diff --git a/src/Vervis.hs b/src/Vervis.hs index 23cb893..5b6196f 100644 --- a/src/Vervis.hs +++ b/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) -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" +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- 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) @@ -230,9 +170,12 @@ data VervisEnv = VervisEnv } data VervisState = VervisState - { vsUsers :: HashMap UserID User - , vsGroups :: HashMap GroupID Group - , vsProjects :: HashMap (Either UserID GroupID) (HashMap ProjID Project) + { 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