Add state and env to the monad, completing step 4

This commit is contained in:
fr33domlover 2016-02-01 14:17:28 +00:00
parent 56dddddde6
commit 81f8dba101

View file

@ -16,12 +16,25 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Vervis module Vervis
( User (..) ( UserID (..)
, GroupID (..)
, RepoID (..)
, ProjID (..)
, Username (..)
, PasswordHash (..)
, RealName (..)
, EmailAddress (..)
, GroupName (..)
, RepoName (..)
, ProjectName (..)
, User (..)
, Group (..) , Group (..)
, IrcChannel (..) , IrcChannel (..)
, Repository (..) , Repository (..)
, Server (..) , Project (..)
, Vervis () , Vervis ()
, runVervis
, Server (..)--TODO remove this type later...
, subdirs , subdirs
, lastChange , lastChange
, timeAgo , timeAgo
@ -39,10 +52,11 @@ import Data.Git
import Data.Git.Revision import Data.Git.Revision
import Data.Git.Repository import Data.Git.Repository
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy (HashMap)
import Data.HashSet (HashSet)
import Data.Hourglass import Data.Hourglass
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text) import Data.Text (Text)
import System.Directory.Tree import System.Directory.Tree hiding (name)
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.Hourglass (dateCurrent) import System.Hourglass (dateCurrent)
@ -50,16 +64,41 @@ import qualified Data.CaseInsensitive as CI (original)
import qualified Data.HashMap.Lazy as M import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T import qualified Data.Text as T
newtype UserID = UserID { unUserID :: Int }
newtype GroupID = GroupID { unGroupID :: Int }
newtype RepoID = RepoID { unRepoID :: Int }
newtype ProjID = ProjID { unProjID :: Int }
newtype Username = Username { unUsername :: CI Text }
newtype PasswordHash = PasswordHash { unPasswordHash :: Text }
newtype RealName = RealName { unRealName :: Text }
data EmailAddress = EmailAddress
{ emailUser :: Text
, emailHost :: Text
}
newtype GroupName = GroupName { unGroupName :: CI Text }
newtype RepoName = RepoName { unRepoName :: CI Text }
newtype ProjectName = ProjectName { unProjectName :: CI Text }
data User = User data User = User
{ userNick :: CI Text { userName :: Username
, userPassHash :: Text , userPassHash :: Maybe PasswordHash -- to disable pass and use SSH only?
, userName :: Text , userRealName :: RealName
, userEmail :: Text , userEmail :: EmailAddress
} }
data Group = Group data Group = Group
{ groupName :: CI Text { groupName :: GroupName
, groupUsers :: [Int] , groupUsers :: HashSet UserID
} }
data IrcChannel = IrcChannel data IrcChannel = IrcChannel
@ -68,25 +107,25 @@ data IrcChannel = IrcChannel
} }
data Repository = Repository data Repository = Repository
{ repoName :: CI Text { repoName :: RepoName
, repoIRC :: Maybe IrcChannel , repoIRC :: Maybe IrcChannel
, repoML :: Maybe Text , repoML :: Maybe Text
} }
data Server = Server data Project = Project
{ serverName :: Text { projName :: ProjectName
, serverDir :: FilePath , projRepos :: HashMap RepoID Repository
, serverUsers :: HashMap Int User
, serverGroups :: HashMap Int Group
, serverRepos :: HashMap (Either Int Int) [Repository]
} }
data VervisEnv = VervisEnv data VervisEnv = VervisEnv
{ { veName :: Text
, veDir :: FilePath
} }
data VervisState = VervisState data VervisState = VervisState
{ { vsUsers :: HashMap UserID User
, vsGroups :: HashMap GroupID Group
, vsProjects :: HashMap ProjID Project
} }
newtype Vervis a = Vervis { unVervis :: RWST VervisEnv () VervisState IO a } newtype Vervis a = Vervis { unVervis :: RWST VervisEnv () VervisState IO a }
@ -99,6 +138,33 @@ runVervis' venv vstate computation = do
(a, s, _) <- runRWST rwst venv vstate (a, s, _) <- runRWST rwst venv vstate
return (a, s) return (a, s)
-- | Run a Vervis server computation.
runVervis
:: Text -- ^ Server name, e.g. @hub.vervis.org@
-> FilePath -- ^ Path to the directory containing the namespace/repo tree
-> Vervis a -- ^ Computation to run
-> IO a
runVervis name dir comp = do
let venv = VervisEnv
{ veName = name
, veDir = dir
}
vstate = VervisState
{ vsUsers = M.empty
, vsGroups = M.empty
, vsProjects = M.empty
}
(a, _s) <- runVervis' venv vstate comp
return a
data Server = Server
{ serverName :: Text
, serverDir :: FilePath
, serverUsers :: HashMap Int User
, serverGroups :: HashMap Int Group
, serverRepos :: HashMap (Either Int Int) [Repository]
}
subdirs :: FilePath -> IO [FilePath] subdirs :: FilePath -> IO [FilePath]
subdirs dir = do subdirs dir = do
_base :/ tree <- buildL dir _base :/ tree <- buildL dir
@ -166,18 +232,20 @@ repoPaths server (Left uid) repos =
Nothing -> error "';..;'" Nothing -> error "';..;'"
Just user -> Just user ->
let dir = serverDir server let dir = serverDir server
ns = T.unpack $ CI.original $ userNick user ns = T.unpack $ CI.original $ unUsername $ userName user
prefix = dir </> ns prefix = dir </> ns
repoNames = map (T.unpack . CI.original . repoName) repos repoNames =
map (T.unpack . CI.original . unRepoName . repoName) repos
in map (prefix </>) repoNames in map (prefix </>) repoNames
repoPaths server (Right gid) repos = repoPaths server (Right gid) repos =
case M.lookup gid $ serverGroups server of case M.lookup gid $ serverGroups server of
Nothing -> error "';..;'" Nothing -> error "';..;'"
Just group -> Just group ->
let dir = serverDir server let dir = serverDir server
ns = T.unpack $ CI.original $ groupName group ns = T.unpack $ CI.original $ unGroupName $ groupName group
prefix = dir </> ns prefix = dir </> ns
repoNames = map (T.unpack . CI.original . repoName) repos repoNames =
map (T.unpack . CI.original . unRepoName . repoName) repos
in map (prefix </>) repoNames in map (prefix </>) repoNames
timesAgo :: Server -> IO [(Text, Text)] timesAgo :: Server -> IO [(Text, Text)]