80 lines
3.7 KiB
Haskell
80 lines
3.7 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Tutorial.TutorInvite
|
|
( getTInviteR, postTInviteR
|
|
, tutorInvitationConfig
|
|
, InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils.Tutorial
|
|
import Handler.Utils.Invitations
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
import Text.Hamlet (ihamlet)
|
|
|
|
|
|
instance IsInvitableJunction Tutor where
|
|
type InvitationFor Tutor = Tutorial
|
|
data InvitableJunction Tutor = JunctionTutor
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationDBData Tutor = InvDBDataTutor
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationTokenData Tutor = InvTokenDataTutor
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\Tutor{..} -> (tutorUser, tutorTutorial, JunctionTutor))
|
|
(\(tutorUser, tutorTutorial, JunctionTutor) -> Tutor{..})
|
|
|
|
instance ToJSON (InvitableJunction Tutor) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction Tutor) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData Tutor) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
instance FromJSON (InvitationDBData Tutor) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
|
|
instance ToJSON (InvitationTokenData Tutor) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
instance FromJSON (InvitationTokenData Tutor) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
|
|
tutorInvitationConfig :: InvitationConfig Tutor
|
|
tutorInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity _ Tutorial{..}) _ = do
|
|
Course{..} <- get404 tutorialCourse
|
|
return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
|
|
invitationResolveFor _ = do
|
|
cRoute <- getCurrentRoute
|
|
case cRoute of
|
|
Just (CTutorialR tid csh ssh tutn TInviteR) ->
|
|
fetchTutorialId tid csh ssh tutn
|
|
_other ->
|
|
error "tutorInvitationConfig called from unsupported route"
|
|
invitationSubject (Entity _ Tutorial{..}) _ = do
|
|
Course{..} <- get404 tutorialCourse
|
|
return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
|
|
invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
|
|
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- Right <$> liftHandler requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm _ _ _ = pure (JunctionTutor, ())
|
|
invitationInsertHook _ _ _ _ = id
|
|
invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
|
|
invitationUltDest (Entity _ Tutorial{..}) _ = do
|
|
Course{..} <- get404 tutorialCourse
|
|
return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR
|
|
|
|
getTInviteR, postTInviteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
|
getTInviteR = postTInviteR
|
|
postTInviteR = invitationR tutorInvitationConfig
|