First operation: createUser

src/Vervis.hs

@@ -37,6 +37,7 @@ module Vervis
     , Vervis ()
     , runVervis
     , saveState
+    , createUser
     , Server (..)--TODO remove this type later...
     , subdirs
     , lastChange
@@ -73,81 +74,20 @@ import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Lazy as M
 import qualified Data.Text as T
 
--- | Fetch the value of the environment.
+-------------------------------------------------------------------------------
-ask :: Vervis (VervisEnv)
+-- Types
-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
-
-instance (CI.FoldCase a, FromJSON a) => FromJSON (CI a) where
-    parseJSON v = CI.mk <$> parseJSON v
-
-instance ToJSON a => ToJSON (CI a) where
-    toJSON = toJSON . CI.original
-
-class WrappedText a where
-    toText   :: a -> Text
-    fromText :: Text -> a
-
-instance WrappedText Text where
-    toText   = id
-    fromText = id
-
-instance (WrappedText a, CI.FoldCase a) => WrappedText (CI a) where
-    toText   = toText . CI.original
-    fromText = CI.mk . fromText
-
-instance WrappedText Int where
-    toText   = T.pack . show
-    fromText = read . T.unpack
-
-mapFst :: (a -> c) -> [(a, b)] -> [(c, b)]
-mapFst f = map $ \ (x, y) -> (f x, y)
-
-instance (Eq k, Hashable k, WrappedText k, FromJSON v) => FromJSON (HashMap k v) where
-    parseJSON v = M.fromList . mapFst fromText . M.toList <$> parseJSON v
-
-instance (WrappedText k, ToJSON v) => ToJSON (HashMap k v) where
-    toJSON = toJSON . M.fromList . mapFst toText . M.toList
-
-instance (WrappedText a, WrappedText b) => WrappedText (Either a b) where
-    toText (Left x) = 'l' `T.cons` toText x
-    toText (Right y) = 'r' `T.cons` toText y
-    fromText t =
-        case T.uncons t of
-            Nothing       -> error "blank JSON field name???"
-            Just ('l', r) -> Left $ fromText r
-            Just ('r', r) -> Right $ fromText r
-            _             -> error "what is dis ting"
 
 newtype UserID = UserID { unUserID :: Int }
     deriving (Eq, Hashable, FromJSON, ToJSON, WrappedText)
 
-newtype GroupID = GroupID { unGroupID :: Int } deriving (Eq, Hashable, WrappedText)
+newtype GroupID = GroupID { unGroupID :: Int }
+    deriving (Eq, Hashable, FromJSON, ToJSON, WrappedText)
 
 newtype RepoID = RepoID { unRepoID :: Int } deriving (Eq, Hashable, WrappedText)
 
-newtype ProjID = ProjID { unProjID :: Int } deriving (Eq, Hashable, WrappedText)
+newtype ProjID = ProjID { unProjID :: Int }
+    deriving (Eq, Hashable, FromJSON, ToJSON, WrappedText)
 
 newtype Username = Username { unUsername :: CI Text }
     deriving (FromJSON, ToJSON)
@@ -233,6 +173,9 @@ 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
 
@@ -242,6 +185,85 @@ instance FromJSON VervisState
 newtype Vervis a = Vervis { unVervis :: RWST VervisEnv () VervisState IO a }
     deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
 
+-------------------------------------------------------------------------------
+-- Instances
+-------------------------------------------------------------------------------
+
+instance (CI.FoldCase a, FromJSON a) => FromJSON (CI a) where
+    parseJSON v = CI.mk <$> parseJSON v
+
+instance ToJSON a => ToJSON (CI a) where
+    toJSON = toJSON . CI.original
+
+class WrappedText a where
+    toText   :: a -> Text
+    fromText :: Text -> a
+
+instance WrappedText Text where
+    toText   = id
+    fromText = id
+
+instance (WrappedText a, CI.FoldCase a) => WrappedText (CI a) where
+    toText   = toText . CI.original
+    fromText = CI.mk . fromText
+
+instance WrappedText Int where
+    toText   = T.pack . show
+    fromText = read . T.unpack
+
+mapFst :: (a -> c) -> [(a, b)] -> [(c, b)]
+mapFst f = map $ \ (x, y) -> (f x, y)
+
+instance (Eq k, Hashable k, WrappedText k, FromJSON v) => FromJSON (HashMap k v) where
+    parseJSON v = M.fromList . mapFst fromText . M.toList <$> parseJSON v
+
+instance (WrappedText k, ToJSON v) => ToJSON (HashMap k v) where
+    toJSON = toJSON . M.fromList . mapFst toText . M.toList
+
+instance (WrappedText a, WrappedText b) => WrappedText (Either a b) where
+    toText (Left x) = 'l' `T.cons` toText x
+    toText (Right y) = 'r' `T.cons` toText y
+    fromText t =
+        case T.uncons t of
+            Nothing       -> error "blank JSON field name???"
+            Just ('l', r) -> Left $ fromText r
+            Just ('r', r) -> Right $ fromText r
+            _             -> error "what is dis ting"
+
+-------------------------------------------------------------------------------
+-- Monad
+-------------------------------------------------------------------------------
+
+-- | 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
+
+-------------------------------------------------------------------------------
+-- Operations
+-------------------------------------------------------------------------------
+
 -- 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
@@ -277,6 +299,19 @@ saveState = do
     vstate <- get
     save vstate
 
+createUser :: User -> Vervis ()
+createUser user = do
+    vstate <- get
+    let users = vsUsers vstate
+        next = vsNextUser vstate
+        users' = M.insert next user users'
+    put vstate { vsUsers = users', vsNextUser = UserID $ unUserID next + 1 }
+    saveState
+
+-------------------------------------------------------------------------------
+-- Git Utils
+-------------------------------------------------------------------------------
+
 data Server = Server
     { serverName   :: Text
     , serverDir    :: FilePath