|
|
|
|
@ -1,42 +1,112 @@
|
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
|
|
|
|
|
|
module Handler.ExamOffice.Users
|
|
|
|
|
( getEOUsersR
|
|
|
|
|
, postEOUsersR
|
|
|
|
|
( getEOUsersR, postEOUsersR
|
|
|
|
|
, getEOUsersInviteR, postEOUsersInviteR
|
|
|
|
|
) where
|
|
|
|
|
|
|
|
|
|
import Import
|
|
|
|
|
import Utils.Form
|
|
|
|
|
import Handler.Utils
|
|
|
|
|
import Handler.Utils.Invitations
|
|
|
|
|
|
|
|
|
|
import Text.Hamlet (ihamlet)
|
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
|
|
|
import Jobs.Queue
|
|
|
|
|
|
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
import Data.Map ((!))
|
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
import Data.Map ((!), (!?))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
makeExamOfficeUsersForm :: Maybe (Set UserId) -> Form (Set UserId)
|
|
|
|
|
instance IsInvitableJunction ExamOfficeUser where
|
|
|
|
|
type InvitationFor ExamOfficeUser = User
|
|
|
|
|
data InvitableJunction ExamOfficeUser = JunctionExamOfficeUser
|
|
|
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
data InvitationDBData ExamOfficeUser = InvDBDataExamOfficeUser
|
|
|
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
data InvitationTokenData ExamOfficeUser = InvTokenDataExamOfficeUser
|
|
|
|
|
{ invTokenExamOfficeUserOffice :: CryptoUUIDUser
|
|
|
|
|
}
|
|
|
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
|
|
|
|
|
_InvitableJunction = iso
|
|
|
|
|
(\ExamOfficeUser{..} -> (examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser))
|
|
|
|
|
(\(examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser) -> ExamOfficeUser{..})
|
|
|
|
|
|
|
|
|
|
instance ToJSON (InvitableJunction ExamOfficeUser) where
|
|
|
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
|
instance FromJSON (InvitableJunction ExamOfficeUser) where
|
|
|
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
|
|
|
|
|
|
instance ToJSON (InvitationDBData ExamOfficeUser) where
|
|
|
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
|
instance FromJSON (InvitationDBData ExamOfficeUser) where
|
|
|
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
|
|
|
|
|
|
instance ToJSON (InvitationTokenData ExamOfficeUser) where
|
|
|
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
|
|
|
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
|
|
|
|
|
instance FromJSON (InvitationTokenData ExamOfficeUser) where
|
|
|
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
|
|
|
|
|
|
|
|
|
|
examOfficeUserInvitationConfig :: InvitationConfig ExamOfficeUser
|
|
|
|
|
examOfficeUserInvitationConfig = InvitationConfig{..}
|
|
|
|
|
where
|
|
|
|
|
invitationRoute _ _ = return $ ExamOfficeR EOUsersInviteR
|
|
|
|
|
invitationResolveFor InvTokenDataExamOfficeUser{..} = do
|
|
|
|
|
officeId <- decrypt invTokenExamOfficeUserOffice
|
|
|
|
|
bool notFound (return officeId) =<< existsKey officeId
|
|
|
|
|
invitationSubject (Entity _ User{..}) _ = do
|
|
|
|
|
return . SomeMessage $ MsgMailSubjectExamOfficeUserInvitation userDisplayName
|
|
|
|
|
invitationHeading (Entity _ User{..}) _ = do
|
|
|
|
|
return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
|
|
|
|
|
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
|
|
|
|
|
invitationTokenConfig _ _ = do
|
|
|
|
|
itAuthority <- liftHandlerT requireAuthId
|
|
|
|
|
let itExpiresAt = Nothing
|
|
|
|
|
itStartsAt = Nothing
|
|
|
|
|
itAddAuth = Nothing
|
|
|
|
|
return InvitationTokenConfig{..}
|
|
|
|
|
invitationRestriction _ _ = return Authorized
|
|
|
|
|
invitationForm _ _ _ = pure (JunctionExamOfficeUser, ())
|
|
|
|
|
invitationInsertHook _ _ ExamOfficeUser{..} _ act = do
|
|
|
|
|
res <- act
|
|
|
|
|
audit $ TransactionExamOfficeUserAdd examOfficeUserOffice examOfficeUserUser
|
|
|
|
|
return res
|
|
|
|
|
invitationSuccessMsg _ _ =
|
|
|
|
|
return $ SomeMessage MsgExamOfficeUserInvitationAccepted
|
|
|
|
|
invitationUltDest _ _ = return $ SomeRoute HomeR
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
|
|
|
|
|
makeExamOfficeUsersForm template = renderWForm FormStandard $ do
|
|
|
|
|
Just cRoute <- getCurrentRoute
|
|
|
|
|
|
|
|
|
|
let
|
|
|
|
|
sortProj = over _1 ((readMay :: Text -> Maybe Integer) =<<) . view _2
|
|
|
|
|
|
|
|
|
|
miAdd' :: (Text -> Text)
|
|
|
|
|
-> FieldView UniWorX
|
|
|
|
|
-> Form ([(UserId, _)] -> FormResult [(UserId, _)])
|
|
|
|
|
miAdd' nudge submitView csrf = do
|
|
|
|
|
-> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
|
|
|
|
|
miAdd' nudge btn csrf = do
|
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
|
(addRes, addView) <- mpreq userMatriculationField ("" & addName (nudge "matr") & addPlaceholder (mr MsgUserMatriculation)) Nothing
|
|
|
|
|
(addRes, addView) <- mpreq (multiUserField False Nothing) ("" & addName (nudge "users") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
|
|
|
|
let
|
|
|
|
|
res' :: FormResult ([(UserId, _)] -> FormResult [(UserId, _)])
|
|
|
|
|
res' :: FormResult ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
|
|
|
|
|
res' = addRes <&> \newUsers oldUsers -> if
|
|
|
|
|
| null newUsers
|
|
|
|
|
-> pure oldUsers
|
|
|
|
|
| otherwise
|
|
|
|
|
-> pure . nubOn (view _1) . sortOn sortProj
|
|
|
|
|
$ oldUsers ++ [ (uid, (userMatrikelnummer, userSurname, userDisplayName)) | Entity uid User{..} <- newUsers ]
|
|
|
|
|
-> pure . nub $ oldUsers ++ Set.toList newUsers
|
|
|
|
|
return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add"))
|
|
|
|
|
miCell' :: (UserId, (Maybe UserMatriculation, UserSurname, UserDisplayName)) -> Widget
|
|
|
|
|
miCell' (_, (userMatr, userSName, userDName)) = $(widgetFile "widgets/massinput/examOfficeUsers/cell")
|
|
|
|
|
miCell' :: Either UserEmail UserId -> Widget
|
|
|
|
|
miCell' (Left email) = $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation")
|
|
|
|
|
miCell' (Right uid) = do
|
|
|
|
|
User{..} <- liftHandlerT . runDB $ getJust uid
|
|
|
|
|
$(widgetFile "widgets/massinput/examOfficeUsers/cellKnown")
|
|
|
|
|
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
|
|
|
miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag
|
|
|
|
|
miLayout' :: MassInputLayout ListLength _ ()
|
|
|
|
|
@ -49,13 +119,15 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
|
|
|
|
|
fRequired :: Bool
|
|
|
|
|
fRequired = False
|
|
|
|
|
|
|
|
|
|
template' <- for template $ \uids -> fmap (sortOn sortProj) . liftHandlerT . runDB $ do
|
|
|
|
|
users <- E.select . E.from $ \user -> do
|
|
|
|
|
E.where_ $ user E.^. UserId `E.in_` E.valList (Set.toList uids)
|
|
|
|
|
return (user E.^. UserId, user E.^. UserMatrikelnummer, user E.^. UserSurname, user E.^. UserDisplayName)
|
|
|
|
|
return $ users <&> \(E.Value uid, E.Value matr, E.Value sName, E.Value dName) -> (uid, (matr, sName, dName))
|
|
|
|
|
template' <- for template $ \uids -> liftHandlerT . runDB $ do
|
|
|
|
|
let (invitations, knownUsers) = partitionEithers $ Set.toList uids
|
|
|
|
|
knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do
|
|
|
|
|
E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers
|
|
|
|
|
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
|
|
|
|
return $ user E.^. UserId
|
|
|
|
|
return $ map Left invitations ++ map Right knownUsers'
|
|
|
|
|
|
|
|
|
|
fmap (Set.fromList . keys) <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
|
|
|
|
|
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | Manage the list of users this user (in her function as exam-office)
|
|
|
|
|
@ -70,18 +142,26 @@ postEOUsersR = do
|
|
|
|
|
E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser
|
|
|
|
|
E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid
|
|
|
|
|
return $ user E.^. UserId
|
|
|
|
|
return $ setOf (folded . _Value) users
|
|
|
|
|
invites <- Map.keysSet <$> sourceInvitationsF @ExamOfficeUser uid
|
|
|
|
|
return $ setOf (folded . _Value . re _Right) users <> Set.mapMonotonic Left invites
|
|
|
|
|
|
|
|
|
|
((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers
|
|
|
|
|
|
|
|
|
|
formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do
|
|
|
|
|
liftHandlerT . runDB . forM_ changes $ \change -> if
|
|
|
|
|
| change `Set.member` oldUsers -> do
|
|
|
|
|
deleteBy $ UniqueExamOfficeUser uid change
|
|
|
|
|
audit $ TransactionExamOfficeUserDelete uid change
|
|
|
|
|
| otherwise -> do
|
|
|
|
|
insert_ $ ExamOfficeUser uid change
|
|
|
|
|
audit $ TransactionExamOfficeUserAdd uid change
|
|
|
|
|
liftHandlerT . runDBJobs . forM_ changes $ \change -> if
|
|
|
|
|
| change `Set.member` oldUsers -> case change of
|
|
|
|
|
Right change' -> do
|
|
|
|
|
deleteBy $ UniqueExamOfficeUser uid change'
|
|
|
|
|
audit $ TransactionExamOfficeUserDelete uid change'
|
|
|
|
|
Left change' ->
|
|
|
|
|
deleteInvitation @ExamOfficeUser uid change'
|
|
|
|
|
| otherwise -> case change of
|
|
|
|
|
Right change' -> do
|
|
|
|
|
insert_ $ ExamOfficeUser uid change'
|
|
|
|
|
audit $ TransactionExamOfficeUserAdd uid change'
|
|
|
|
|
Left change' -> do
|
|
|
|
|
cID <- encrypt uid
|
|
|
|
|
sinkInvitation examOfficeUserInvitationConfig (change', uid, (InvDBDataExamOfficeUser, InvTokenDataExamOfficeUser cID))
|
|
|
|
|
addMessageI Success $ MsgTransactionExamOfficeUsersUpdated (Set.size $ changes `Set.intersection` oldUsers) (Set.size $ changes `Set.difference` oldUsers)
|
|
|
|
|
redirect $ ExamOfficeR EOExamsR
|
|
|
|
|
|
|
|
|
|
@ -100,3 +180,7 @@ postEOUsersR = do
|
|
|
|
|
_{MsgExamOfficeSubscribedUsersExplanation}
|
|
|
|
|
^{usersView'}
|
|
|
|
|
|]
|
|
|
|
|
|
|
|
|
|
getEOUsersInviteR, postEOUsersInviteR :: Handler Html
|
|
|
|
|
getEOUsersInviteR = postEOUsersInviteR
|
|
|
|
|
postEOUsersInviteR = invitationR examOfficeUserInvitationConfig
|
|
|
|
|
|
Gregor Kleen