mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 19:34:52 +09:00
First operation: createUser
This commit is contained in:
fr33domlover
parent
6440550f48
commit
aa351c00d2
1 changed files with 106 additions and 71 deletions
171
src/Vervis.hs
171
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)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue