88 lines
4.1 KiB
Haskell
88 lines
4.1 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Exam.CorrectorInvite
|
|
( InvitableJunction(..)
|
|
, InvitationDBData(..)
|
|
, InvitationTokenData(..)
|
|
, examCorrectorInvitationConfig
|
|
, getECInviteR, postECInviteR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils.Invitations
|
|
import Handler.Utils.Exam
|
|
import Handler.Utils.Memcached
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
|
|
instance IsInvitableJunction ExamCorrector where
|
|
type InvitationFor ExamCorrector = Exam
|
|
data InvitableJunction ExamCorrector = JunctionExamCorrector
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
data InvitationDBData ExamCorrector = InvDBDataExamCorrector
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
_InvitableJunction = iso
|
|
(\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector))
|
|
(\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..})
|
|
|
|
instance ToJSON (InvitableJunction ExamCorrector) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction ExamCorrector) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData ExamCorrector) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
instance FromJSON (InvitationDBData ExamCorrector) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
|
|
instance ToJSON (InvitationTokenData ExamCorrector) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
instance FromJSON (InvitationTokenData ExamCorrector) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
|
|
examCorrectorInvitationConfig :: InvitationConfig ExamCorrector
|
|
examCorrectorInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity _ Exam{..}) _ = do
|
|
Course{..} <- get404 examCourse
|
|
return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
|
|
invitationResolveFor _ = do
|
|
cRoute <- getCurrentRoute
|
|
case cRoute of
|
|
Just (CExamR tid csh ssh examn ECInviteR) ->
|
|
fetchExamId tid csh ssh examn
|
|
_other ->
|
|
error "examCorrectorInvitationConfig called from unsupported route"
|
|
invitationSubject (Entity _ Exam{..}) _ = do
|
|
Course{..} <- get404 examCourse
|
|
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
|
|
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
|
|
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm _ _ _ = pure (JunctionExamCorrector, ())
|
|
invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId))
|
|
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
|
|
invitationUltDest (Entity _ Exam{..}) _ = do
|
|
Course{..} <- get404 examCourse
|
|
return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
|
|
|
|
getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
|
getECInviteR = postECInviteR
|
|
postECInviteR = invitationR examCorrectorInvitationConfig
|