module Handler.Sheet where

import Import

import Jobs.Queue

import System.FilePath (takeFileName)

import Utils.Sheet
import Handler.Utils
-- import Handler.Utils.Zip
import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
import Handler.Utils.Delete
import Handler.Utils.Form.MassInput

-- 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.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 Network.Mime

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


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

data SheetForm = SheetForm
      { sfName         :: SheetName
      , sfDescription  :: Maybe Html
      , sfType         :: SheetType
      , sfGrouping     :: SheetGroup
      , sfVisibleFrom  :: Maybe UTCTime
      , sfActiveFrom   :: UTCTime
      , sfActiveTo     :: UTCTime
      , sfSubmissionMode :: SubmissionMode
      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
      , sfHintFrom     :: Maybe UTCTime
      , sfHintF        :: Maybe (Source Handler (Either FileId File))
      , sfSolutionFrom :: Maybe UTCTime
      , sfSolutionF    :: Maybe (Source Handler (Either FileId File))
      , sfMarkingF     :: Maybe (Source Handler (Either FileId File))
      , 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)
      <*> aopt htmlField      (fslpI MsgSheetDescription "Html")
                                                          (sfDescription <$> template)
      <*> sheetTypeAFormReq   (fslI MsgSheetType
            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
                                                          (sfType        <$> template)
      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
      <*> 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)
      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
      <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
            & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
      <*> aopt utcTimeField   (fslpI MsgSheetSolutionFrom  "Datum, sonst nur für Korrektoren"
            & setTooltip MsgSheetSolutionFromTip)
                                                              (sfSolutionFrom <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarking
            & setTooltip MsgSheetMarkingTip)   (sfMarkingF <$> template)
      <*> aopt htmlField      (fslI MsgSheetMarking)      (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 = runDB $ do
  let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR
  shn <- sheetCurrent tid ssh csh
  maybe notFound redi shn

getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler ()
getSheetOldUnassigned tid ssh csh = runDB $ do
  let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR
  shn <- sheetOldUnassigned tid ssh csh
  maybe notFound redi shn

getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do
  muid <- maybeAuthId
  Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  let
    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) (toWidget sheetName)
      , sortable (Just "last-edit") (i18nCell MsgLastEdit)
          $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty dateTimeCell mEditTime
      , sortable (Just "visible-from") (i18nCell MsgSheetVisibleFrom)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> maybe mempty dateTimeCell sheetVisibleFrom
      , 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|#{display 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 ->
                        let percent = sPoints / maxPoints
                        in textCell $ textPercent $ realToFrac percent
                  _other -> mempty
              _other -> mempty
      ]

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

  (raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
      { dbtColonnade = sheetCol
      , dbtSQLQuery  = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
                          -> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
      , 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
      }
    -- ) ( -- !!!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
  Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
  -- without Colonnade
--   fileNameTypes <- runDB $ E.select $ E.from $
--     \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
--       -- Restrict to consistent rows that correspond to each other
--       E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
--       E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
--       -- filter to requested file
--       E.where_ (sheet     E.^. SheetId      E.==. E.val sid )
--       -- return desired columns
--       return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
--   let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
  -- with Colonnade

  let fileData (sheet' `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
        -- Restrict to consistent rows that correspond to each other
        E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
        E.on (sheetFile E.^. SheetFileSheet   E.==. sheet'    E.^. SheetId)
        -- filter to requested file
        E.where_ $  sheet'    E.^. SheetId      E.==. E.val sid
              E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
        -- return desired columns
        return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
  let colonnadeFiles = widgetColonnade $ mconcat
        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
        , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell
            (CSheetR tid ssh csh shn (SFileR fType fName))
            (str2widget fName)
        , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
        ]
  let psValidator = def
        & defaultSorting [SortAscBy "type", SortAscBy "path"]
  (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
    { dbtSQLQuery = fileData
    , dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
    , dbtColonnade = colonnadeFiles
    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
                   -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
    , dbtStyle = def
    , dbtFilter = mempty
    , dbtFilterUI = mempty
    , dbtIdent = "files" :: Text
    , dbtSorting = Map.fromList
      [ ( "type"
        , SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType
        )
      , ( "path"
        , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
        )
      , ( "time"
        , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
        )
      ]
    , dbtParams = def
    }
  (hasHints, hasSolution) <- runDB $ do
    hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
    hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
    return (hasHints, hasSolution)
  cTime <- Just <$> liftIO getCurrentTime
  visibleFrom <-    traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom  sheet
  when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
    maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
  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 $ MsgSheetTitle tid ssh csh shn
    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")

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 typ title = do
  results <- runDB $ E.select $ E.from $
    \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
      -- Restrict to consistent rows that correspond to each other
      E.on (file      E.^. FileId         E.==. sheetFile E.^. SheetFileFile)
      E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
      E.on (sheet     E.^. SheetCourse    E.==. course    E.^. CourseId)
      -- filter to requested file
      E.where_ ((file      E.^. FileTitle       E.==. E.val title)
        E.&&.   (sheetFile E.^. SheetFileType   E.==. E.val typ  )
        E.&&.   (sheet     E.^. SheetName       E.==. E.val shn  )
        E.&&.   (course    E.^. CourseShorthand E.==. E.val csh  )
        E.&&.   (course    E.^. CourseSchool    E.==. E.val ssh  )
        E.&&.   (course    E.^. CourseTerm      E.==. E.val tid  )
        )
      -- return desired columns
      return $ (file E.^. FileTitle, file E.^. FileContent)
  case results of
    [(E.Value fileTitle, E.Value fileContent)]
      | Just fileContent' <- fileContent -> do
          whenM downloadFiles $
            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
          return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
      | otherwise -> sendResponseStatus noContent204 ()
    [] -> notFound
    other -> do
      $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
      error "Multiple matching files found."

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 [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
            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 $ (join . (flip fmap template))
          <$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]

  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
    wrapForm formWidget def
      { formAction = Just $ SomeRoute actionUrl
      , formEncoding = formEnctype
      }


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 SheetCorrectorInvitation 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 $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. 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'

  when (not (Map.null loads) && applyDefaultLoads) $
    addMessageI Warning MsgCorrectorsDefaulted

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

  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
      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 :: ListLength
             -> 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")

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

        postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector
        postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
        postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..}

  fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) True (Just . Map.fromList . zip [0..] $ Map.toList loads)

getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
  uid <- requireAuthId
  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 ]
      deleteWhere [ SheetCorrectorSheet ==. shid ]
      deleteWhere [ SheetCorrectorInvitationSheet ==. shid, SheetCorrectorInvitationEmail /<-. toListOf (folded . _Left . _sheetCorrectorInvitationEmail) sheetCorrectors ]
      forM_ sheetCorrectors $ \case
        Right shCor -> insert_ shCor
        Left shCorInv -> do
          insertRes <- insertBy shCorInv
          case insertRes of
            Right _ ->
              void . queueDBJob $ JobCorrectorInvitation uid shCorInv
            Left (Entity old _) ->
               replace old shCorInv
      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
      }


