87 lines
4.3 KiB
Haskell
87 lines
4.3 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Sheet.CorrectorInvite
|
|
( getSCorrInviteR, postSCorrInviteR
|
|
, InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
|
, correctorInvitationConfig
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
import Text.Hamlet (ihamlet)
|
|
|
|
|
|
instance IsInvitableJunction SheetCorrector where
|
|
type InvitationFor SheetCorrector = Sheet
|
|
data InvitableJunction SheetCorrector = JunctionSheetCorrector
|
|
{ jSheetCorrectorLoad :: Load
|
|
, jSheetCorrectorState :: CorrectorState
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationDBData SheetCorrector = InvDBDataSheetCorrector
|
|
{ invDBSheetCorrectorLoad :: Load
|
|
, invDBSheetCorrectorState :: CorrectorState
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState))
|
|
(\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..})
|
|
|
|
instance ToJSON (InvitableJunction SheetCorrector) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction SheetCorrector) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData SheetCorrector) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
instance FromJSON (InvitationDBData SheetCorrector) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
|
|
|
instance ToJSON (InvitationTokenData SheetCorrector) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
instance FromJSON (InvitationTokenData SheetCorrector) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
|
|
correctorInvitationConfig :: InvitationConfig SheetCorrector
|
|
correctorInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity _ Sheet{..}) _ = do
|
|
Course{..} <- get404 sheetCourse
|
|
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
|
|
invitationResolveFor _ = do
|
|
cRoute <- getCurrentRoute
|
|
case cRoute of
|
|
Just (CSheetR tid csh ssh shn SCorrInviteR) ->
|
|
fetchSheetId tid csh ssh shn
|
|
_other ->
|
|
error "correctorInvitationConfig called from unsupported route"
|
|
invitationSubject (Entity _ Sheet{..}) _ = do
|
|
Course{..} <- get404 sheetCourse
|
|
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
|
|
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
|
|
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
|
|
invitationInsertHook _ _ _ _ _ = id
|
|
invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
|
|
invitationUltDest (Entity _ Sheet{..}) _ = do
|
|
Course{..} <- get404 sheetCourse
|
|
return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR
|
|
|
|
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
getSCorrInviteR = postSCorrInviteR
|
|
postSCorrInviteR = invitationR correctorInvitationConfig
|