do some stuff to make it work

This commit is contained in:
nek0 2020-07-19 12:27:28 +02:00
parent 786cddd7b3
commit f177465f4f
6 changed files with 87 additions and 61 deletions

View file

@ -76,7 +76,7 @@ type MateAPI = "v1" :> (
:> Patch '[JSON] () :> Patch '[JSON] ()
:<|> "role" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int :<|> "role" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int
:> Delete '[JSON] () :> Delete '[JSON] ()
:<|> "role" :> "assiciation" :> "list" :<|> "role" :> "association" :> "list"
:> Get '[JSON] [RoleAssociation] :> Get '[JSON] [RoleAssociation]
:<|> "role" :> "association" :> AuthProtect "header-auth" :<|> "role" :> "association" :> AuthProtect "header-auth"
:> ReqBody '[JSON] RoleAssociationSubmit :> ReqBody '[JSON] RoleAssociationSubmit

View file

@ -21,18 +21,19 @@ roleList = do
conn <- asks rsConnection conn <- asks rsConnection
selectAllRoles conn 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 notImplemented = throwError $ err501
{ errBody = "Function has not yet been implemented!" { errBody = "Function has not yet been implemented!"
} }

View file

@ -19,6 +19,7 @@ import qualified Data.Text as T
import Types import Types
import Model import Model
import Control.Role
userNew userNew
:: UserSubmit :: UserSubmit
@ -30,7 +31,8 @@ userNew (UserSubmit ident email passhash) = do
void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
baseRoleId <- queryRoleIdByCapabilities baseRoleId <- queryRoleIdByCapabilities
(False, False, False, False, False, False, False, False, False, False, False) (False, False, False, False, False, False, False, False, False, False, False)
void $ assiciateuserToRole uid baseRoleId conn
void $ associateUserToRole uid baseRoleId conn
return uid return uid
userGet userGet

View file

@ -375,33 +375,13 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
if now > ticketExpiry ticket if now > ticketExpiry ticket
then then
#if defined(DEVELOP)
do
mockticket <- Ticket <$>
pure aticket <*>
pure 1 <*>
liftIO getCurrentTime <*>
pure (PrimaryPass, Nothing)
generateToken mockticket hash conn
#else
return Denied return Denied
#endif
else else
-- liftIO $ putStrLn "...and it is valid" -- liftIO $ putStrLn "...and it is valid"
generateToken ticket hash conn generateToken ticket hash conn
_ -> do _ -> do
liftIO $ threadDelay delayTime 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 return Denied
#endif
processLogout processLogout
:: Int :: Int

View file

@ -8,9 +8,13 @@ import qualified Database.PostgreSQL.Simple as PGS
import Data.Profunctor.Product (p2, p13) import Data.Profunctor.Product (p2, p13)
import qualified Data.Text as T
import Opaleye as O hiding (null, not) import Opaleye as O hiding (null, not)
import Opaleye.Constant as C import Opaleye.Constant as C
import Control.Arrow ((<<<))
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -167,7 +171,7 @@ selectAllRoles
selectAllRoles conn = do selectAllRoles conn = do
rawRoles <- liftIO $ runSelect conn ( rawRoles <- liftIO $ runSelect conn (
queryTable roleTable queryTable roleTable
) :: Matehandler ) :: MateHandler
[ [
( Int ( Int
, T.Text , T.Text
@ -194,10 +198,10 @@ queryRoleIdByName
:: T.Text :: T.Text
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
queryRoleIdByName name con = do queryRoleIdByName name conn = do
roles <- liftIO $ runSelect conn ( roles <- liftIO $ runSelect conn (
keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _, _) -> keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _, _) ->
C.constant name == rname) <<< queryTable roleTable C.constant name .== rname) <<< queryTable roleTable
) :: MateHandler ) :: MateHandler
[ [
( Int ( Int
@ -221,45 +225,56 @@ queryRoleIdByCapabilities
:: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
queryRoleIdByName caps con = do queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) conn =
roles <- liftIO $ runSelect conn ( do
keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) -> roles <- liftIO $ runSelect conn (
C.constant caps == (c1, c2, c3, vc4, c5, c6, c7, c8, c9, c10, c11)) keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) ->
<<< queryTable roleTable C.constant p1 .== c1 .&&
) :: MateHandler C.constant p2 .== c2 .&&
[ C.constant p3 .== c3 .&&
( Int C.constant p4 .== c4 .&&
, T.Text C.constant p5 .== c5 .&&
, Bool C.constant p6 .== c6 .&&
, Bool C.constant p7 .== c7 .&&
, Bool C.constant p8 .== c8 .&&
, Bool C.constant p9 .== c9 .&&
, Bool C.constant p10 .== c10 .&&
, Bool C.constant p11 .== c11
, Bool )
, Bool <<< queryTable roleTable
, Bool ) :: MateHandler
, Bool [
, Bool ( Int
) , T.Text
] , Bool
return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) , Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
)
]
return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles)
associateUserToRole associateUserToRole
:: Int -- ^ User id :: Int -- ^ User id
-> Int -- ^ Role id -> Int -- ^ Role id
-> PGS.Connection -> PGS.Connection
-> Matehandler Int -- ^ Resulting UserToRole id -> MateHandler () -- ^ Resulting UserToRole id
associateUserToRole uid rid conn = do associateUserToRole uid rid conn =
a <- runInsert_ conn $ Insert head <$> liftIO (runInsert_ conn $ Insert
{ iTable = userToRoleTable { iTable = userToRoleTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( C.constant uid
, C.constant uid
, C.constant rid , C.constant rid
) )
] ]
, iReturning = rReturning (\(id_, _, _) -> id_ ) , iReturning = rReturning (const ())
, iOnConflict = Nothing , iOnConflict = Nothing
} })

