{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Submission.SubmissionUserInvite
  ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
  , submissionUserInvitationConfig
  , getSInviteR, postSInviteR
  ) where

import Import

import Handler.Utils.Invitations

import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)

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 _ _ _ = pure (JunctionSubmissionUser, ())
    invitationInsertHook _ _ _ _ _ = id
    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