217 lines
10 KiB
Haskell
217 lines
10 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Course.ParticipantInvite
|
|
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
|
, getCInviteR, postCInviteR
|
|
, getCAddUserR, postCAddUserR
|
|
, AddParticipantsResult(..)
|
|
, addParticipantsResultMessages
|
|
, registerUsers, registerUser
|
|
, registerUsers', registerUser'
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
import Handler.Utils.Course
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import Jobs.Queue
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
|
|
import Text.Hamlet (ihamlet)
|
|
|
|
import Control.Monad.Except (MonadError(..))
|
|
|
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
|
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
|
|
-- Invitations for ordinary participants of this course
|
|
instance IsInvitableJunction CourseParticipant where
|
|
type InvitationFor CourseParticipant = Course
|
|
data InvitableJunction CourseParticipant = JunctionParticipant
|
|
{ jParticipantRegistration :: UTCTime
|
|
, jParticipantAllocated :: Maybe AllocationId
|
|
, jParticipantState :: CourseParticipantState
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
|
-- no data needed in DB to manage participant invitation
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationTokenData CourseParticipant = InvTokenDataParticipant
|
|
{ invTokenParticipantSubmissionGroup :: Maybe SubmissionGroupName
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState))
|
|
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
|
|
|
|
instance ToJSON (InvitableJunction CourseParticipant) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction CourseParticipant) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData CourseParticipant) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationDBData CourseParticipant) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
|
|
instance ToJSON (InvitationTokenData CourseParticipant) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
|
|
instance FromJSON (InvitationTokenData CourseParticipant) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3, omitNothingFields = True }
|
|
|
|
participantInvitationConfig :: InvitationConfig CourseParticipant
|
|
participantInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
|
|
invitationResolveFor _ = do
|
|
cRoute <- getCurrentRoute
|
|
case cRoute of
|
|
Just (CourseR tid csh ssh CInviteR) ->
|
|
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
|
_other ->
|
|
error "participantInvitationConfig called from unsupported route"
|
|
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
|
|
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
|
|
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do
|
|
now <- liftIO getCurrentTime
|
|
return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive
|
|
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
|
|
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
|
|
res <- act -- insertUnique
|
|
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
|
|
void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup
|
|
return res
|
|
invitationSuccessMsg (Entity _ Course{..}) _ =
|
|
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
|
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
|
|
|
data AddParticipantsResult = AddParticipantsResult
|
|
{ aurAlreadyRegistered
|
|
, aurSuccess :: 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
|
|
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
|
enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
|
|
|
|
let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
|
|
mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
|
|
|
|
mr <- getMessageRender
|
|
users <- wreq (multiUserInvitationField . maybe MUIAlwaysInvite (const $ MUILookupAnyUser Nothing) $ formResultToMaybe enlist)
|
|
(fslpI MsgCourseParticipantInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing
|
|
|
|
return $ Map.fromSet . const <$> mbGrp <*> users
|
|
|
|
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
|
|
hoist runDBJobs . registerUsers' cid
|
|
|
|
|
|
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 -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
|
|
registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing)
|
|
|
|
registerUsers' :: CourseId -> Map (Either UserEmail UserId) (Maybe SubmissionGroupName) -> WriterT [Message] (YesodJobDB UniWorX) ()
|
|
registerUsers' cid users = do
|
|
let (emails,uids) = partitionKeysEither users
|
|
|
|
-- send Invitation eMails to unkown users
|
|
lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant{..})) | (mail, invTokenParticipantSubmissionGroup) <- Map.toList emails]
|
|
-- register known users
|
|
tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser' cid) uids
|
|
|
|
unless (null emails) $
|
|
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
|
|
|
|
|
addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
|
=> AddParticipantsResult
|
|
-> ReaderT (YesodPersistBackend UniWorX) m [Message]
|
|
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
|
|
aurAlreadyRegistered' <-
|
|
fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
|
|
|
|
unless (null aurAlreadyRegistered) $ do
|
|
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
|
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
|
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
|
|
|
unless (null aurSuccess) $
|
|
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
|
|
|
|
|
registerUser :: CourseId
|
|
-> UserId
|
|
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
|
|
registerUser cid uid = registerUser' cid uid Nothing
|
|
|
|
registerUser' :: CourseId
|
|
-> UserId
|
|
-> Maybe SubmissionGroupName
|
|
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
|
|
registerUser' cid uid mbGrp = 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
|
|
|
|
void . lift . lift $ setUserSubmissionGroup cid uid mbGrp
|
|
|
|
return $ mempty { aurSuccess = Set.singleton uid }
|
|
|
|
|
|
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCInviteR = postCInviteR
|
|
postCInviteR = invitationR participantInvitationConfig
|