module Handler.Sheet where

import Import
import System.FilePath (takeFileName)

import Handler.Utils
-- import Handler.Utils.Zip
import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
import Handler.Utils.Delete

-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
--
-- import Colonnade hiding (fromMaybe, singleton, bool)
import qualified Yesod.Colonnade as Yesod
import Text.Blaze (text)
--
-- 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 :: SheetSubmissionMode
      , sfUploadMode   :: UploadMode
      , 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 = identForm FIDsheet $ \html -> do
    oldFileIds <- (return.) <$> case msId of
      Nothing    -> return $ partitionFileType mempty
      (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
    mr <- getMsgRenderer
    ctime <- liftIO $ getCurrentTime
    (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
      <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
      <*> aopt htmlField      (fslI MsgSheetDescription)  (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)
      <*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
      <*> areq uploadModeField (fslI MsgSheetUploadMode)      ((sfUploadMode   <$> template) <|> pure (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)
      <*  submitButton
    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)
      ] ]

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 timeCell mEditTime
      , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveFrom
      , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell 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)} -> case mbSub of
              Nothing -> mempty
              (Just (Entity sid Submission{..})) ->
                let mkCid = encrypt sid
                    mkRoute = do
                      cid' <- mkCid
                      return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
                in anchorCellM mkRoute $(widgetFile "widgets/rating")
      , 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"]

  (table,raw_statistics) <- runDB $ liftA2 (,)
    (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
          )
        , ( "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
      }
    ) (
      -- 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 $
        foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
        raw_statistics
  defaultLayout $ do
    $(widgetFile "sheetList")

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

nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)

instance Button UniWorX ButtonGeneratePseudonym where
  label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
  cssClass BtnGenerate = 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
  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
    $(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
  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
      E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
      E.limit 1
      return sheet
  let template = case lastSheets of
        ((Entity {entityVal=Sheet{..}}):_)  -> Just $ SheetForm
          { sfName         = stepTextCounterCI sheetName
          , sfDescription  = sheetDescription
          , sfType         = sheetType
          , sfGrouping     = sheetGrouping
          , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
          , sfActiveFrom   = addOneWeek     sheetActiveFrom
          , sfActiveTo     = addOneWeek     sheetActiveTo
          , sfSubmissionMode = sheetSubmissionMode
          , sfUploadMode   = sheetUploadMode
          , sfSheetF       = Nothing
          , sfHintFrom     = addOneWeek <$> sheetHintFrom
          , sfHintF        = Nothing
          , sfSolutionFrom = addOneWeek <$> 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
        , sfUploadMode   = sheetUploadMode
        , 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 newSheet = do
        replaceRes <- myReplaceUnique sid $ newSheet
        case replaceRes of
          Nothing     -> return $ Just sid
          (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
  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
              , sheetUploadMode     = sfUploadMode
              , 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
  let formText  = Nothing :: Maybe UniWorXMessage
  actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
  defaultLayout $ do
    setTitleI pageTitle
    $(widgetFile "formPageI18n")


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 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 uid (state, load)


correctorForm :: SheetId -> MForm Handler (FormResult (Bool {- ^ autoDistribute -} , Set SheetCorrector), [FieldView UniWorX])
correctorForm shid = do
  cListIdent <- newFormIdent
  let
    guardNonDeleted :: UserId -> Handler (Maybe UserId)
    guardNonDeleted uid = do
      CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser
      deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
      return $ bool Just (const Nothing) (isJust deleted) uid
  formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
  let
    currentLoads :: DB Loads
    currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
  (autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
  loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
    | Map.null currentLoads'
    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
    | otherwise              -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'

  deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')

  let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
      didDelete = any (flip Set.member deletions) formCIDs

  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
  (autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
  let
    tutorField :: Field Handler [UserEmail]
    tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
      { fieldView = \theId name attrs _val isReq -> asWidgetT $ do
          listIdent <- newIdent
          userId <- handlerToWidget requireAuthId
          previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ 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 E.^. UserEmail
          [whamlet|
            $newline never
            <input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
            <datalist id=#{listIdent}>
              $forall E.Value prev <- previousCorrectors
                <option value=#{prev}>
          |]
      }
  (addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)

  loads <- case addTutRes of
    FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
      mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
      case mUid of
        Nothing  -> loads'' <$ addMessageI Error (MsgEMailUnknown email)
        Just uid
          | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
          | otherwise                   -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
    FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
    _ -> return loads''

  let deletions' = deletions `Set.difference` Map.keysSet loads

  names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
    E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys  loads)
    return $ (user E.^. UserId, user E.^. UserDisplayName)

  let
    constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
    constructFields (uid, uname, (state, Load{..})) = do
      CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
      let
        fs name = ""
          { fsName = Just $ tshow ciphertext <> "-" <> name
          }
        rationalField = convertField toRational fromRational doubleField

      (stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
      (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
      (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
      (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
      let
        cfResult :: FormResult (CorrectorState, Load)
        cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
        tutRes'
          | FormSuccess True <- byTutRes  = Just <$> countTutRes
          | otherwise                     = Nothing <$ byTutRes
        cfUserId = uid
        cfUserName = uname
      return CorrectorForm{..}

  corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid

  mr <- getMessageRender

  $logDebugS "SCorrR" $ tshow (didDelete, addTutRes)

  let
    corrColonnade = mconcat
      [ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
      , headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
      , headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
      , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
      , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
      ]
    corrResults
      | FormSuccess (Just es) <- addTutRes
      , not $ null es = FormMissing
      | didDelete = FormMissing
      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
                                                  | CorrectorForm{..} <- corrData
                                                  ]
    idField CorrectorForm{..} = do
      cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
      toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]

    delField uid = do
      cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
      toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]

  return ( (,) <$> autoDistributeRes <*> corrResults
         , [ autoDistributeView
           , countTutView
           , FieldView
             { fvLabel = text $ mr MsgCorrectors
             , fvTooltip = Just $ toHtml $ mr MsgCorrectorStateTip
             , fvId = ""
             , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
             , fvErrors = Nothing
             , fvRequired = True
             }
           , addTutView
             { fvInput = [whamlet|
                           <div>
                             ^{fvInput addTutView}
                             <button type=submit formnovalidate data-formnorequired>Hinzufügen
                         |]
             }
           ])

  -- Eingabebox für Korrektor hinzufügen
  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen

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 . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton

  case res of
    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
    FormSuccess (autoDistribute, res') -> runDB $ do
      update shid [ SheetAutoDistribute =. autoDistribute ]
      deleteWhere [SheetCorrectorSheet ==. shid]
      insertMany_ $ Set.toList res'
      addMessageI Success MsgCorrectorsUpdated
    FormMissing -> return ()

  let
    --     formTitle = MsgSheetCorrectorsTitle tid ssh csh shn
    formText  = Nothing :: Maybe (SomeMessage UniWorX)
    actionUrl = CSheetR tid ssh csh shn SCorrR
    -- actionUrl = CSheetR tid ssh csh shn SShowR
  defaultLayout $ do
    setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
    $(widgetFile "formPageI18n")