-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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

module Handler.Sheet.CorrectorInvite
  ( getSCorrInviteR, postSCorrInviteR
  , InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
  , correctorInvitationConfig
  ) where

import Import

import Handler.Utils
import Handler.Utils.Invitations

import qualified Data.HashSet as HashSet

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


instance IsInvitableJunction SheetCorrector where
  type InvitationFor SheetCorrector = Sheet
  data InvitableJunction SheetCorrector = JunctionSheetCorrector
    { jSheetCorrectorLoad :: Load
    , jSheetCorrectorState :: CorrectorState
    } deriving (Eq, Ord, Read, Show, Generic)
  data InvitationDBData SheetCorrector = InvDBDataSheetCorrector
    { invDBSheetCorrectorLoad :: Load
    , invDBSheetCorrectorState :: CorrectorState
    } deriving (Eq, Ord, Read, Show, Generic)
  data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector
    deriving (Eq, Ord, Read, Show, Generic)

  _InvitableJunction = iso
    (\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState))
    (\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..})

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

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

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

correctorInvitationConfig :: InvitationConfig SheetCorrector
correctorInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Sheet{..}) _ = do
      Course{..} <- get404 sheetCourse
      return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
    invitationResolveFor _ = do
      cRoute <- getCurrentRoute
      case cRoute of
        Just (CSheetR tid csh ssh shn SCorrInviteR) ->
          fetchSheetId tid csh ssh shn
        _other ->
          error "correctorInvitationConfig called from unsupported route"
    invitationSubject (Entity _ Sheet{..}) _ = do
      Course{..} <- get404 sheetCourse
      return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
    invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure (JunctionSheetCorrector cLoad cState, ())
    invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheCorrectorList $ Proxy @(Set UserId))
    invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
    invitationUltDest (Entity _ Sheet{..}) _ = do
      Course{..} <- get404 sheetCourse
      return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR

getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSCorrInviteR = postSCorrInviteR
postSCorrInviteR = invitationR correctorInvitationConfig