138 lines
4.1 KiB
Haskell
138 lines
4.1 KiB
Haskell
{- 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
|