View file

@ -1,6 +1,10 @@
{-# LANGUAGE DeriveGeneric #-}
module Types.Role where module Types.Role where
import qualified Data.Text as T import qualified Data.Text as T
import Data.Aeson
import GHC.Generics
data Role = Role data Role = Role
{ roleID :: Int { roleID :: Int
@ -17,6 +21,12 @@ data Role = Role
, roleCanManageSuppliers :: Bool , roleCanManageSuppliers :: Bool
, roleCanManageSettings :: Bool , roleCanManageSettings :: Bool
} }
deriving (Generic, Show)
instance ToJSON Role where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Role
data RoleSubmit = RoleSubmit data RoleSubmit = RoleSubmit
{ roleSubmitName :: T.Text { roleSubmitName :: T.Text
@ -32,14 +42,32 @@ data RoleSubmit = RoleSubmit
, roleSubmitCanManageSuppliers :: Bool , roleSubmitCanManageSuppliers :: Bool
, roleSubmitCanManageSettings :: Bool , roleSubmitCanManageSettings :: Bool
} }
deriving (Generic, Show)
instance ToJSON RoleSubmit where
toEncoding = genericToEncoding defaultOptions
instance FromJSON RoleSubmit
data RoleAssociation = RoleAssociation data RoleAssociation = RoleAssociation
{ roleAssociationId :: Int { roleAssociationId :: Int
, roleAssociationUser :: Int , roleAssociationUser :: Int
, roleAssociationRole :: Int , roleAssociationRole :: Int
} }
deriving (Generic, Show)
instance ToJSON RoleAssociation where
toEncoding = genericToEncoding defaultOptions
instance FromJSON RoleAssociation
data RoleAssociationSubmit = RoleAssociationSubmit data RoleAssociationSubmit = RoleAssociationSubmit
{ roleAssociationSubmitUser :: Int { roleAssociationSubmitUser :: Int
, roleAssociationSubmitRole :: Int , roleAssociationSubmitRole :: Int
} }
deriving (Generic, Show)
instance ToJSON RoleAssociationSubmit where
toEncoding = genericToEncoding defaultOptions
instance FromJSON RoleAssociationSubmit