From f177465f4f60337c5ab8de0ba9cb163b9d0d410b Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 19 Jul 2020 12:27:28 +0200 Subject: [PATCH] do some stuff to make it work --- src/API.hs | 2 +- src/Control/Role.hs | 13 ++++---- src/Control/User.hs | 4 ++- src/Model/Auth.hs | 20 ----------- src/Model/Role.hs | 81 +++++++++++++++++++++++++++------------------ src/Types/Role.hs | 28 ++++++++++++++++ 6 files changed, 87 insertions(+), 61 deletions(-) diff --git a/src/API.hs b/src/API.hs index 2f09dde..c1db490 100644 --- a/src/API.hs +++ b/src/API.hs @@ -76,7 +76,7 @@ type MateAPI = "v1" :> ( :> Patch '[JSON] () :<|> "role" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int :> Delete '[JSON] () - :<|> "role" :> "assiciation" :> "list" + :<|> "role" :> "association" :> "list" :> Get '[JSON] [RoleAssociation] :<|> "role" :> "association" :> AuthProtect "header-auth" :> ReqBody '[JSON] RoleAssociationSubmit diff --git a/src/Control/Role.hs b/src/Control/Role.hs index 6229a1d..51e893b 100644 --- a/src/Control/Role.hs +++ b/src/Control/Role.hs @@ -21,18 +21,19 @@ roleList = do conn <- asks rsConnection selectAllRoles conn -roleNew = notImpelemented +roleNew _ _ = notImplemented -roleUpdate = notImpelemented +roleUpdate _ _ = notImplemented -roleDelete = notImpelemented +roleDelete _ _ = notImplemented -roleAssociationList = notImpelemented +roleAssociationList = notImplemented -roleAssociationSubmit = notImpelemented +roleAssociationSubmit _ _ = notImplemented -roleAssociationDelete = notImpelemented +roleAssociationDelete _ _ = notImplemented +notImplemented :: MateHandler a notImplemented = throwError $ err501 { errBody = "Function has not yet been implemented!" } diff --git a/src/Control/User.hs b/src/Control/User.hs index 59a416a..fae1bba 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -19,6 +19,7 @@ import qualified Data.Text as T import Types import Model +import Control.Role userNew :: UserSubmit @@ -30,7 +31,8 @@ userNew (UserSubmit ident email passhash) = do void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn baseRoleId <- queryRoleIdByCapabilities (False, False, False, False, False, False, False, False, False, False, False) - void $ assiciateuserToRole uid baseRoleId + conn + void $ associateUserToRole uid baseRoleId conn return uid userGet diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index 08cb679..e077506 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -375,33 +375,13 @@ processAuthRequest (AuthRequest aticket hash) store conn = do liftIO $ threadDelay delayTime if now > ticketExpiry ticket then -#if defined(DEVELOP) - do - mockticket <- Ticket <$> - pure aticket <*> - pure 1 <*> - liftIO getCurrentTime <*> - pure (PrimaryPass, Nothing) - generateToken mockticket hash conn -#else return Denied -#endif else -- liftIO $ putStrLn "...and it is valid" generateToken ticket hash conn _ -> do liftIO $ threadDelay delayTime -#if defined(DEVELOP) - do - mockticket <- Ticket <$> - pure aticket <*> - pure 1 <*> - liftIO getCurrentTime <*> - pure (PrimaryPass, Nothing) - generateToken mockticket hash conn -#else return Denied -#endif processLogout :: Int diff --git a/src/Model/Role.hs b/src/Model/Role.hs index 5d0c5dd..ac802b1 100644 --- a/src/Model/Role.hs +++ b/src/Model/Role.hs @@ -8,9 +8,13 @@ import qualified Database.PostgreSQL.Simple as PGS import Data.Profunctor.Product (p2, p13) +import qualified Data.Text as T + import Opaleye as O hiding (null, not) import Opaleye.Constant as C +import Control.Arrow ((<<<)) + import Control.Monad import Control.Monad.IO.Class (liftIO) @@ -167,7 +171,7 @@ selectAllRoles selectAllRoles conn = do rawRoles <- liftIO $ runSelect conn ( queryTable roleTable - ) :: Matehandler + ) :: MateHandler [ ( Int , T.Text @@ -194,10 +198,10 @@ queryRoleIdByName :: T.Text -> PGS.Connection -> MateHandler Int -queryRoleIdByName name con = do +queryRoleIdByName name conn = do roles <- liftIO $ runSelect conn ( keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _, _) -> - C.constant name == rname) <<< queryTable roleTable + C.constant name .== rname) <<< queryTable roleTable ) :: MateHandler [ ( Int @@ -221,45 +225,56 @@ queryRoleIdByCapabilities :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) -> PGS.Connection -> MateHandler Int -queryRoleIdByName caps con = do - roles <- liftIO $ runSelect conn ( - keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) -> - C.constant caps == (c1, c2, c3, vc4, c5, c6, c7, c8, c9, c10, c11)) - <<< queryTable roleTable - ) :: MateHandler - [ - ( Int - , T.Text - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - ) - ] - return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) +queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) conn = + do + roles <- liftIO $ runSelect conn ( + keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) -> + C.constant p1 .== c1 .&& + C.constant p2 .== c2 .&& + C.constant p3 .== c3 .&& + C.constant p4 .== c4 .&& + C.constant p5 .== c5 .&& + C.constant p6 .== c6 .&& + C.constant p7 .== c7 .&& + C.constant p8 .== c8 .&& + C.constant p9 .== c9 .&& + C.constant p10 .== c10 .&& + C.constant p11 .== c11 + ) + <<< queryTable roleTable + ) :: MateHandler + [ + ( Int + , T.Text + , Bool + , Bool + , Bool + , Bool + , Bool + , Bool + , Bool + , Bool + , Bool + , Bool + , Bool + ) + ] + return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) associateUserToRole :: Int -- ^ User id -> Int -- ^ Role id -> PGS.Connection - -> Matehandler Int -- ^ Resulting UserToRole id -associateUserToRole uid rid conn = do - a <- runInsert_ conn $ Insert + -> MateHandler () -- ^ Resulting UserToRole id +associateUserToRole uid rid conn = + head <$> liftIO (runInsert_ conn $ Insert { iTable = userToRoleTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant uid + ( C.constant uid , C.constant rid ) ] - , iReturning = rReturning (\(id_, _, _) -> id_ ) + , iReturning = rReturning (const ()) , iOnConflict = Nothing - } + }) diff --git a/src/Types/Role.hs b/src/Types/Role.hs index b3e3636..52c1af4 100644 --- a/src/Types/Role.hs +++ b/src/Types/Role.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE DeriveGeneric #-} module Types.Role where import qualified Data.Text as T +import Data.Aeson + +import GHC.Generics data Role = Role { roleID :: Int @@ -17,6 +21,12 @@ data Role = Role , roleCanManageSuppliers :: Bool , roleCanManageSettings :: Bool } + deriving (Generic, Show) + +instance ToJSON Role where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON Role data RoleSubmit = RoleSubmit { roleSubmitName :: T.Text @@ -32,14 +42,32 @@ data RoleSubmit = RoleSubmit , roleSubmitCanManageSuppliers :: Bool , roleSubmitCanManageSettings :: Bool } + deriving (Generic, Show) + +instance ToJSON RoleSubmit where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON RoleSubmit data RoleAssociation = RoleAssociation { roleAssociationId :: Int , roleAssociationUser :: Int , roleAssociationRole :: Int } + deriving (Generic, Show) + +instance ToJSON RoleAssociation where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON RoleAssociation data RoleAssociationSubmit = RoleAssociationSubmit { roleAssociationSubmitUser :: Int , roleAssociationSubmitRole :: Int } + deriving (Generic, Show) + +instance ToJSON RoleAssociationSubmit where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON RoleAssociationSubmit