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

module Handler.Sheet where

import Import

import Jobs.Queue

-- import Utils.Lens
import Utils.Sheet
import Handler.Utils
-- import Handler.Utils.Zip
import Handler.Utils.Table.Cells
-- import Handler.Utils.Table.Columns
import Handler.Utils.SheetType
import Handler.Utils.Delete
import Handler.Utils.Invitations

-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
--
-- import Colonnade hiding (fromMaybe, singleton, bool)
--
-- import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C

-- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-- import qualified Database.Esqueleto.Internal.Sql as E

import Control.Monad.Writer (MonadWriter(..), execWriterT)
-- import Control.Monad.Trans.RWS.Lazy (RWST, local)

-- import qualified Text.Email.Validate as Email

-- import qualified Data.List as List

import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)

import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map

import Data.Map (Map, (!))

import Data.Monoid (Any(..))

-- import Control.Lens
import Utils.Lens

--import qualified Data.Aeson as Aeson

import Control.Monad.Random.Class (MonadRandom(..))
import Utils.Sql

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


{-
  * Implement Handlers
  * Implement Breadcrumbs in Foundation
  * Implement Access in Foundation
-}

data SheetForm = SheetForm
      { sfName         :: SheetName
      , sfVisibleFrom  :: Maybe UTCTime
      , sfActiveFrom   :: UTCTime
      , sfActiveTo     :: UTCTime
      , sfHintFrom     :: Maybe UTCTime
      , sfSolutionFrom :: Maybe UTCTime
      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
      , sfHintF        :: Maybe (Source Handler (Either FileId File))
      , sfSolutionF    :: Maybe (Source Handler (Either FileId File))
      , sfMarkingF     :: Maybe (Source Handler (Either FileId File))
      , sfType         :: SheetType
      , sfGrouping     :: SheetGroup
      , sfSubmissionMode :: SubmissionMode
      , sfDescription  :: Maybe Html
      , sfMarkingText  :: Maybe Html
      -- Keine SheetId im Formular!
      }

getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
getFtIdMap sId = do
  allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
      E.on     $ sheetFile E.^. SheetFileFile  E.==. file E.^. FileId
      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
      return    (sheetFile E.^. SheetFileType, file E.^. FileId)
  return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]

makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
    oldFileIds <- (return.) <$> case msId of
      Nothing    -> return $ partitionFileType mempty
      (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
    mr <- getMsgRenderer
    ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
    (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
      <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
      <* aformSection MsgSheetFormTimes
      <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
            & setTooltip MsgSheetVisibleFromTip)
                                                              ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
      <*> areq utcTimeField   (fslI MsgSheetActiveFrom
            & setTooltip MsgSheetActiveFromTip)
                                                              (sfActiveFrom   <$> template)
      <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
      <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
            & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
      <*> aopt utcTimeField   (fslpI MsgSheetSolutionFrom  "Datum, sonst nur für Korrektoren"
            & setTooltip MsgSheetSolutionFromTip)             (sfSolutionFrom <$> template)
      <* aformSection MsgSheetFormFiles
      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarkingFiles
            & setTooltip MsgSheetMarkingTip)                  (sfMarkingF <$> template)
      <* aformSection MsgSheetFormType
      <*> sheetTypeAFormReq   (fslI MsgSheetType
            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus, MsgSheetTypeInfoInformational, MsgSheetTypeInfoNotGraded]))
                                                          (sfType        <$> template)
      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
      <*> aopt htmlField      (fslpI MsgSheetDescription "Html")
                                                          (sfDescription <$> template)
      <*> aopt htmlField    (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
    return $ case result of
      FormSuccess sheetResult
        | errorMsgs <- validateSheet mr sheetResult
        , not $ null errorMsgs ->
            (FormFailure errorMsgs, widget)
      _ -> (result, widget)
  where
    validateSheet :: MsgRenderer -> SheetForm -> [Text]
    validateSheet (MsgRenderer {..}) (SheetForm{..}) =
      [ msg | (False, msg) <-
        [ (      sfVisibleFrom  <=       Just sfActiveFrom  , render MsgSheetErrVisibility)
        , (      sfActiveFrom   <=            sfActiveTo    , render MsgSheetErrDeadlineEarly)
        , ( NTop sfHintFrom     >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly)
        , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo)   , render MsgSheetErrSolutionEarly)
      ] ]


getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetCurrentR tid ssh csh = do
  mbShn <- runDB $ sheetCurrent tid ssh csh
  case mbShn of
    Just shn -> redirectAccess $ CSheetR tid ssh csh shn SShowR
    Nothing  -> do -- no current sheet exists
      -- users should never see a link to this URL in this situation,
      -- but we had confused users that used a bookmark instead.
      let headingShort = [whamlet|_{MsgMenuSheetCurrent}|]
          headingLong = prependCourseTitle tid ssh csh MsgMenuSheetCurrent
      siteLayout headingShort $ do
        setTitleI headingLong
        [whamlet|_{MsgSheetNoCurrent}|]


getSheetOldUnassignedR:: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetOldUnassignedR tid ssh csh = do
    mbShn <- runDB $ sheetOldUnassigned tid ssh csh
    case mbShn of
      Just shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR
      Nothing  -> do -- no unassigned submissions in any inactive sheet
        -- users should never see a link to this URL in this situation,
        -- but we had confused users that used a bookmark instead.
        let headingShort = [whamlet|_{MsgMenuSheetOldUnassigned}|]
            headingLong = prependCourseTitle tid ssh csh MsgMenuSheetOldUnassigned
        siteLayout headingShort $ do
          setTitleI headingLong
          [whamlet|_{MsgSheetNoOldUnassigned}|]

getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do
  muid <- maybeAuthId
  now <- liftIO getCurrentTime
  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
  let
    hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType]
    hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking)
      = [ sft | sft <- [minBound..maxBound]
              , sft /= SheetExercise || hasExercise
              , sft /= SheetHint     || hasHint
              , sft /= SheetSolution || hasSolution
              , sft /= SheetMarking  || hasMarking
        ]
    lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
        E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
        return . E.max_ $ sheetEdit E.^. SheetEditTime

    sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery ()
    sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
      E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
      E.on $  (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
        E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid

    sheetFilter :: SheetName -> DB Bool
    sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False

    sheetCol = widgetColonnade . mconcat $
      [ -- dbRow ,
        sortable (Just "name") (i18nCell MsgSheet)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName
      , sortable (Just "last-edit") (i18nCell MsgLastEdit)
          $ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
      , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
      , sortable (toNothing "downloads") (i18nCell MsgFiles)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> listCell
              [ icnCell & addIconFixedWidth
              | let existingSFTs = hasSFT existFiles
              , sft <- [minBound..maxBound]
              , let link = CSheetR tid ssh csh sheetName $ SZipR sft
              , let icn  = toWidget $ sheetFile2markup sft
              , let icnCell = if sft `elem` existingSFTs
                              then linkEmptyCell link icn
                              else spacerCell
              ] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
      , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveFrom
      , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveTo
      , sortable Nothing (i18nCell MsgSheetType)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
      , sortable Nothing (i18nCell MsgSubmission)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
              Nothing -> mempty
              (Just (Entity sid Submission{..})) ->
                let mkCid = encrypt sid -- TODO: executed twice
                    mkRoute = do
                      cid' <- mkCid
                      return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
                in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{cid2}|])
      , sortable (Just "rating") (i18nCell MsgRating)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
            let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
            case mbSub of
              Nothing -> cellTell mempty $ stats Nothing
              (Just (Entity sid sub@Submission{..})) ->
                let mkCid = encrypt sid
                    mkRoute = do
                      cid' <- mkCid
                      return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
                    mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
                    acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
                in cellTell acell $ stats submissionRatingPoints

      , sortable Nothing -- (Just "percent")
                        (i18nCell MsgRatingPercent)
          $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub,_)} -> case mbSub of
              (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
                case preview (_grading . _maxPoints) sType of
                  Just maxPoints
                    | maxPoints /= 0 -> textCell $ textPercent sPoints maxPoints
                  _other -> mempty
              _other -> mempty
      ]

    psValidator = def
      & defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"]

  (raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
      { dbtColonnade = sheetCol
      , dbtSQLQuery  = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do
                          sheetData dt
                          let existFiles = -- check whether files exist for given type
                                ( hasSheetFileQuery sheet SheetExercise
                                , hasSheetFileQuery sheet SheetHint
                                , hasSheetFileQuery sheet SheetSolution
                                , hasSheetFileQuery sheet SheetMarking
                                )
                          return (sheet, lastSheetEdit sheet, submission, existFiles)
      , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
      , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _, _) }
                    -> dbr <$ guardM (lift $ sheetFilter sheetName)
      , dbtSorting   = Map.fromList
        [ ( "name"
          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
          )
        , ( "last-edit"
          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
          )
        , ( "visible-from"
          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetVisibleFrom
          )
        , ( "submission-since"
          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
          )
        , ( "submission-until"
          , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
          )
        , ( "rating"
          , SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
          )
  --    GitLab Issue $143: HOW TO SORT?
  --       , ( "percent"
  --         , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
  --             case sheetType of -- no Haskell inside Esqueleto, right?
  --             (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
  --         )
        ]
      , dbtFilter    = mempty
      , dbtFilterUI  = mempty
      , dbtStyle     = def
      , dbtParams    = def
      , dbtIdent     = "sheets" :: Text
      , dbtCsvEncode = noCsvEncode
      , dbtCsvDecode = Nothing
      }
    -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!!
    --   -- Collect summary over all Sheets, not just the ones shown due to pagination:
    --   do
    --     rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
    --       sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
    --     flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName)
    -- )

  let statistics = gradeSummaryWidget MsgSheetGradingSummaryTitle raw_statistics -- only over shown rows
        -- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
  defaultLayout $ do
    $(widgetFile "sheetList")

