91 lines
4.3 KiB
Haskell
91 lines
4.3 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Course.LecturerInvite
|
|
( lecturerInvitationConfig
|
|
, getCLecInviteR, postCLecInviteR
|
|
, InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils.Invitations
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
|
|
import Text.Hamlet (ihamlet)
|
|
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
|
|
instance IsInvitableJunction Lecturer where
|
|
type InvitationFor Lecturer = Course
|
|
data InvitableJunction Lecturer = JunctionLecturer
|
|
{ jLecturerType :: LecturerType
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationDBData Lecturer = InvDBDataLecturer
|
|
{ invDBLecturerType :: Maybe LecturerType
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationTokenData Lecturer = InvTokenDataLecturer
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType))
|
|
(\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..})
|
|
|
|
instance ToJSON (InvitableJunction Lecturer) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction Lecturer) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData Lecturer) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationDBData Lecturer) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
|
|
instance ToJSON (InvitationTokenData Lecturer) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationTokenData Lecturer) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
lecturerInvitationConfig :: InvitationConfig Lecturer
|
|
lecturerInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
|
invitationResolveFor _ = do
|
|
cRoute <- getCurrentRoute
|
|
case cRoute of
|
|
Just (CourseR tid csh ssh CLecInviteR) ->
|
|
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
|
_other -> error "lecturerInvitationConfig called from unsupported route"
|
|
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
|
|
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
|
|
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of
|
|
Nothing -> areq (selectField optionsFinite) lFs Nothing
|
|
Just lType -> aforced (selectField optionsFinite) lFs lType
|
|
where
|
|
toJunction jLecturerType = (JunctionLecturer{..}, ())
|
|
lFs :: FieldSettings UniWorX
|
|
lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
|
|
invitationInsertHook _ _ _ _ _ = id
|
|
invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
|
|
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
|
|
|
|
|
getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCLecInviteR = postCLecInviteR
|
|
postCLecInviteR = invitationR lecturerInvitationConfig
|
|
|