Vervis/src-old/Vervis/Monad.hs
2016-02-13 03:35:30 +00:00

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