Add state and env to the monad, completing step 4

src/Vervis.hs

@@ -16,12 +16,25 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Vervis
-    ( User (..)
+    ( UserID (..)
+    , GroupID (..)
+    , RepoID (..)
+    , ProjID (..)
+    , Username (..)
+    , PasswordHash (..)
+    , RealName (..)
+    , EmailAddress (..)
+    , GroupName (..)
+    , RepoName (..)
+    , ProjectName (..)
+    , User (..)
     , Group (..)
     , IrcChannel (..)
     , Repository (..)
-    , Server (..)
+    , Project (..)
     , Vervis ()
+    , runVervis
+    , Server (..)--TODO remove this type later...
     , subdirs
     , lastChange
     , timeAgo
@@ -39,10 +52,11 @@ import Data.Git
 import Data.Git.Revision
 import Data.Git.Repository
 import Data.HashMap.Lazy (HashMap)
+import Data.HashSet (HashSet)
 import Data.Hourglass
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Text (Text)
-import System.Directory.Tree
+import System.Directory.Tree hiding (name)
 import System.FilePath ((</>))
 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.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
-    { userNick     :: CI Text
-    , userPassHash :: Text
-    , userName     :: Text
-    , userEmail    :: Text
+    { userName     :: Username
+    , userPassHash :: Maybe PasswordHash -- to disable pass and use SSH only?
+    , userRealName :: RealName
+    , userEmail    :: EmailAddress
     }
 
 data Group = Group
-    { groupName  :: CI Text
-    , groupUsers :: [Int]
+    { groupName  :: GroupName
+    , groupUsers :: HashSet UserID
     }
 
 data IrcChannel = IrcChannel
@@ -68,25 +107,25 @@ data IrcChannel = IrcChannel
     }
 
 data Repository = Repository
-    { repoName :: CI Text
+    { repoName :: RepoName
     , repoIRC  :: Maybe IrcChannel
     , repoML   :: Maybe Text
     }
 
-data Server = Server
-    { serverName   :: Text
-    , serverDir    :: FilePath
-    , serverUsers  :: HashMap Int User
-    , serverGroups :: HashMap Int Group
-    , serverRepos  :: HashMap (Either Int Int) [Repository]
+data Project = Project
+    { projName  :: ProjectName
+    , projRepos :: HashMap RepoID Repository
     }
 
 data VervisEnv = VervisEnv
-    {
+    { veName :: Text
+    , veDir  :: FilePath
     }
 
 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 }
@@ -99,6 +138,33 @@ runVervis' venv vstate computation = do
     (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 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 dir = do
     _base :/ tree <- buildL dir
@@ -166,18 +232,20 @@ repoPaths server (Left uid) repos =
         Nothing   -> error "';..;'"
         Just user ->
             let dir = serverDir server
-                ns = T.unpack $ CI.original $ userNick user
+                ns = T.unpack $ CI.original $ unUsername $ userName user
                 prefix = dir </> ns
-                repoNames = map (T.unpack . CI.original . repoName) repos
+                repoNames =
+                    map (T.unpack . CI.original . unRepoName . repoName) repos
             in  map (prefix </>) repoNames
 repoPaths server (Right gid) repos =
     case M.lookup gid $ serverGroups server of
         Nothing    -> error "';..;'"
         Just group ->
             let dir = serverDir server
-                ns = T.unpack $ CI.original $ groupName group
+                ns = T.unpack $ CI.original $ unGroupName $ groupName group
                 prefix = dir </> ns
-                repoNames = map (T.unpack . CI.original . repoName) repos
+                repoNames =
+                    map (T.unpack . CI.original . unRepoName . repoName) repos
             in  map (prefix </>) repoNames
 
 timesAgo :: Server -> IO [(Text, Text)]