258 lines
11 KiB
Haskell
258 lines
11 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Course.ParticipantInvite
|
|
( getCAddUserR, postCAddUserR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Avs
|
|
|
|
import Jobs.Queue
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Data.List (genericLength)
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Time.Zones as TZ
|
|
import qualified Data.Set as Set
|
|
|
|
import Control.Monad.Except (MonadError(..))
|
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
|
|
|
|
|
type TutorialIdent = CI Text
|
|
|
|
|
|
data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonCourseRegisterMode
|
|
instance Finite ButtonCourseRegisterMode
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id
|
|
|
|
nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1
|
|
|
|
instance Button UniWorX ButtonCourseRegisterMode where
|
|
btnLabel x = [whamlet|_{x}|]
|
|
|
|
btnClasses BtnCourseRegisterAdd = [BCIsButton, BCPrimary]
|
|
btnClasses BtnCourseRegisterConfirm = [BCIsButton, BCPrimary]
|
|
btnClasses BtnCourseRegisterAbort = [BCIsButton, BCDanger]
|
|
|
|
btnValidate _ BtnCourseRegisterAbort = False
|
|
btnValidate _ _ = True
|
|
|
|
|
|
data CourseRegisterAction
|
|
= CourseRegisterActionAddParticipant
|
|
| CourseRegisterActionAddTutorialMember
|
|
| CourseRegisterActionUnknownPerson
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe CourseRegisterAction
|
|
instance Finite CourseRegisterAction
|
|
|
|
data CourseRegisterActionData
|
|
= CourseRegisterActionAddParticipantData
|
|
{ crActParticipantUser :: UserId
|
|
, crActParticipantTutorial :: Maybe TutorialIdent
|
|
}
|
|
| CourseRegisterActionAddTutorialMemberData
|
|
{ crActTutorialMemberParticipant :: CourseParticipantId
|
|
, crActTutorialMemberTutorial :: TutorialIdent
|
|
}
|
|
| CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
|
|
{ crActUnknownPersonIdent :: Text
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
makeLenses_ ''CourseRegisterActionData
|
|
|
|
classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction
|
|
classifyRegisterAction = \case
|
|
CourseRegisterActionAddParticipantData{} -> CourseRegisterActionAddParticipant
|
|
CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember
|
|
CourseRegisterActionUnknownPersonData{} -> CourseRegisterActionUnknownPerson
|
|
|
|
|
|
data AddUsers = AddUsers
|
|
{ auUsers :: Set Text
|
|
, auTutorial :: Maybe TutorialIdent
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
|
data AddParticipantsResult = AddParticipantsResult
|
|
{ aurNotFound :: Set Text
|
|
, aurAlreadyRegistered
|
|
, aurAlreadyTutorialMember
|
|
, aurRegisterSuccess
|
|
, aurTutorialSuccess :: Set UserId
|
|
} deriving (Read, Show, Generic, Typeable)
|
|
|
|
instance Semigroup AddParticipantsResult where
|
|
(<>) = mappenddefault
|
|
|
|
instance Monoid AddParticipantsResult where
|
|
mempty = memptydefault
|
|
mappend = (<>)
|
|
|
|
|
|
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCAddUserR = postCAddUserR
|
|
postCAddUserR tid ssh csh = do
|
|
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
-- mr <- getMessageRender
|
|
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
|
|
|
((usersToRegister :: FormResult AddUsers, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
|
let
|
|
cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
|
|
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)
|
|
auUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
|
|
auTutorial <- optionalActionW
|
|
( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting
|
|
( fslI MsgCourseParticipantsRegisterTutorialOption )
|
|
( Just True )
|
|
return $ AddUsers <$> auUsers <*> auTutorial
|
|
|
|
-- let dest = CourseR tid ssh csh . maybe CUsersR (flip TutorialR TUsersR . CI.mk) . join . fmap auTutorial $ formResult' usersToRegister
|
|
let dest | Just AddUsers{auTutorial=Just tutn} <- formResult' usersToRegister
|
|
= CTutorialR tid ssh csh tutn TUsersR
|
|
| otherwise
|
|
= CourseR tid ssh csh CUsersR
|
|
formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do
|
|
avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $ liftHandler . upsertAvsUser
|
|
case catMaybes $ Map.elems avsUsers of
|
|
[] -> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
|
|
uids -> do
|
|
registerUsers cid avsUsers
|
|
for_ auTutorial $ \tutorialName -> lift $ do
|
|
-- TODO: move somewhere else
|
|
now <- liftIO getCurrentTime
|
|
Entity tutId _ <- upsert
|
|
Tutorial
|
|
{ tutorialCourse = cid
|
|
, tutorialType = CI.mk mempty -- TODO: remove type? unneeded?
|
|
, tutorialCapacity = Nothing
|
|
, tutorialRoom = Nothing
|
|
, tutorialRoomHidden = False
|
|
, tutorialTime = Occurrences mempty mempty
|
|
, tutorialRegGroup = Nothing -- TODO: remove
|
|
, tutorialRegisterFrom = Nothing
|
|
, tutorialRegisterTo = Nothing
|
|
, tutorialDeregisterUntil = Nothing
|
|
, tutorialLastChanged = now
|
|
, tutorialTutorControlled = False
|
|
, ..
|
|
}
|
|
[ TutorialName =. tutorialName
|
|
, TutorialLastChanged =. now
|
|
]
|
|
for_ uids $ \tutorialParticipantUser -> upsert
|
|
TutorialParticipant
|
|
{ tutorialParticipantTutorial = tutId
|
|
, ..
|
|
}
|
|
[]
|
|
-- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids
|
|
|
|
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
wrapForm formWgt def
|
|
{ formEncoding
|
|
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
|
|
}
|
|
|
|
|
|
confirmAddUser :: Handler Html
|
|
confirmAddUser = do
|
|
siteLayoutMsg MsgCourseParticipantsRegisterConfirmationHeading $ do
|
|
setTitleI MsgCourseParticipantsRegisterConfirmationHeading
|
|
let
|
|
confirmCheckBox :: Widget
|
|
confirmCheckBox = do
|
|
let sJsonField :: Field (HandlerFor UniWorX) a
|
|
sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
|
|
[whamlet|
|
|
$newline never
|
|
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} checked>
|
|
|]
|
|
fieldView sJsonField act mempty vAttrs (Right act) False
|
|
availableActs :: Widget
|
|
availableActs = fieldView (secretJsonField :: Field Handler (Set csvAction)) "" mempty [] (Right . Set.empty) False
|
|
(confirmForm', confirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCourseRegisterConfirm, BtnCourseRegisterAbort] . identifyForm FIDCourseRegisterConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "course/add-user/confirmation"))
|
|
let confirmForm = wrapForm confirmForm' FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just $ tblLink id
|
|
, formEncoding = confirmEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
$(widgetFile "course/add-user/confirmation-wrapper")
|
|
|
|
|
|
registerUsers :: CourseId -> Map Text (Maybe UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
|
|
registerUsers cid users
|
|
| null users = tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
|
|
| otherwise = tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT . mapM_ (registerUser cid) $ Map.toList users
|
|
|
|
|
|
addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
|
=> AddParticipantsResult
|
|
-> ReaderT (YesodPersistBackend UniWorX) m [Message]
|
|
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
|
|
unless (null aurNotFound) $ do
|
|
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisterNotFoundInAvs (length aurNotFound)}|]
|
|
modalContent = $(widgetFile "messages/courseInvitationNotFoundInAvs")
|
|
tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
|
|
|
|
aurAlreadyRegistered' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered)
|
|
aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember)
|
|
|
|
unless (null aurAlreadyRegistered) $ do
|
|
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
|
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
|
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
|
unless (null aurAlreadyTutorialMember) $ do
|
|
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyTutorialMember (length aurAlreadyTutorialMember)}|]
|
|
modalContent = $(widgetFile "messages/courseInvitationAlreadyTutorialMember")
|
|
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
|
|
|
unless (null aurRegisterSuccess) $
|
|
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess
|
|
unless (null aurTutorialSuccess) $
|
|
tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess
|
|
|
|
|
|
registerUser :: CourseId
|
|
-> (Text, Maybe UserId)
|
|
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
|
|
registerUser _cid ( avsIdent, Nothing ) = tell $ mempty { aurNotFound = Set.singleton avsIdent }
|
|
registerUser cid (_avsIdent, Just uid) = exceptT tell tell $ do
|
|
whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
|
|
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
|
|
|
|
courseParticipantRegistration <- liftIO getCurrentTime
|
|
void . lift . lift $ upsert
|
|
CourseParticipant
|
|
{ courseParticipantCourse = cid
|
|
, courseParticipantUser = uid
|
|
, courseParticipantAllocated = Nothing
|
|
, courseParticipantState = CourseParticipantActive
|
|
, ..
|
|
}
|
|
[ CourseParticipantRegistration =. courseParticipantRegistration
|
|
, CourseParticipantAllocated =. Nothing
|
|
, CourseParticipantState =. CourseParticipantActive
|
|
]
|
|
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
|
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all?
|
|
|
|
return $ mempty { aurRegisterSuccess = Set.singleton uid }
|