vervis/src-old/Vervis/Monad.hs

{- 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