Remove the src-old dir, no need for it anymore (since long time ago)
This commit is contained in:
fr33domlover
parent
f9045e211b
commit
fe4d1e1afe
2 changed files with 0 additions and 245 deletions
|
|
@ -1,138 +0,0 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Vervis.Monad
|
||||
( VervisEnv (..)
|
||||
, VervisState (..)
|
||||
, Vervis ()
|
||||
, runVervis
|
||||
, ask
|
||||
, asks
|
||||
, get
|
||||
, gets
|
||||
, put
|
||||
, modify
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.Fix (MonadFix)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.RWS (RWST (..))
|
||||
import Data.Aeson
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Git
|
||||
import Data.Git.Revision
|
||||
import Data.Git.Repository
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Hourglass
|
||||
import Data.JsonState
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Units
|
||||
import GHC.Generics
|
||||
import System.Directory.Tree hiding (name, file, err)
|
||||
import System.FilePath ((</>))
|
||||
import System.Hourglass (dateCurrent)
|
||||
import Vervis.Types
|
||||
|
||||
import qualified Control.Monad.Trans.RWS as RWS
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import qualified Data.Text as T
|
||||
|
||||
data VervisEnv = VervisEnv
|
||||
{ veName :: Text
|
||||
, veDir :: FilePath
|
||||
, veSave :: VervisState -> Vervis ()
|
||||
}
|
||||
|
||||
data VervisState = VervisState
|
||||
{ vsUsers :: HashMap UserID User
|
||||
, vsGroups :: HashMap GroupID Group
|
||||
, vsProjects :: HashMap (Either UserID GroupID) (HashMap ProjID Project)
|
||||
, vsNextUser :: UserID
|
||||
, vsNextGroup :: GroupID
|
||||
, vsNextProject :: ProjID
|
||||
}
|
||||
deriving Generic
|
||||
|
||||
instance ToJSON VervisState
|
||||
instance FromJSON VervisState
|
||||
|
||||
newtype Vervis a = Vervis { unVervis :: RWST VervisEnv () VervisState IO a }
|
||||
deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
|
||||
|
||||
-- internal func, wrap with API func which hides env and state details
|
||||
runVervis' :: VervisEnv -> VervisState -> Vervis a -> IO (a, VervisState)
|
||||
runVervis' venv vstate computation = do
|
||||
let rwst = unVervis computation
|
||||
(a, s, _) <- runRWST rwst venv vstate
|
||||
return (a, s)
|
||||
|
||||
-- | Run a Vervis server computation.
|
||||
runVervis
|
||||
:: Text -- ^ Server name, e.g. @hub.vervis.org@
|
||||
-> FilePath -- ^ Path of database file, which is really JSON currently
|
||||
-> FilePath -- ^ Path to the directory containing the namespace/repo tree
|
||||
-> Vervis a -- ^ Computation to run
|
||||
-> IO a
|
||||
runVervis name file dir comp = do
|
||||
result <- loadState file
|
||||
case result of
|
||||
Left (False, err) -> error $ "Loading JSON state failed: " ++ err
|
||||
Left (True, err) -> error $ "Parsing JSON state failed: " ++ err
|
||||
Right vstate -> do
|
||||
save <- mkSaveState (3 :: Second) file
|
||||
let venv = VervisEnv
|
||||
{ veName = name
|
||||
, veDir = dir
|
||||
, veSave = liftIO . save
|
||||
}
|
||||
(a, _s) <- runVervis' venv vstate comp
|
||||
return a
|
||||
|
||||
-- | Fetch the value of the environment.
|
||||
ask :: Vervis VervisEnv
|
||||
ask = Vervis RWS.ask
|
||||
|
||||
-- | Retrieve a function of the current environment.
|
||||
asks :: (VervisEnv -> a) -> Vervis a
|
||||
asks = Vervis . RWS.asks
|
||||
|
||||
-- | Fetch the current value of the state within the monad.
|
||||
get :: Vervis VervisState
|
||||
get = Vervis RWS.get
|
||||
|
||||
-- | Get a specific component of the state, using a projection function
|
||||
-- supplied.
|
||||
gets :: (VervisState -> a) -> Vervis a
|
||||
gets = Vervis . RWS.gets
|
||||
|
||||
-- | @'put' s@ sets the state within the monad to @s@.
|
||||
put :: VervisState -> Vervis ()
|
||||
put = Vervis . RWS.put
|
||||
|
||||
-- | @'modify' f@ is an action that updates the state to the result of
|
||||
-- applying @f@ to the current state.
|
||||
modify :: (VervisState -> VervisState) -> Vervis ()
|
||||
modify = Vervis . RWS.modify
|
||||
|
|
@ -1,107 +0,0 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Vervis.Persist
|
||||
--(
|
||||
--)
|
||||
where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import Control.Monad.Logger (runStderrLoggingT)
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable (forM)
|
||||
import Database.Esqueleto ((^.), (&&.), (==.))
|
||||
import Database.Persist hiding ((==.))
|
||||
import Database.Persist.Sqlite hiding ((==.))
|
||||
import Database.Persist.TH
|
||||
import Vervis.Git
|
||||
import Yesod hiding ((==.))
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = do
|
||||
rows <- runDB $ do
|
||||
repos <- E.select $ E.from $ \ (sharer, project, repo) -> do
|
||||
E.where_ $
|
||||
project ^. ProjectSharer ==. sharer ^. SharerId &&.
|
||||
repo ^. RepoProject ==. project ^. ProjectId
|
||||
E.orderBy
|
||||
[ E.asc $ sharer ^. SharerIdent
|
||||
, E.asc $ project ^. ProjectIdent
|
||||
, E.asc $ repo ^. RepoIdent
|
||||
]
|
||||
return
|
||||
( sharer ^. SharerIdent
|
||||
, project ^. ProjectIdent
|
||||
, repo ^. RepoIdent
|
||||
)
|
||||
liftIO $ forM repos $ \ (E.Value sharer, E.Value project, E.Value repo) -> do
|
||||
let path =
|
||||
T.unpack $
|
||||
T.intercalate "/"
|
||||
[ "state2"
|
||||
, sharer
|
||||
, project
|
||||
, repo
|
||||
]
|
||||
dt <- lastChange path
|
||||
ago <- timeAgo dt
|
||||
return (sharer, project, repo, T.pack ago)
|
||||
|
||||
mainView :: IO ()
|
||||
mainView =
|
||||
runStderrLoggingT $
|
||||
withSqlitePool "test.db3" openConnectionCount $
|
||||
\ pool -> liftIO $ do
|
||||
runResourceT $ flip runSqlPool pool $ do
|
||||
runMigration migrateAll
|
||||
|
||||
cindyId <- insert $ Sharer "cindy" Nothing
|
||||
bobId <- insert $ Sharer "bob" Nothing
|
||||
aliceId <- insert $ Sharer "alice" Nothing
|
||||
|
||||
proj4Id <- insert $ Project "proj4" cindyId Nothing Nothing
|
||||
proj2Id <- insert $ Project "proj2" aliceId Nothing Nothing
|
||||
proj6Id <- insert $ Project "proj6" cindyId Nothing Nothing
|
||||
proj3Id <- insert $ Project "proj3" bobId Nothing Nothing
|
||||
proj5Id <- insert $ Project "proj5" cindyId Nothing Nothing
|
||||
proj1Id <- insert $ Project "proj1" aliceId Nothing Nothing
|
||||
|
||||
insert_ $ Repo "repo8" proj5Id Nothing Nothing
|
||||
insert_ $ Repo "repo1" proj1Id Nothing Nothing
|
||||
insert_ $ Repo "repo6" proj4Id Nothing Nothing
|
||||
insert_ $ Repo "repo3" proj3Id Nothing Nothing
|
||||
insert_ $ Repo "repo4" proj3Id Nothing Nothing
|
||||
insert_ $ Repo "repo10" proj6Id Nothing Nothing
|
||||
insert_ $ Repo "repo5" proj4Id Nothing Nothing
|
||||
insert_ $ Repo "repo7" proj5Id Nothing Nothing
|
||||
insert_ $ Repo "repo2" proj2Id Nothing Nothing
|
||||
insert_ $ Repo "repo9" proj5Id Nothing Nothing
|
||||
insert_ $ Repo "repo11" proj6Id Nothing Nothing
|
||||
insert_ $ Repo "repo12" proj6Id Nothing Nothing
|
||||
warp 3000 $ MainView pool
|
||||
Loading…
Reference in a new issue