108 lines
5.5 KiB
Haskell
108 lines
5.5 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Submission.SubmissionUserInvite
|
|
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
|
, submissionUserInvitationConfig
|
|
, getSInviteR, postSInviteR
|
|
) where
|
|
|
|
import Import
|
|
import Utils.Form
|
|
|
|
import Handler.Utils.Invitations
|
|
import Handler.Utils.AuthorshipStatement
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
|
|
instance IsInvitableJunction SubmissionUser where
|
|
type InvitationFor SubmissionUser = Submission
|
|
data InvitableJunction SubmissionUser = JunctionSubmissionUser
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationDBData SubmissionUser = InvDBDataSubmissionUser
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
data InvitationTokenData SubmissionUser = InvTokenDataSubmissionUser
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
_InvitableJunction = iso
|
|
(\SubmissionUser{..} -> (submissionUserUser, submissionUserSubmission, JunctionSubmissionUser))
|
|
(\(submissionUserUser, submissionUserSubmission, JunctionSubmissionUser) -> SubmissionUser{..})
|
|
|
|
instance ToJSON (InvitableJunction SubmissionUser) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
instance FromJSON (InvitableJunction SubmissionUser) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
|
|
|
instance ToJSON (InvitationDBData SubmissionUser) where
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationDBData SubmissionUser) where
|
|
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
|
|
|
instance ToJSON (InvitationTokenData SubmissionUser) where
|
|
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
instance FromJSON (InvitationTokenData SubmissionUser) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
|
|
|
submissionUserInvitationConfig :: InvitationConfig SubmissionUser
|
|
submissionUserInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute (Entity subId Submission{..}) _ = do
|
|
Sheet{..} <- getJust submissionSheet
|
|
Course{..} <- getJust sheetCourse
|
|
cID <- encrypt subId
|
|
return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
|
|
invitationResolveFor _ = do
|
|
cRoute <- getCurrentRoute
|
|
case cRoute of
|
|
Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do
|
|
subId <- decrypt cID
|
|
bool notFound (return subId) =<< existsKey subId
|
|
_other ->
|
|
error "submissionUserInvitationConfig called from unsupported route"
|
|
invitationSubject (Entity _ Submission{..}) _ = do
|
|
Sheet{..} <- getJust submissionSheet
|
|
Course{..} <- getJust sheetCourse
|
|
return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName
|
|
invitationHeading (Entity _ Submission{..}) _ = do
|
|
Sheet{..} <- getJust submissionSheet
|
|
return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
|
|
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
|
|
invitationTokenConfig (Entity _ Submission{..}) _ = do
|
|
Sheet{..} <- getJust submissionSheet
|
|
Course{..} <- getJust sheetCourse
|
|
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
|
itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
|
|
let itExpiresAt = Nothing
|
|
itStartsAt = Nothing
|
|
return InvitationTokenConfig{..}
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm (Entity _ Submission{..}) _ _ = wFormToAForm $ do
|
|
-- TODO(AuthorshipStatements): allow invitee to download submission files/see co-submittors iff authorship-statement is required
|
|
authorshipStatementRes <- maybeT (return $ FormSuccess Nothing) . fmap (fmap Just) $ do
|
|
sheetEnt <- lift . lift . lift $ getJustEntity submissionSheet
|
|
asd <- MaybeT . lift . lift $ getSheetAuthorshipStatement sheetEnt
|
|
lift $ wpopt (acceptAuthorshipStatementField asd) (fslI MsgSubmissionAuthorshipStatement & setTooltip MsgSubmissionAuthorshipStatementTip) Nothing
|
|
return $ (JunctionSubmissionUser, ) <$> authorshipStatementRes
|
|
invitationInsertHook _ (Entity smid _) _ SubmissionUser{..} masdId act = do
|
|
for_ masdId $ \asdId -> do
|
|
now <- liftIO getCurrentTime
|
|
insert_ $ AuthorshipStatementSubmission asdId smid submissionUserUser now
|
|
act
|
|
invitationSuccessMsg (Entity _ Submission{..}) _ = do
|
|
Sheet{..} <- getJust submissionSheet
|
|
return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName
|
|
invitationUltDest (Entity subId Submission{..}) _ = do
|
|
Sheet{..} <- getJust submissionSheet
|
|
Course{..} <- getJust sheetCourse
|
|
cID <- encrypt subId
|
|
return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
|
|
|
|
getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
|
getSInviteR = postSInviteR
|
|
postSInviteR = invitationR submissionUserInvitationConfig
|