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] ()
:<|> "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

View file

@ -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!"
}

View file

@ -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

View file

@ -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

View file

@ -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
}
})

View file

@ -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