fradrive/src/Handler/Course/ParticipantInvite.hs

401 lines
20 KiB
Haskell

-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-}
module Handler.Course.ParticipantInvite
( getCAddUserR, postCAddUserR
, getTAddUserR, postTAddUserR
) where
import Import
import Handler.Utils
import Handler.Utils.Avs
import Jobs.Queue
import qualified Data.Aeson as Aeson
import qualified Data.CaseInsensitive as CI
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Time.Zones as TZ
import qualified Data.Set as Set
import qualified Data.Text as Text
import Control.Monad.Except (MonadError(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
import Utils.Occurrences
type UserSearchKey = Text
type TutorialType = CI Text
defaultTutorialType :: TutorialType
defaultTutorialType = "Schulung"
tutorialTypeSeparator :: TutorialType
tutorialTypeSeparator = "_"
tutorialTemplateNames :: Maybe TutorialType -> [TutorialType]
tutorialTemplateNames Nothing = ["Vorlage", "Template"]
tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]
tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
tutorialDefaultName Nothing = formatDayForTutName
tutorialDefaultName (Just ttyp) =
let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing
formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user
-- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this
formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow
where
d2u '-' = '_'
d2u c = c
data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe ButtonCourseRegisterMode
instance Finite ButtonCourseRegisterMode
embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id
nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1
instance Button UniWorX ButtonCourseRegisterMode where
btnLabel x = [whamlet|_{x}|]
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)
instance Universe CourseRegisterAction
instance Finite CourseRegisterAction
data CourseRegisterActionData
= CourseRegisterActionAddParticipantData
{ crActIdent :: UserSearchKey
, crActUser :: (UserId, User)
}
| CourseRegisterActionAddTutorialMemberData
{ crActIdent :: UserSearchKey
, crActUser :: (UserId, User)
, crActTutorial :: (Maybe TutorialName, Maybe TutorialType, Maybe Day)
}
-- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
-- { crActUnknownPersonIdent :: Text
-- }
deriving (Eq, Ord, Show, Generic)
makeLenses_ ''CourseRegisterActionData
makePrisms ''CourseRegisterActionData
instance Aeson.FromJSON CourseRegisterActionData where
parseJSON = Aeson.genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }
instance Aeson.ToJSON CourseRegisterActionData where
toJSON = Aeson.genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }
toEncoding = Aeson.genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }
_classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction
_classifyRegisterAction = \case
CourseRegisterActionAddParticipantData{} -> CourseRegisterActionAddParticipant
CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember
--CourseRegisterActionUnknownPersonData{} -> CourseRegisterActionUnknownPerson
courseRegisterRenderActionClass :: CourseRegisterAction -> Widget
courseRegisterRenderActionClass = \case
CourseRegisterActionAddParticipant -> [whamlet|_{MsgCourseParticipantsRegisterActionAddParticipants}|]
CourseRegisterActionAddTutorialMember -> [whamlet|_{MsgCourseParticipantsRegisterActionAddTutorialMembers}|]
courseRegisterRenderAction :: CourseRegisterActionData -> Widget
courseRegisterRenderAction act = [whamlet|^{userWidget (view _2 (crActUser act))} (#{crActIdent act})|]
data AddUserRequest = AddUserRequest
{ auReqUsers :: Set UserSearchKey
, auReqTutorial :: Maybe (Maybe TutorialName, Maybe TutorialType, Maybe Day)
} deriving (Eq, Ord, Read, Show, Generic)
data AddParticipantsResult = AddParticipantsResult
{ aurNotFound :: Set UserSearchKey
, aurAlreadyRegistered
, aurAlreadyTutorialMember
, aurRegisterSuccess
, aurTutorialSuccess :: Set UserId
} deriving (Read, Show, Generic)
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
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
handleAddUserR tid ssh csh (Right today) Nothing
-- postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users
getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTAddUserR = postTAddUserR
postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing
handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html
handleAddUserR tid ssh csh tdesc ttyp = do
(cid, tutTypes, tutNameSuggestions) <- runDB $ do
let plainTemplates = tutorialTemplateNames Nothing
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
tutTypes <- E.select $ E.distinct $ do
tutorial <- E.from $ E.table @Tutorial
let tuTyp = tutorial E.^. TutorialType
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.orderBy [E.asc tuTyp]
return tuTyp
let typeSet = Set.fromList [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t
| temp <- plainTemplates
, let temp_sep = CI.original (temp <> tutorialTypeSeparator)
, E.Value t <- tutTypes
]
tutNames <- E.select $ do
tutorial <- E.from $ E.table @Tutorial
let tuName = tutorial E.^. TutorialName
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. E.isJust (tutorial E.^. TutorialFirstDay)
E.&&. E.not_ (E.any (E.hasPrefix_ (tutorial E.^. TutorialType) . E.val) plainTemplates)
E.orderBy [E.desc $ tutorial E.^. TutorialFirstDay, E.asc tuName]
E.limit 7
return tuName
let tutNameSuggestions = return $ mkOptionList [Option tno tn tno | etn <- tutNames, let tn = E.unValue etn, let tno = CI.original tn]
return (cid, Set.toAscList typeSet, tutNameSuggestions) -- Set in order to remove duplicates and sort ascending at once
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
-- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
let
users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!
registeredUsers <- registerUsers cid users
whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
tutId <- upsertNewTutorial cid tName tutType tutDay
registerTutorialMembers tutId registeredUsers
-- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point
redirect $ CTutorialR tid ssh csh tName TUsersR
redirect $ CourseR tid ssh csh CUsersR
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes]
tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)
auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
auReqTutorial <- optionalActionW
( (,,)
<$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
(fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
(Just $ maybeLeft tdesc)
<*> aopt (selectFieldList tutTypesMsg)
(fslI MsgTableTutorialType)
(Just tutDefType)
<*> aopt dayField
(fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip)
(Just $ maybeRight tdesc)
)
( fslI MsgCourseParticipantsRegisterTutorialOption )
( Just True )
return $ AddUserRequest <$> auReqUsers <*> auReqTutorial
formResult usersToAdd $ \AddUserRequest{..} -> do
avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser auReqUsers
let (usersFound, usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
unless (null usersNotFound) $
let msgContent = [whamlet|
$newline never
<ul>
$forall (usr,_) <- usersNotFound
<li>#{usr}
|]
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
when (null usersFound) $
redirect currentRoute
liftHandler . (>>= sendResponse) $
siteLayoutMsg MsgCourseParticipantsRegisterHeading $ do
setTitleI MsgCourseParticipantsRegisterHeading
actionMap :: Map CourseRegisterAction (Set CourseRegisterActionData) <- fmap (Map.unionsWith Set.union) . forM usersFound $ \case
(_, Nothing) -> error "Found user in AVS, but response is Nothing!" -- this should not be possible
(ukey, Just uid) -> do
-- isParticipant <- exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]
user <- liftHandler . runDBRead $ get404 uid
case auReqTutorial of
Nothing -> return . Map.singleton CourseRegisterActionAddParticipant . Set.singleton $ CourseRegisterActionAddParticipantData ukey (uid,user)
Just crActAddTutorialMemberTutorial -> return . Map.singleton CourseRegisterActionAddTutorialMember . Set.singleton $ CourseRegisterActionAddTutorialMemberData ukey (uid,user) crActAddTutorialMemberTutorial
let
precomputeIdents :: forall f m. (Eq (Element f), MonoFoldable f, MonadHandler m) => f -> m (Element f -> Text)
precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed")
actionClassIdent <- precomputeIdents $ Map.keys actionMap
actionIdent <- precomputeIdents . Set.unions $ Map.elems actionMap
let
confirmCheckBox :: [(Text,Text)] -> CourseRegisterActionData -> Widget
confirmCheckBox vAttrs act = do
let
sJsonField :: Field (HandlerFor UniWorX) CourseRegisterActionData
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 (actionIdent act) (toPathPiece PostCourseUserAddConfirmAction) vAttrs (Right act) False
availableActs :: Widget
availableActs = fieldView (secretJsonField :: Field Handler (Set CourseRegisterActionData)) "" (toPathPiece PostCourseUserAddConfirmAvailableActions) [] (Right . Set.unions $ Map.elems actionMap) False
(confirmForm', confirmEnctype) <- 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 . SomeRoute $ CourseR tid ssh csh CAddUserR
, formEncoding = confirmEnctype
, formAttrs = []
, formSubmit = FormNoSubmit
, formAnchor = Nothing :: Maybe Text
}
$(widgetFile "course/add-user/confirmation-wrapper")
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
siteLayoutMsg heading $ do
setTitleI heading
wrapForm formWgt def
{ formEncoding
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
}
registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId)
registerUsers cid users
| Map.null users = do
addMessageI Error MsgCourseParticipantsRegisterNoneGiven
return Set.empty
| otherwise = do
(mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (registerUser cid) $ Map.toList users
unless (Set.null aurRegisterSuccess) $
addMessageI Success . MsgCourseParticipantsRegistered $ Set.size aurRegisterSuccess
unless (Set.null aurAlreadyRegistered) $
addMessageI Info . MsgCourseParticipantsAlreadyRegistered $ Set.size aurAlreadyRegistered
return $ aurRegisterSuccess `Set.union` aurAlreadyRegistered
registerUser :: CourseId
-> (UserSearchKey, Maybe UserId)
-> YesodJobDB UniWorX AddParticipantsResult
registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent }
registerUser cid (_avsIdent, Just uid) = exceptT return return $ do
whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
courseParticipantRegistration <- liftIO getCurrentTime
void . lift $ upsert
CourseParticipant -- TODO: use participantId instead of userId for aurRegisterSuccess
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, courseParticipantState = CourseParticipantActive
, ..
}
[ CourseParticipantRegistration =. courseParticipantRegistration
, CourseParticipantState =. CourseParticipantActive
]
lift . audit $ TransactionCourseParticipantEdit cid uid
lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
return $ mempty { aurRegisterSuccess = Set.singleton uid }
upsertNewTutorial :: CourseId -> TutorialName -> Maybe TutorialType -> Maybe Day -> Handler TutorialId
upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
now <- liftIO getCurrentTime
existingTut <- getBy $ UniqueTutorial cid newTutorialName
templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName]
case (existingTut, newFirstDay, templateEnt) of
(Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day
(Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do
Course{..} <- get404 cid
term <- get404 courseTerm
let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime)
newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime
dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay
mvTime = fmap $ addLocalDays dayDiff
newType0 = CI.map (snd . Text.breakOnEnd (CI.original tutorialTypeSeparator)) tutorialType
newType = if newType0 `elem` tutorialTemplateNames Nothing
then fromMaybe defaultTutorialType newTutorialType
else newType0
Entity tutId _ <- upsert
Tutorial
{ tutorialName = newTutorialName
, tutorialCourse = cid
, tutorialType = newType
, tutorialFirstDay = newFirstDay
, tutorialTime = newTime
, tutorialRegisterFrom = mvTime tutorialRegisterFrom
, tutorialRegisterTo = mvTime tutorialRegisterTo
, tutorialDeregisterUntil = mvTime tutorialDeregisterUntil
, tutorialLastChanged = now
, ..
} [] -- update cannot happen due to previous case
audit $ TransactionTutorialEdit tutId
return tutId
_ -> do
Entity tutId _ <- upsert
Tutorial
{ tutorialName = newTutorialName
, tutorialCourse = cid
, tutorialType = fromMaybe defaultTutorialType newTutorialType
, tutorialCapacity = Nothing
, tutorialRoom = Nothing
, tutorialRoomHidden = False
, tutorialTime = Occurrences mempty mempty
, tutorialRegGroup = Nothing
, tutorialRegisterFrom = Nothing
, tutorialRegisterTo = Nothing
, tutorialDeregisterUntil = Nothing
, tutorialLastChanged = now
, tutorialTutorControlled = False
, tutorialFirstDay = Nothing
} [] -- update cannot happen due to previous cases
audit $ TransactionTutorialEdit tutId
return tutId
registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] []
participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> do
Entity tutPartId _ <- upsert TutorialParticipant { tutorialParticipantTutorial = tutId, .. } []
audit $ TransactionTutorialParticipantEdit tutId tutPartId tutorialParticipantUser
return tutPartId
let newParticipants = participants Set.\\ prevParticipants
unless (Set.null newParticipants) $
addMessageI Success . MsgCourseParticipantsRegisteredTutorial $ Set.size newParticipants
unless (Set.null prevParticipants) $
addMessageI Info . MsgCourseParticipantsAlreadyTutorialMember $ length prevParticipants