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

module Handler.Course.LecturerInvite
  ( lecturerInvitationConfig
  , getCLecInviteR, postCLecInviteR
  , InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
  ) where

import Import

import Utils.Form
import Handler.Utils.Invitations

import qualified Data.CaseInsensitive as CI

import Data.Aeson hiding (Result(..))

import Text.Hamlet (ihamlet)

import qualified Data.HashSet as HashSet


instance IsInvitableJunction Lecturer where
  type InvitationFor Lecturer = Course
  data InvitableJunction Lecturer = JunctionLecturer
    { jLecturerType :: LecturerType
    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationDBData Lecturer = InvDBDataLecturer
    { invDBLecturerType :: Maybe LecturerType
    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData Lecturer = InvTokenDataLecturer
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType))
    (\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..})

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

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

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

lecturerInvitationConfig :: InvitationConfig Lecturer
lecturerInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
    invitationResolveFor _ = do
      cRoute <- getCurrentRoute
      case cRoute of
        Just (CourseR tid csh ssh CLecInviteR) ->
          getKeyBy404 $ TermSchoolCourseShort tid csh ssh
        _other -> error "lecturerInvitationConfig called from unsupported route"
    invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
    invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of
      Nothing    -> areq    (selectField optionsFinite) lFs Nothing
      Just lType -> aforced (selectField optionsFinite) lFs lType
      where
        toJunction jLecturerType = (JunctionLecturer{..}, ())
        lFs :: FieldSettings UniWorX
        lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
    invitationInsertHook _ _ _ _ _ = id
    invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do
      MsgRenderer mr <- getMsgRenderer
      return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
    invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR


getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCLecInviteR = postCLecInviteR
postCLecInviteR = invitationR lecturerInvitationConfig