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


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