82 lines
4.5 KiB
Haskell
82 lines
4.5 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.ExternalExam.StaffInvite
|
|
( externalExamStaffInvitationConfig
|
|
, getEEStaffInviteR, postEEStaffInviteR
|
|
, InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils.Invitations
|
|
|
|
import Text.Hamlet (ihamlet)
|
|
import Data.Aeson hiding (Result(..))
|
|
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
|
|
instance IsInvitableJunction ExternalExamStaff where
|
|
type InvitationFor ExternalExamStaff = ExternalExam
|
|
data InvitableJunction ExternalExamStaff = JunctionExternalExamStaff
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationDBData ExternalExamStaff = InvDBDataExternalExamStaff
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationTokenData ExternalExamStaff = InvTokenDataExternalExamStaff
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\ExternalExamStaff{..} -> (externalExamStaffUser, externalExamStaffExam, JunctionExternalExamStaff))
|
|
(\(externalExamStaffUser, externalExamStaffExam, JunctionExternalExamStaff{}) -> ExternalExamStaff{..})
|
|
|
|
instance ToJSON (InvitableJunction ExternalExamStaff) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction ExternalExamStaff) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData ExternalExamStaff) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationDBData ExternalExamStaff) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
instance ToJSON (InvitationTokenData ExternalExamStaff) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationTokenData ExternalExamStaff) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
externalExamStaffInvitationConfig :: InvitationConfig ExternalExamStaff
|
|
externalExamStaffInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity _ ExternalExam{..}) _ = return $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEStaffInviteR
|
|
invitationResolveFor _ = do
|
|
cRoute <- getCurrentRoute
|
|
case cRoute of
|
|
Just (EExamR tid ssh coursen examn EEStaffInviteR) ->
|
|
getKeyBy404 $ UniqueExternalExam tid ssh coursen examn
|
|
_other -> error "externalExamStaffInvitationConfig called from unsupported route"
|
|
invitationSubject (Entity _ ExternalExam{..}) _ = return . SomeMessage $ MsgMailSubjectExternalExamStaffInvitation externalExamCourseName externalExamExamName
|
|
invitationHeading (Entity _ ExternalExam{..}) _ = return . SomeMessage $ MsgExternalExamStaffInviteHeading externalExamCourseName externalExamExamName
|
|
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExternalExamStaffInviteExplanation}|]
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing (Just Nothing) Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm _ (InvDBDataExternalExamStaff, _) _ = pure (JunctionExternalExamStaff, ())
|
|
invitationInsertHook invEmail _ _ ExternalExamStaff{..} _ act = do
|
|
res <- act
|
|
|
|
audit $ TransactionExternalExamStaffInviteDelete externalExamStaffExam invEmail
|
|
audit $ TransactionExternalExamStaffEdit externalExamStaffExam externalExamStaffUser
|
|
return res
|
|
invitationSuccessMsg (Entity _ ExternalExam{..}) (Entity _ ExternalExamStaff{})
|
|
= return . SomeMessage $ MsgExternalExamStaffInvitationAccepted externalExamCourseName externalExamExamName
|
|
invitationUltDest (Entity _ ExternalExam{..}) _ = return . SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR
|
|
|
|
|
|
getEEStaffInviteR, postEEStaffInviteR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html
|
|
getEEStaffInviteR = postEEStaffInviteR
|
|
postEEStaffInviteR = invitationR externalExamStaffInvitationConfig
|