209 lines
9.6 KiB
Haskell
209 lines
9.6 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Course.ParticipantInvite
|
|
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
|
, getCInviteR, postCInviteR
|
|
, getCAddUserR, postCAddUserR
|
|
, AddParticipantsResult(..)
|
|
, addParticipantsResultMessages
|
|
, registerUsers, registerUser
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Data.Function ((&))
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Jobs.Queue
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
|
|
import Text.Hamlet (ihamlet)
|
|
|
|
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
|
import Control.Monad.Except (MonadError(..))
|
|
|
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
|
|
|
|
|
-- Invitations for ordinary participants of this course
|
|
instance IsInvitableJunction CourseParticipant where
|
|
type InvitationFor CourseParticipant = Course
|
|
data InvitableJunction CourseParticipant = JunctionParticipant
|
|
{ jParticipantRegistration :: UTCTime
|
|
, jParticipantField :: Maybe StudyFeaturesId
|
|
, jParticipantAllocated :: Maybe AllocationId
|
|
} 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
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated))
|
|
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated) -> 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 { constructorTagModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationTokenData CourseParticipant) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
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 <- liftHandler requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
|
|
now <- liftIO getCurrentTime
|
|
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
|
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
|
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing
|
|
invitationInsertHook _ _ CourseParticipant{..} _ act = do
|
|
res <- act
|
|
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
|
|
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
|
|
, aurNoUniquePrimaryField
|
|
, 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)
|
|
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
|
|
(fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
|
|
|
|
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 users = do
|
|
let (emails,uids) = partitionEithers $ Set.toList users
|
|
|
|
-- send Invitation eMails to unkown users
|
|
lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
|
|
-- register known users
|
|
tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (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', aurNoUniquePrimaryField') <-
|
|
(,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
|
|
<*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)
|
|
|
|
unless (null aurAlreadyRegistered) $ do
|
|
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
|
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
|
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
|
|
|
unless (null aurNoUniquePrimaryField) $ do
|
|
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
|
|
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
|
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
|
|
|
unless (null aurSuccess) $
|
|
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
|
|
|
|
|
registerUser :: CourseId
|
|
-> UserId
|
|
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
|
|
registerUser cid uid = exceptT tell tell $ do
|
|
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
|
|
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
|
|
|
|
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
|
applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
|
|
|
let courseParticipantField
|
|
| [f] <- features
|
|
= Just f
|
|
| [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications
|
|
, f' `elem` features
|
|
= Just f'
|
|
| otherwise
|
|
= Nothing
|
|
|
|
courseParticipantRegistration <- liftIO getCurrentTime
|
|
void . lift . lift . insert $ CourseParticipant
|
|
{ courseParticipantCourse = cid
|
|
, courseParticipantUser = uid
|
|
, courseParticipantAllocated = Nothing
|
|
, ..
|
|
}
|
|
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
|
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
|
|
|
|
return $ case courseParticipantField of
|
|
Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid }
|
|
Just _ -> mempty { aurSuccess = Set.singleton uid }
|
|
|
|
|
|
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCInviteR = postCInviteR
|
|
postCInviteR = invitationR participantInvitationConfig
|