data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ButtonCorrInvite
instance Finite ButtonCorrInvite

nullaryPathPiece ''ButtonCorrInvite $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''ButtonCorrInvite id

instance Button UniWorX ButtonCorrInvite where
  btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary]
  btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger]

getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> UserEmail -> Handler Html
getSCorrInviteR = postSCorrInviteR
postSCorrInviteR tid ssh csh shn email = do
  uid <- requireAuthId
  (Entity _ Course{..}, Entity shid Sheet{..}, Entity ciId SheetCorrectorInvitation{..}) <- runDB $ do
    (sRes@(Entity shid _), cRes) <- fetchSheetCourse tid ssh csh shn
    iRes <- getBy404 $ UniqueSheetCorrectorInvitation email shid
    return (cRes, sRes, iRes)

  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ formEmbedJwtPost buttonForm

  let btnWidget = wrapForm btnInnerWidget def
        { formEncoding = btnEncoding
        , formAction = Just . SomeRoute . CSheetR tid ssh csh shn $ SCorrInviteR email
        , formSubmit = FormNoSubmit
        }

  formResult btnResult $ \case
    BtnCorrInvAccept -> do
      runDB $ do
        delete ciId
        insert_ $ SheetCorrector uid shid sheetCorrectorInvitationLoad sheetCorrectorInvitationState
      addMessageI Success $ MsgCorrectorInvitationAccepted shn
      redirect $ CSheetR tid ssh csh shn SShowR
    BtnCorrInvDecline -> do
      runDB $
        delete ciId
      addMessageI Info $ MsgCorrectorInvitationDeclined shn
      redirect HomeR

  siteLayoutMsg (MsgSheetCorrInviteHeading shn) $ do
    setTitleI $ MsgSheetCorrInviteHeading shn
    $(widgetFile "sheetCorrInvite")
