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

module Handler.Tutorial.TutorInvite
  ( getTInviteR, postTInviteR
  , tutorInvitationConfig
  , InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
  ) where

import Import
import Handler.Utils.Tutorial
import Handler.Utils.Invitations

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


instance IsInvitableJunction Tutor where
  type InvitationFor Tutor = Tutorial
  data InvitableJunction Tutor = JunctionTutor
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationDBData Tutor = InvDBDataTutor
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData Tutor = InvTokenDataTutor
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\Tutor{..} -> (tutorUser, tutorTutorial, JunctionTutor))
    (\(tutorUser, tutorTutorial, JunctionTutor) -> Tutor{..})

instance ToJSON (InvitableJunction Tutor) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction Tutor) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }

instance ToJSON (InvitationDBData Tutor) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData Tutor) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }

instance ToJSON (InvitationTokenData Tutor) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData Tutor) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }

tutorInvitationConfig :: InvitationConfig Tutor
tutorInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Tutorial{..}) _ = do
      Course{..} <- get404 tutorialCourse
      return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
    invitationResolveFor _ = do
      cRoute <- getCurrentRoute
      case cRoute of
        Just (CTutorialR tid csh ssh tutn TInviteR) ->
          fetchTutorialId tid csh ssh tutn
        _other ->
          error "tutorInvitationConfig called from unsupported route"
    invitationSubject (Entity _ Tutorial{..}) _ = do
      Course{..} <- get404 tutorialCourse
      return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
    invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ _ _ = pure (JunctionTutor, ())
    invitationInsertHook _ _ _ _ _ = id
    invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
    invitationUltDest (Entity _ Tutorial{..}) _ = do
      Course{..} <- get404 tutorialCourse
      return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR

getTInviteR, postTInviteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTInviteR = postTInviteR
postTInviteR = invitationR tutorInvitationConfig