{-# 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