data ButtonGeneratePseudonym = BtnGenerate
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonGeneratePseudonym
instance Finite ButtonGeneratePseudonym

nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)

instance Button UniWorX ButtonGeneratePseudonym where
  btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
  btnClasses BtnGenerate = [BCIsButton, BCDefault]

-- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do
  now <- liftIO getCurrentTime
  Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
  seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility

  let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a
      sftVisible sft | Just dts <- sheetFileTypeDates sheet sft
                        = dateTimeCellVisible now dts
                     | otherwise = isVisibleCell False

      sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a
      sftModification sft mtime
        | seeAllModificationTimestamps  =  dateTimeCell mtime
        | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft)  =  dateTimeCell mtime
        | otherwise  =  mempty

  let fileData (sheetFile `E.InnerJoin` file) = do
        -- Restrict to consistent rows that correspond to each other
        E.on (sheetFile E.^. SheetFileFile  E.==.  file E.^. FileId)
        -- filter to requested file
        E.where_ $  sheetFile E.^. SheetFileSheet  E.==.  E.val sid
              E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories
        -- return desired columns
        return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
  let colonnadeFiles = widgetColonnade $ mconcat
        [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) ->
            let link = CSheetR tid ssh csh shn $ SZipR ftype in
            tellCell (Any True) $
            anchorCell link [whamlet|#{sheetFile2markup ftype}  _{ftype}|]
            -- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))

        -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
        , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
             (CSheetR tid ssh csh shn (SFileR fType fName))
             (str2widget fName)
        , sortable (toNothing "visible") (i18nCell MsgVisibleFrom)
            $ \(_,              _ , E.Value ftype) -> sftVisible ftype
        , sortable (Just "time")        (i18nCell MsgFileModified)
            $ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified
        -- , colFileModification (view _2)
        ]
  let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
  (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
    { dbtSQLQuery = fileData
    , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
    , dbtColonnade = colonnadeFiles
    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
                   -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput
    , dbtStyle = def
    , dbtFilter = mempty
    , dbtFilterUI = mempty
    , dbtIdent = "files" :: Text
    , dbtSorting = Map.fromList
      [ ( "type"
        , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> E.orderByEnum $ sheetFile E.^. SheetFileType
        )
      , ( "path"
        , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
        )
      -- , ( "visible"
      --   , SortColumn $ \(sheetFile `E.InnerJoin` _file) ->  sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet
      --   )
      , ( "time"
        , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified
        )
      ]
    , dbtParams = def
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    }
  (hasHints, hasSolution) <- runDB $ do
    hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
    hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
    return (hasHints, hasSolution)
  mPseudonym <- runMaybeT $ do
    uid <- MaybeT maybeAuthId
    Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid
    return $ review _PseudonymText sheetPseudonymPseudonym
  (generateWidget, generateEnctype) <- generateFormPost $ \csrf ->
    over _2 ((toWidget csrf <>) . fvInput) <$> mreq (buttonField BtnGenerate) "" Nothing
  let generateForm = wrapForm generateWidget def
        { formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SPseudonymR
        , formEncoding = generateEnctype
        , formSubmit = FormNoSubmit
        }

  defaultLayout $ do
    setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
    let zipLink = CSheetR tid ssh csh shn SArchiveR
        visibleFrom =     visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom  sheet
    sheetFrom    <-           formatTime SelFormatDateTime  $  sheetActiveFrom   sheet
    sheetTo      <-           formatTime SelFormatDateTime  $  sheetActiveTo     sheet
    hintsFrom    <- traverse (formatTime SelFormatDateTime) $  sheetHintFrom     sheet
    solutionFrom <- traverse (formatTime SelFormatDateTime) $  sheetSolutionFrom sheet
    markingText  <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
    $(widgetFile "sheetShow")

getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSArchiveR tid ssh csh shn = do
  MsgRenderer mr <- getMsgRenderer
  let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <.> "zip"
      sftArchive  = CSheetR tid ssh csh shn . SZipR    -- used to check access to SheetFileTypes
  allowedSFTs <- filterM (hasReadAccessTo . sftArchive) [minBound..maxBound]
  serveZipArchive archiveName $ sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal


getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSPseudonymR = postSPseudonymR
postSPseudonymR tid ssh csh shn = do
  uid <- requireAuthId
  shId <- runDB $ fetchSheetId tid ssh csh shn
  let
    genPseudonym = do
      inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do
        candidate <- liftIO getRandom
        existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid
        case existing of
          Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym
          Nothing
            -> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
      case inserted of
        Right Nothing -> genPseudonym
        Right (Just ps) -> return ps
        Left ps -> return ps
  ps <- genPseudonym
  selectRep $ do
    provideRep . return $ review _PseudonymText ps
    provideJson ps
    provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html)


getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal

getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
getSZipR tid ssh csh shn sft = do
  MsgRenderer mr <- getMsgRenderer
  let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <> "_" <> (unpack $ toPathPiece sft) <.> "zip"
  serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal


getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetNewR tid ssh csh = do
  parShn <- runInputGetResult $ iopt ciField "shn"
  let searchShn sheet = case parShn of
        (FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
        -- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml)
        _other -> return ()
  lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
      E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourse
      E.where_ $ course E.^. CourseTerm      E.==. E.val tid
          E.&&.  course E.^. CourseSchool    E.==. E.val ssh
          E.&&.  course E.^. CourseShorthand E.==. E.val csh
      searchShn sheet
      -- let lastSheetEdit = E.sub_select . E.from $ \sheetEdit -> do
      --       E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
      --       return . E.max_ $ sheetEdit E.^. SheetEditTime
      -- Preferring last edited sheet may lead to suggesting duplicated sheet name numbers
      -- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
      E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
      E.limit 1
      return sheet
  now <- liftIO getCurrentTime
  let template = case lastSheets of
        ((Entity {entityVal=Sheet{..}}):_)  ->
          let addTime = addWeeks $ max 1 $ weeksToAdd sheetActiveTo now
          in Just $ SheetForm
            { sfName         = stepTextCounterCI sheetName
            , sfDescription  = sheetDescription
            , sfType         = sheetType
            , sfGrouping     = sheetGrouping
            , sfVisibleFrom  = addTime <$> sheetVisibleFrom
            , sfActiveFrom   = addTime     sheetActiveFrom
            , sfActiveTo     = addTime     sheetActiveTo
            , sfSubmissionMode = sheetSubmissionMode
            , sfSheetF       = Nothing
            , sfHintFrom     = addTime <$> sheetHintFrom
            , sfHintF        = Nothing
            , sfSolutionFrom = addTime <$> sheetSolutionFrom
            , sfSolutionF    = Nothing
            , sfMarkingF     = Nothing
            , sfMarkingText  = sheetMarkingText
            }
        _other -> Nothing
  let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
        insertUnique $ newSheet
  handleSheetEdit tid ssh csh Nothing template action

postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postSheetNewR = getSheetNewR


getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR tid ssh csh shn = do
  (Entity sid Sheet{..}, sheetFileIds) <- runDB $ do
    ent <- fetchSheet tid ssh csh shn
    fti <- getFtIdMap $ entityKey ent
    return (ent, fti)
  let template = Just $ SheetForm
        { sfName         = sheetName
        , sfDescription  = sheetDescription
        , sfType         = sheetType
        , sfGrouping     = sheetGrouping
        , sfVisibleFrom  = sheetVisibleFrom
        , sfActiveFrom   = sheetActiveFrom
        , sfActiveTo     = sheetActiveTo
        , sfSubmissionMode = sheetSubmissionMode
        , sfSheetF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
        , sfHintFrom     = sheetHintFrom
        , sfHintF        = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
        , sfSolutionFrom = sheetSolutionFrom
        , sfSolutionF    = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
        , sfMarkingF     = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
        , sfMarkingText  = sheetMarkingText
        }
  let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
  handleSheetEdit tid ssh csh (Just sid) template action

postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSEditR = getSEditR

handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid ssh csh msId template dbAction = do
  let mbshn  = sfName <$> template
  aid  <- requireAuthId
  ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
  case res of
    (FormSuccess SheetForm{..}) -> do
      saveOkay <- runDB $ do
        actTime <- liftIO getCurrentTime
        cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
        oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId
        let newSheet = Sheet
              { sheetCourse         = cid
              , sheetName           = sfName
              , sheetDescription    = sfDescription
              , sheetType           = sfType
              , sheetGrouping       = sfGrouping
              , sheetMarkingText    = sfMarkingText
              , sheetVisibleFrom    = sfVisibleFrom
              , sheetActiveFrom     = sfActiveFrom
              , sheetActiveTo       = sfActiveTo
              , sheetHintFrom       = sfHintFrom
              , sheetSolutionFrom   = sfSolutionFrom
              , sheetSubmissionMode = sfSubmissionMode
              , sheetAutoDistribute = fromMaybe False oldAutoDistribute
              }
        mbsid <- dbAction newSheet
        case mbsid of
          Nothing    -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
          (Just sid) ->  do -- save files in DB:
            whenIsJust sfSheetF    $ insertSheetFile' sid SheetExercise
            whenIsJust sfHintF     $ insertSheetFile' sid SheetHint
            whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
            whenIsJust sfMarkingF  $ insertSheetFile' sid SheetMarking
            insert_ $ SheetEdit aid actTime sid
            addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
            -- Sanity checks generating warnings only, but not errors!
            warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
                [ (sfVisibleFrom,     MsgSheetVisibleFrom)
                , (Just sfActiveFrom, MsgSheetActiveFrom)
                , (Just sfActiveTo,   MsgSheetActiveTo)
                , (sfHintFrom,        MsgSheetSolutionFromTip)
                , (sfSolutionFrom,    MsgSheetSolutionFrom)
                ] ]
            return True
      when saveOkay $ redirect $ case msId of
        Just _  -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
        Nothing -> CSheetR tid ssh csh sfName SCorrR
    (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
    _ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
            [(sfVisibleFrom  =<< template, MsgSheetVisibleFrom)
            ,(sfActiveFrom   <$> template, MsgSheetActiveFrom)
            ,(sfActiveTo     <$> template, MsgSheetActiveTo)
            ,(sfHintFrom     =<< template, MsgSheetSolutionFromTip)
            ,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
            ] ]

  let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
                        (MsgSheetTitle    tid ssh csh) mbshn
--   let formTitle = pageTitle -- no longer used in template
  actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
  defaultLayout $ do
    setTitleI pageTitle
    let sheetEditForm = wrapForm formWidget def
          { formAction = Just $ SomeRoute actionUrl
          , formEncoding = formEnctype
          }
    $(i18nWidgetFile "sheet-edit")


getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSDelR = postSDelR
postSDelR tid ssh csh shn = do
  sid <- runDB $ fetchSheetId tid ssh csh shn
  deleteR $ (sheetDeleteRoute $ Set.singleton sid)
    { drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
    , drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
    }


insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
insertSheetFile sid ftype finfo = do
    runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
  where
    finsert file = do
      fid <- insert file
      void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step

insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
insertSheetFile' sid ftype fs = do
    oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
           E.&&. sheetFile E.^. SheetFileType    E.==. E.val ftype
      return (file E.^. FileId)
    keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
    mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
  where
    finsert (Left fileId) = tell $ singleton fileId
    finsert (Right file) = lift $ do
      fid <- insert file
      void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step


data CorrectorForm = CorrectorForm
  { cfUserId :: UserId
  , cfUserName :: Text
  , cfResult :: FormResult (CorrectorState, Load)
  , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
  }

type Loads = Map (Either UserEmail UserId) (CorrectorState, Load)

defaultLoads :: SheetId -> DB Loads
-- ^ Generate `Loads` in such a way that minimal editing is required
--
-- For every user, that ever was a corrector for this course, return their last `Load`.
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
defaultLoads shid = do
  cId <- sheetCourse <$> getJust shid
  fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
    E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet

    let creationTime = E.sub_select . E.from $ \sheetEdit -> do
          E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
          return . E.min_ $ sheetEdit E.^. SheetEditTime

    E.where_ $ sheet E.^. SheetCourse E.==. E.val cId

    E.orderBy [E.desc creationTime]

    return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
  where
    toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)


correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
correctorForm shid = wFormToAForm $ do
  Just currentRoute <- liftHandlerT getCurrentRoute
  userId <- liftHandlerT requireAuthId
  MsgRenderer mr <- getMsgRenderer

  let
    currentLoads :: DB Loads
    currentLoads = Map.union
      <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
      <*> fmap (foldMap $ \(email, InvDBDataSheetCorrector load state) -> Map.singleton (Left email) (state, load)) (sourceInvitationsList shid)
  (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads

  isWrite <- liftHandlerT $ isWriteRequest currentRoute

  let
    applyDefaultLoads = Map.null currentLoads' && not isWrite
    loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
    loads
      | applyDefaultLoads = defaultLoads'
      | otherwise         = currentLoads'

  countTutRes <- wreq checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads

  -- when (not (Map.null loads) && applyDefaultLoads) $       -- Alert Message
  --   addMessageI Warning MsgCorrectorsDefaulted
  when (not (Map.null loads) && applyDefaultLoads) $          -- Alert Notification
    wformMessage =<< messageI Warning MsgCorrectorsDefaulted


  let
    previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
    previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
      E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
      E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
      E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
      E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
      E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
      E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
      return user

    miAdd :: ListPosition
          -> Natural
          -> (Text -> Text)
          -> FieldView UniWorX
          -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
    miAdd _ _ nudge submitView = Just $ \csrf -> do
      (addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
      let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
            | existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
            , not $ null existing
              -> FormFailure [mr MsgCorrectorExists]
            | otherwise
              -> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
      return (addRes', $(widgetFile "sheetCorrectors/add"))

    miCell :: ListPosition
           -> Either UserEmail UserId
           -> Maybe (CorrectorState, Load)
           -> (Text -> Text)
           -> Form (CorrectorState, Load)
    miCell _ userIdent initRes nudge csrf = do
      (stateRes, stateView) <- mreq (selectField optionsFinite) ("" & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
      (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
      (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) ("" & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
      let
        res :: FormResult (CorrectorState, Load)
        res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
        tutRes'
          | FormSuccess True <- byTutRes  = Just <$> countTutRes
          | otherwise                     = Nothing <$ byTutRes
      identWidget <- case userIdent of
        Left email -> return . toWidget $ mailtoHtml email
        Right uid -> do
          User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
          return $ nameEmailWidget userEmail userDisplayName userSurname
      return (res, $(widgetFile "sheetCorrectors/cell"))


    miDelete :: Map ListPosition (Either UserEmail UserId)
             -> ListPosition
             -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
    miDelete = miDeleteList

    miAllowAdd :: ListPosition
               -> Natural
               -> ListLength
               -> Bool
    miAllowAdd _ _ _ = True

    miAddEmpty :: ListPosition
               -> Natural
               -> ListLength
               -> Set ListPosition
    miAddEmpty _ _ _ = Set.empty

    miButtonAction :: forall p.
                      PathPiece p
                   => p
                   -> Maybe (SomeRoute UniWorX)
    miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag

    miLayout :: ListLength
             -> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
             -> Map ListPosition Widget
             -> Map ListPosition (FieldView UniWorX)
             -> Map (Natural, ListPosition) Widget
             -> Widget
    miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")

    miIdent :: Text
    miIdent = "correctors"

    postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector)
    postProcess = Set.fromList . map postProcess' . Map.elems
      where
        sheetCorrectorSheet = shid

        postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
        postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
        postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector))

    filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
    filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!

  fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True filledData

getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
  Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn

  ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
    (,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute)
        <*> correctorForm shid

  case res of
    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
    FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
      update shid [ SheetAutoDistribute =. autoDistribute ]

      let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors

      deleteWhere [ SheetCorrectorSheet ==. shid ]
      insertMany_ adds

      deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites]
      sinkInvitationsF correctorInvitationConfig invites

      addMessageI Success MsgCorrectorsUpdated
    FormMissing -> return ()

  defaultLayout $ do
    setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
    wrapForm formWidget def
      { formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SCorrR
      , formEncoding = formEnctype
      }


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

  _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
      Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
      fetchSheetId tid csh ssh shn
    invitationSubject (Entity _ Sheet{..}) _ = do
      Course{..} <- get404 sheetCourse
      return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
    invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- liftHandlerT requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ())
    invitationInsertHook _ _ _ _ = id
    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


getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet!
getSIsCorrR _ _ _ shn = do
  defaultLayout $ [whamlet|You have corrector access to #{shn}.|]

