module Handler.Utils.Submission
  ( AssignSubmissionException(..)
  , assignSubmissions, writeSubmissionPlan, planSubmissions
  , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
  , submissionFileSource, submissionFileQuery
  , SubmissionDownloadAnonymous(..)
  , submissionMultiArchive
  , SubmissionSinkException(..)
  , msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
  , sinkSubmission, sinkMultiSubmission
  , submissionMatchesSheet
  , submissionDeleteRoute
  , correctionInvisibleWidget
  ) where

import Import hiding (joinPath)
import Jobs.Queue
import Yesod.Core.Types (HandlerContents(..))

import qualified Control.Monad.State.Class as State
import Control.Monad.Trans.State (execStateT)
import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST)
import qualified Control.Monad.Random as Rand

import Data.Maybe ()

import qualified Data.Set as Set
import Data.Map ((!), (!?))
import qualified Data.Map as Map

import qualified Data.Text as Text

import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import Handler.Utils
import qualified Handler.Utils.Rating as Rating (extractRatings)
import Handler.Utils.Delete

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils.TH as E

import qualified Data.Conduit.List as Conduit
import Data.Conduit.ResumableSink
import qualified Data.Conduit.Combinators as C

import System.FilePath
import System.FilePath.Glob

import Text.Hamlet (ihamletFile)

import qualified Control.Monad.Catch as E (Handler(..))

import qualified Data.CaseInsensitive as CI

import Text.Unidecode (unidecode)
import Data.Char (isAlphaNum)


data AssignSubmissionException = NoCorrectors
                               | NoCorrectorsByProportion
                               | SubmissionsNotFound (NonNull (Set SubmissionId))
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance Exception AssignSubmissionException

-- | Assigns all submissions according to sheet corrector loads
assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors
                  -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
                  -> YesodDB UniWorX ( Set SubmissionId
                                     , Set SubmissionId
                                     ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
assignSubmissions sid restriction = do
    (plan,_) <- planSubmissions sid restriction
    writeSubmissionPlan plan

-- | Assigns all submissions according to an already given assignment plan
writeSubmissionPlan :: Map SubmissionId (Maybe UserId)
                  -- ^ map that assigns submissions to correctors
                  -> YesodDB UniWorX ( Set SubmissionId
                                     , Set SubmissionId
                                     ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
writeSubmissionPlan newSubmissionData = do
    now <- liftIO getCurrentTime
    execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, mCorrector) -> if
      | is _Just mCorrector
        -> do
          lift $ do
            Submission{submissionSheet} <- updateGet subId
              [ SubmissionRatingBy       =. mCorrector
              , SubmissionRatingAssigned =. Just now
              ]
            audit $ TransactionSubmissionEdit subId submissionSheet
          tell (Set.singleton subId, mempty)
      | otherwise
        -> tell (mempty, Set.singleton subId)

-- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet!
--   May throw an exception if there are no suitable correctors
planSubmissions :: SheetId -- ^ Sheet to distribute to correctors
                  -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
                  -> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational)
                  -- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit
planSubmissions sid restriction = do
    Sheet{..} <- getJust sid
    correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
      E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
      E.where_ $ sheetCorrector E.^. SheetCorrectorState `E.in_` E.valList [CorrectorNormal, CorrectorMissing]
      return (sheet E.^. SheetId, sheetCorrector)

    let
      correctors :: Map SheetId (Map UserId (Load, CorrectorState))
      correctors = Map.fromList $ do
        E.Value sheetId <- Set.toList $ setOf (folded . _1) correctorsRaw
        let loads = Map.fromList $ do
              (E.Value sheetId', Entity _ SheetCorrector{..})
                <- correctorsRaw
              guard $ sheetId' == sheetId
              return (sheetCorrectorUser, (sheetCorrectorLoad, sheetCorrectorState))
        return (sheetId, loads)

      sheetCorrectors :: Map UserId Load
      sheetCorrectors = Map.mapMaybe filterLoad $ correctors ! sid
        where
          filterLoad (l@Load{..}, CorrectorNormal) = l <$ guard (isJust byTutorial || byProportion /= 0)
          filterLoad _ = Nothing

    unless (Map.member sid correctors) $
      throwM NoCorrectors

    submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorial `E.InnerJoin` tutorialUser `E.InnerJoin` tutor)) -> do
      E.on $ tutor E.?. TutorTutorial E.==. tutorial E.?. TutorialId
      E.on $ tutorialUser E.?. TutorialParticipantTutorial E.==. tutorial E.?. TutorialId
      E.on $ tutorialUser E.?. TutorialParticipantUser E.==. E.just (submissionUser E.^. SubmissionUserUser)
       E.&&. tutor E.?. TutorUser `E.in_` E.justList (E.valList $ foldMap Map.keys correctors)
       E.&&. tutorial E.?. TutorialCourse E.==. E.just (E.val sheetCourse)
      E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
      E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId

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

      return (sheet E.^. SheetId, submission, tutor E.?. TutorUser)

    let
      -- | All submissions in this course so far
      submissionData :: Map SubmissionId
                          ( Maybe UserId -- Corrector
                          , Map UserId (Sum Natural) -- Tutors
                          , SheetId
                          )
      submissionData = Map.fromListWith merge $ map process submissionDataRaw
        where
          process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) $ assertM isCorrectorByTutorial mTutId, sheetId))
          merge (corrA, tutorsA, sheetA) (corrB, tutorsB, sheetB)
            | corrA /= corrB   = error "Same submission seen with different correctors"
            | sheetA /= sheetB = error "Same submission seen with different sheets"
            | otherwise        = (corrA, Map.unionWith mappend tutorsA tutorsB, sheetA)

          -- Not done in esqueleto, since inspection of `Load`-Values is difficult
          isCorrectorByTutorial = maybe False (\Load{..} -> is _Just byTutorial) . flip Map.lookup sheetCorrectors

      targetSubmissions = Set.fromList $ do
        (E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw
        guard $ sheetId == sid
        case restriction of
          Just restriction' ->
            guard $ subId `Set.member` restriction'
          Nothing ->
            guard $ is _Nothing submissionRatingBy
        return subId

      targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions
      oldSubmissionData    = Map.withoutKeys submissionData targetSubmissions

    whenIsJust (fromNullable . (`Set.difference` targetSubmissions) =<< restriction) $ \missing ->
      throwM $ SubmissionsNotFound missing

    let
      withSubmissionData :: MonadRWS (Map SubmissionId a) w (Map SubmissionId a) m
                         => (Map SubmissionId a -> b)
                         -> m b
      withSubmissionData f = f <$> (mappend <$> ask <*> State.get)

      -- | Old Deficit for protocol purposes, not used here
      oldDeficit :: Map UserId Rational
      oldDeficit = Map.mapWithKey (\k _v -> calculateDeficit k submissionData) sheetCorrectors

      -- | How many additional submission should the given corrector be assigned, if possible?
      calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
      calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet
        where
          sheetSizes :: Map SheetId Integer
          -- ^ Number of assigned submissions (to anyone) per sheet
          sheetSizes = Map.map getSum . Map.fromListWith mappend $ do
            (_, (Just _, _, sheetId)) <- Map.toList submissionState
            return (sheetId, Sum 1)

          deficitBySheet :: Map SheetId Rational
          -- ^ Deficite of @corrector@ per sheet
          deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do
            let assigned :: Rational
                assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState
                proportionSum :: Rational
                proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId
                  where corrProportion (_, CorrectorExcused) = mempty
                        corrProportion (Load{..}, _) = Sum byProportion
                relativeProportion :: Rational -> Rational
                relativeProportion prop
                  | proportionSum == 0 = 0
                  | otherwise = prop / proportionSum
                extra
                  | Just (Load{..}, corrState) <- correctors !? sheetId >>= Map.lookup corrector
                  = sum
                    [ assigned
                    , fromMaybe 0 $ do -- If corrections assigned by tutorial do not count against proportion, substract them from deficit
                        tutCounts <- byTutorial
                        guard $ not tutCounts
                        guard $ corrState /= CorrectorExcused
                        return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState
                    , fromMaybe 0 $ do
                        guard $ corrState /= CorrectorExcused
                        return . negate $ relativeProportion byProportion * fromIntegral sheetSize
                    ]
                  | otherwise
                  = assigned
            return $ negate extra

    -- Sort target submissions by those that have tutors first and otherwise random
    --
    -- Deficit produced by restriction to tutors can thus be fixed by later submissions
    targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions

    (newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, subId) -> do
      tutors <- State.gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural)
      let acceptableCorrectors
            | correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors
            , not $ null correctorsByTut
            = Map.keysSet correctorsByTut
            | otherwise
            = Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors

      unless (null acceptableCorrectors) $ do
        deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit
        let
          bestCorrectors :: Set UserId
          bestCorrectors = acceptableCorrectors
            & maximumsBy (deficits !)
            & maximumsBy (tutors !?)

        $logDebugS "assignSubmissions" [st|#{tshow i} Tutors for #{tshow subId}: #{tshow tutors}|]
        $logDebugS "assignSubmissions" [st|#{tshow i} Current (#{tshow subId}) relevant deficits: #{tshow deficits}|]
        $logDebugS "assignSubmissions" [st|#{tshow i} Assigning #{tshow subId} to one of #{tshow bestCorrectors}|]

        ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)

    return (fmap (view _1) newSubmissionData, oldDeficit)
  where
    maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a
    maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs


submissionFileSource :: SubmissionId -> ConduitT () DBFile (YesodDB UniWorX) ()
submissionFileSource subId = E.selectSource (E.from $ submissionFileQuery subId)
                          .| C.map entityVal
                          .| sourceFiles'

submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile)
                    -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile))
submissionFileQuery submissionID sf = E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
  E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
  E.where_ . E.not_ . E.exists . E.from $ \sf' ->
    E.where_ $ sf' E.^. SubmissionFileIsDeletion
         E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission
         E.&&. sf' E.^. SubmissionFileTitle E.==. sf E.^. SubmissionFileTitle
  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
  return sf

data SubmissionDownloadAnonymous = SubmissionDownloadAnonymous
                                 | SubmissionDownloadSurnames
                                 | SubmissionDownloadMatriculations
                                 | SubmissionDownloadGroups
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''SubmissionDownloadAnonymous $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''SubmissionDownloadAnonymous id
makePrisms ''SubmissionDownloadAnonymous

submissionMultiArchive :: SubmissionDownloadAnonymous -> Set SubmissionId -> Handler TypedContent
submissionMultiArchive anonymous (Set.toList -> ids) = do
  (dbrunner, cleanup) <- getDBRunner

  ratedSubmissions <- runDBRunner dbrunner $ do
    submissions <- E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
      E.on $ sheet E.^. SheetId     E.==. submission E.^. SubmissionSheet
      E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
      E.where_ $ submission E.^. SubmissionId `E.in_` E.valList ids
      let subTime = E.subSelectMaybe . E.from $ \submissionEdit -> do
            E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
            return . E.max_ $ submissionEdit E.^. SubmissionEditTime
      return (submission, subTime, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm, sheet E.^. SheetAnonymousCorrection))

    forM submissions $ \(s@(Entity submissionId _), E.Value sTime, courseSheetInfo) ->
       maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, sTime, $(E.unValueN 5) courseSheetInfo)) =<< getRating submissionId
  let (setSheet,setCourse,setSchool,setTerm) =
        execWriter . forM ratedSubmissions $ \(_rating,_submission,_subTime,(shn,csh,ssh,tid,_anon)) ->
          tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid)

  let
    archiveName = case (Set.toList setTerm, Set.toList setSchool, Set.toList setCourse, Set.toList setSheet) of
      ([tid], [ssh], [csh], [shn])
        ->  MsgSubmissionTermSchoolCourseSheetArchiveName tid ssh csh shn
      ([tid], [ssh], [csh], _)
        -> MsgSubmissionTermSchoolCourseArchiveName tid ssh csh
      ([tid], [ssh], _, _)
        ->  MsgSubmissionTermSchoolArchiveName tid ssh
      ([tid], _, _, _)
        -> MsgSubmissionTermArchiveName tid
      _other
        -> MsgSubmissionArchiveName
  MsgRenderer mr <- getMsgRenderer
  setContentDisposition' $ Just ((addExtension `on` unpack) (mr archiveName) extensionZip)
  respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do
    let
      fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () DBFile (YesodDB UniWorX) ()
      fileEntitySource' (rating, Entity submissionID Submission{}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
        cID <- encrypt submissionID

        let
          dirFrag :: PathPiece p => p -> FilePath
          dirFrag = Text.unpack . toPathPiece

          userFeature :: SubmissionDownloadAnonymous ->  Maybe (E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe Text)))
          userFeature SubmissionDownloadSurnames = Just $ E.just . (E.^. UserSurname)
          userFeature SubmissionDownloadMatriculations = Just $ E.castString . (E.^. UserMatrikelnummer)
          userFeature _ = Nothing

          withNames fp
            | is _SubmissionDownloadGroups anonymous = do
                groups <- lift . E.select . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do
                  E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
                  E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
                  E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID
                  E.where_ $ E.subSelectForeign submissionUser SubmissionUserSubmission (\submission -> E.subSelectForeign submission SubmissionSheet (E.^. SheetGrouping)) E.==. E.val RegisteredGroups
                  E.where_ . E.exists . E.from $ \(submission `E.InnerJoin` sheet) -> do
                    E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
                    E.where_ $ submission E.^. SubmissionId E.==. E.val submissionID
                    E.where_ $ sheet E.^. SheetCourse E.==. submissionGroup E.^. SubmissionGroupCourse
                  return $ submissionGroup E.^. SubmissionGroupName
                let asciiGroups = nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups
                return . intercalate "_" $ asciiGroups `snoc` fp
            | Just feature <- userFeature anonymous
            = do
                features <- lift . E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
                  E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
                  E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID
                  return $ feature user
                let asciiFeatures = sort $ mapMaybe (fmap (filter isAlphaNum . foldMap unidecode . unpack) . E.unValue) features
                return . intercalate "_" $ asciiFeatures `snoc` fp
            | otherwise = return fp

        notAnonymized' <- and2M
          (return $ isn't _SubmissionDownloadAnonymous anonymous)
          (or2M (return $ not sheetAnonymous) (lift . hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR))

        submissionDirectory <- bool return withNames notAnonymized' $ dirFrag (cID :: CryptoFileNameSubmission)

        let
          directoryName
            | Set.size setTerm   > 1 = dirFrag tid </> dirFrag ssh </> dirFrag csh </> dirFrag shn </> submissionDirectory
            | Set.size setSchool > 1 =                 dirFrag ssh </> dirFrag csh </> dirFrag shn </> submissionDirectory
            | Set.size setCourse > 1 =                                 dirFrag csh </> dirFrag shn </> submissionDirectory
            | Set.size setSheet  > 1 =                                                 dirFrag shn </> submissionDirectory
            | otherwise              =                                                                 submissionDirectory

          fileEntitySource = do
            yieldM $ ratingFile cID rating
            submissionFileSource submissionID

          withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }

        fileModified <- maybe (liftIO getCurrentTime) return subTime
        yield $ File
          { fileModified
          , fileTitle = directoryName
          , fileContent = Nothing
          }

        fileEntitySource .| mapC withinDirectory

    mapM_ fileEntitySource' ratedSubmissions .| produceZip def .| Conduit.map toFlushBuilder





data SubmissionSinkState = SubmissionSinkState
  { sinkSeenRating :: Last Rating'
  , sinkSubmissionTouched :: Any
  , sinkFilenames :: Set FilePath
  } deriving (Show, Eq, Generic, Typeable)

instance Semigroup SubmissionSinkState where
  (<>) = mappenddefault

instance Monoid SubmissionSinkState where
  mempty = memptydefault
  mappend = (<>)

filterSubmission :: MonadLogger m => ConduitM FileReference FileReference m (Set FilePath)
-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
filterSubmission = do
  $logDebugS "filterSubmission" $ tshow submissionBlacklist
  execWriterLC . awaitForever $ \case
    FileReference{fileReferenceTitle}
      | any (`match'` fileReferenceTitle) submissionBlacklist -> tell $ Set.singleton fileReferenceTitle
    file -> yield file
  where
    match' = matchWith $ matchDefault
      { matchDotsImplicitly = True -- Special treatment for . makes no sense since we're multiplatform
      }

extractRatings :: ( MonadHandler m
                  , HandlerSite m ~ UniWorX
                  ) => ConduitM FileReference SubmissionContent m (Set FilePath)
extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings

extractRatingsMsg :: ( MonadHandler m
                     , HandlerSite m ~ UniWorX
                     ) => ConduitT FileReference SubmissionContent m ()
extractRatingsMsg = do
  ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
  let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
      ignoredFiles = Right `Set.map` ignored'
  unless (null ignoredFiles) $ do
    let ignoredModal = msgModal
          [whamlet|_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}|]
          (Right $(widgetFile "messages/submissionFilesIgnored"))
    addMessageWidget Warning ignoredModal

-- | Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
msgSubmissionErrors = flip catches
    [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException)
    , E.Handler $ \(SubmissionSinkException sinkId _ sinkEx) -> do
        mr <- getMessageRender
        addMessageI Error $ MsgMultiSinkException (toPathPiece sinkId) (mr sinkEx)
        return Nothing
    , E.Handler $ \e -> (Nothing <$) . addMessageWidget Error $ case e of
        RatingFileException{..}
          -> [whamlet|
               $newline never
               _{MsgRatingFileException ratingExceptionFile}
               <br>
               ^{ratingExceptionWidget ratingException}
             |]
        RatingSubmissionException{..}
          -> [whamlet|
               $newline never
               _{MsgRatingSubmissionException ratingExceptionSubmission}
               <br>
               ^{ratingExceptionWidget ratingException}
             |]
    ] . fmap Just
  where
    ratingExceptionWidget = \case
      RatingFileIsDirectory -> i18n MsgRatingFileIsDirectory
      RatingSubmissionIDIncorrect -> i18n MsgRatingSubmissionIDIncorrect
      RatingValidityException exc -> i18n exc
      RatingParseException pExc
        -> [whamlet|
             $newline never
             _{MsgRatingParseException}
             <br>
             $case pExc
               $of RatingYAMLStreamTerminatedUnexpectedly
                 _{MsgRatingYAMLStreamTerminatedUnexpectedly}
               $of RatingYAMLDocumentEndIllDefined
                 _{MsgRatingYAMLDocumentEndIllDefined}
               $of RatingYAMLExceptionBeforeComment errStr
                 _{MsgRatingYAMLExceptionBeforeComment}
                 <br>
                 <code .literal-error>
                   #{errStr}
               $of RatingYAMLException errStr
                 _{MsgRatingYAMLException}
                 <br>
                 <code .literal-error>
                   #{errStr}
               $of RatingYAMLCommentNotUnicode unicodeErr
                 _{MsgRatingYAMLCommentNotUnicode}
                 <br>
                 <code .literal-error>
                   #{tshow unicodeErr}
               $of RatingYAMLNotUnicode unicodeErr
                 _{MsgRatingYAMLNotUnicode}
                 <br>
                 <code .literal-error>
                   #{unicodeErr}
           |]
      RatingParseLegacyException pExc
        -> [whamlet|
             $newline never
             _{MsgRatingParseLegacyException}
             <br>
             $case pExc
               $of RatingMissingSeparator
                 _{MsgRatingMissingSeparator}
               $of RatingMultiple
                 _{MsgRatingMultiple}
               $of RatingInvalid errStr
                 _{MsgRatingInvalid}
                 <br>
                 <code .literal-error>
                   #{errStr}
               $of RatingNotUnicode unicodeErr
                 _{MsgRatingNotUnicode}
                 <br>
                 <code .literal-error>
                   #{tshow unicodeErr}
           |]


sinkSubmission :: Maybe UserId
               -> Either SheetId SubmissionId
               -> Bool -- ^ Is this a correction
               -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) SubmissionId
-- ^ Replace the currently saved files for the given submission (either
--   corrected files or original ones, depending on arguments) with the supplied
--   'SubmissionContent'.
--
-- Files that don't occur in the 'SubmissionContent' but are in the database
-- are deleted (or marked as deleted in the case of this being a correction).
--
-- A 'Submission' is created if no 'SubmissionId' is supplied
sinkSubmission userId mExists isUpdate = do
  sId <- lift $ case mExists of
    Left sheetId -> do
      let
        submissionSheet          = sheetId
        submissionRatingPoints   = Nothing
        submissionRatingComment  = Nothing
        submissionRatingBy       = Nothing
        submissionRatingAssigned = Nothing
        submissionRatingTime     = Nothing

      sId <- insert Submission{..}
      audit $ TransactionSubmissionEdit sId sheetId
      return sId
    Right sId -> return sId

  Sheet{..} <- lift $ case mExists of
    Left sheetId -> getJust sheetId
    Right subId  -> getJust . submissionSheet =<< getJust subId

  sId <$ (guardFileTitles sheetSubmissionMode .| sinkSubmission' sId)
  where
    tellSt = State.modify . mappend

    guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m ()
    guardFileTitles SubmissionMode{..}
      | Just UploadAny{..} <- submissionModeUser
      , not isUpdate
      , Just (map unpack . Set.toList . toNullable -> exts) <- uploadExtensionRestriction
      = Conduit.mapM $ \x -> if
          | Left FileReference{..} <- x
          , none ((flip isExtensionOf `on` CI.foldCase) fileReferenceTitle) exts
          , isn't _Nothing fileReferenceContent -- File record is not a directory, we don't care about those
            -> throwM $ InvalidFileTitleExtension fileReferenceTitle
          | otherwise
            -> return x
      | otherwise = Conduit.map id

    sinkSubmission' :: SubmissionId
                    -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
    sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
      Left file@FileReference{..} -> do
        $logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)

        alreadySeen <- State.gets (Set.member fileReferenceTitle . sinkFilenames)
        when alreadySeen . throwM $ DuplicateFileTitle fileReferenceTitle
        tellSt $ mempty{ sinkFilenames = Set.singleton fileReferenceTitle  }

        otherVersions <- lift . E.select . E.from $ \sf -> do
          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
          -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
          E.where_ $ sf E.^. SubmissionFileTitle E.==. E.val fileReferenceTitle -- 'Zip.hs' normalises filenames already, so this should work
          return sf

        let collidingFiles = [ t | t@(Entity _ sf) <- otherVersions
                                 , submissionFileIsUpdate sf == isUpdate
                                 ]
            underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
                                  , not (submissionFileIsUpdate sf)
                                  ]
            anyChanges
              | not (null collidingFiles)  = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
              | otherwise                  = True
            matchesUnderlying
              | not (null underlyingFiles) = all (~~ file) [ view (_FileReference . _1) sf | Entity _ sf <- underlyingFiles ]
              | otherwise                  = False
            undoneDeletion = any submissionFileIsDeletion [ sf | Entity _ sf <- collidingFiles ]

        when anyChanges $ do
          touchSubmission
          forM_ collidingFiles $ \sfEnt@(Entity sfId' _) -> lift $ do
            delete sfId'
            audit $ TransactionSubmissionFileDelete sfEnt
          lift $ if
            | matchesUnderlying
            , isUpdate
              -> return ()
            | otherwise -> do
                subFile <- insertEntity $
                  _FileReference # ( file
                                   , SubmissionFileResidual
                                     { submissionFileResidualSubmission = submissionId
                                     , submissionFileResidualIsUpdate = isUpdate
                                     , submissionFileResidualIsDeletion = False
                                     }
                                   )
                audit $ TransactionSubmissionFileEdit subFile
        when undoneDeletion $ do
          touchSubmission
          forM_ (filter (submissionFileIsDeletion . entityVal) collidingFiles) $ \sfEnt@(Entity sfId' _) -> lift $ do
            delete sfId'
            audit $ TransactionSubmissionFileDelete sfEnt

      Right (submissionId', r) -> do
        $logDebugS "sinkSubmission" $ tshow submissionId'
        cID <- encrypt submissionId'

        unless (submissionId' == submissionId) $
          throwM $ ForeignRating cID

        alreadySeen <- State.gets $ is (_Wrapped . _Just) . sinkSeenRating
        when alreadySeen $ throwM DuplicateRating

        submission <- lift $ getJust submissionId

        now <- liftIO getCurrentTime
        let rated = ratingDone r
        let
          r'@Rating'{..} = r
            { ratingTime = now <$ guard rated -- Ignore `ratingTime` from result @r@ of `parseRating` to ensure plausible timestamps (`parseRating` returns file modification time for consistency with `ratingFile`)
            }
          submission' = submission
            { submissionRatingPoints  = ratingPoints
            , submissionRatingComment = ratingComment
            , submissionRatingTime    = ratingTime
            , submissionRatingBy      = userId
            }
        tellSt $ mempty{ sinkSeenRating = Last $ Just r' }

        unless isUpdate $ throwM RatingWithoutUpdate

        -- 'ratingTime' is ignored for consistency with 'File's:
        --
        -- 'fileModified' is simply stored and never inspected while
        -- 'submissionChanged' is always set to @now@.
        let anyChanges = any (\f -> f submission submission')
              [ (/=) `on` submissionRatingPoints
              , (/=) `on` submissionRatingComment
              , (/=) `on` submissionRatingDone
              , (/=) `on` submissionRatingBy
              ]

        when anyChanges $ do
          touchSubmission

          Sheet{..} <- lift . getJust $ submissionSheet submission'

          mapM_ (throwM . RatingSubmissionException cID . RatingValidityException) $ validateRating sheetType r'

          lift $ replace submissionId submission'
          sheetId <- lift getSheetId
          lift $ audit $ TransactionSubmissionEdit submissionId sheetId
      where
        a /~ b = not $ a ~~ b

        (~~) :: FileReference -> FileReference -> Bool
        (~~) a b
          | isUpdate  = fileReferenceTitle   a == fileReferenceTitle   b
                     && fileReferenceContent a == fileReferenceContent b
          | otherwise = a == b
        -- The Eq Instance for File compares modification time exactly even
        -- though zip archives have very limited accuracy and range regarding
        -- timestamps.
        -- We thus expect to replace files a little more often than is actually
        -- necessary.
        -- This was done on the premise that changes in file modification time
        -- break file identity under upload and re-download.
        --
        -- The check whether the new version matches the underlying file is
        -- more lenient, considering only filename and -content.

        touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
        touchSubmission = do
          alreadyTouched <- State.gets $ getAny . sinkSubmissionTouched
          unless alreadyTouched $ do
            now <- liftIO getCurrentTime
            if
              | isUpdate -> do
                  Submission{submissionRatingTime} <- lift $ getJust submissionId
                  when (is _Just submissionRatingTime) $
                    lift $ update submissionId [ SubmissionRatingTime =. Just now ]
              | otherwise -> lift . insert_ $ SubmissionEdit userId now submissionId
            tellSt $ mempty{ sinkSubmissionTouched = Any True }

        getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId
        getSheetId = case mExists of
          Left shid
            -> return shid
          Right _
            -> submissionSheet <$> getJust submissionId  -- there must have been a submission, otherwise mExists would have been Left shid

        finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()
        finalize sState = do
          SubmissionSinkState{..} <- flip execStateT sState $
            when (is _Left mExists)
              touchSubmission
          
          missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
            E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
            unless isUpdate $
              E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
            E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
            E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]

            return sf

          if
            | isUpdate -> forM_ missingFiles $ \sfEnt@(Entity sfId SubmissionFile{..}) -> do
                shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False

                if
                  | not shadowing -> do
                      delete sfId
                      audit $ TransactionSubmissionFileDelete sfEnt
                  | submissionFileIsUpdate -> do
                      sfRec <- updateGet sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
                      audit . TransactionSubmissionFileEdit $ Entity sfId sfRec
                  | otherwise -> do
                      now <- liftIO getCurrentTime
                      sfEnt' <- insertEntity $ SubmissionFile
                        { submissionFileSubmission = submissionId
                        , submissionFileTitle
                        , submissionFileModified = now
                        , submissionFileContent = Nothing
                        , submissionFileIsUpdate = True
                        , submissionFileIsDeletion = True
                        }
                      audit $ TransactionSubmissionFileEdit sfEnt'
            | otherwise -> do
              shadowed <- selectList
                [ SubmissionFileSubmission ==. submissionId
                , SubmissionFileIsUpdate ==. False
                , SubmissionFileId <-. map entityKey missingFiles
                ] []
              forM_ shadowed $ \sfEnt'@(Entity sfId' _) -> do
                delete sfId'
                audit $ TransactionSubmissionFileDelete sfEnt'

          if
            | isUpdate
            , isn't (_Wrapped . _Just) sinkSeenRating
              -> do
                update submissionId [ SubmissionRatingTime =. Nothing, SubmissionRatingPoints =. Nothing, SubmissionRatingComment =. Nothing]
                sheetId <- getSheetId
                audit $ TransactionSubmissionEdit submissionId sheetId
            | not isUpdate
            , getAny sinkSubmissionTouched
            , is _Right mExists
              -> do
                uid <- requireAuthId
                queueDBJob . JobQueueNotification $ NotificationSubmissionEdited uid submissionId
            | otherwise -> return ()


sinkMultiSubmission :: UserId
                    -> Bool {-^ Are these corrections -}
                    -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) (Set SubmissionId)

-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
--
-- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction).
--
-- In contrast to `sinkSubmission` this function does authorization-checks against `CorrectionR`
sinkMultiSubmission userId isUpdate = do
  let
    feed :: SubmissionId
         -> SubmissionContent
         -> RWST
              ()
              _
              (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId))
              (YesodJobDB UniWorX)
              ()
    feed sId val = do
      mSink <- State.gets $ Map.lookup sId
      sink <- case mSink of
        Just sink -> return sink
        Nothing -> do
          lift $ do
            cID <- encrypt sId
            $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID
            Submission{..} <- get404 sId
            Sheet{..} <- get404 submissionSheet
            Course{..} <- get404 sheetCourse
            hoist lift $ guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True
          return . newResumableSink $ sinkSubmission (Just userId) (Right sId) isUpdate
      sink' <- lift $ yield val ++$$ sink
      case sink' of
        Left _ -> error "sinkSubmission returned prematurely"
        Right nSink -> State.modify $ Map.insert sId nSink
  (sinks, ignoredFiles) <- execRWSLC () Map.empty . awaitForever $ \case
    v@(Right (sId, _)) -> do
      cID <- encrypt sId
      $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
      lift (feed sId v `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ])
    (Left f@FileReference{..})  -> do
      let
        acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath])
        acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
        acc (Nothing , fp) segment = do
          let
            segments' = filter (not . Text.null) . Text.split (flip Set.notMember cryptoIdChars . CI.mk) $ Text.pack segment
            tryDecrypt ciphertext
              | Just cID <- fromPathPiece ciphertext = do
                  sId <- decrypt (cID :: CryptoFileNameSubmission)
                  Just sId <$ get404 sId
              | otherwise = return Nothing
          Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ]
          return (msId, fp)
      (msId, joinPath -> fileTitle') <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
      case msId of
        Nothing -> do
          $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
        Just sId -> do
          $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
          cID <- encrypt sId
          lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
            feed sId $ Left f{ fileReferenceTitle = fileTitle' }
  unless (null ignoredFiles) $ do
    mr <- (toHtml .) <$> getMessageRender
    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
  lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
    cID <- encrypt sId
    handle (throwM . SubmissionSinkException cID Nothing) $
      closeResumableSink sink
  where
    handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
    handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)
    handleHCError _ e = throwM e
    handleCryptoID :: CryptoIDError -> _ (Maybe a)
    handleCryptoID _ = return Nothing

    cryptoIdChars :: Set (CI Char)
    cryptoIdChars = Set.fromList . map CI.mk $ "uwa" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"


submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
submissionMatchesSheet tid ssh csh shn cid = do
  sid <- decrypt cid
  shid <- fetchSheetId tid ssh csh shn
  Submission{..} <- get404 sid
  when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
  return sid


submissionDeleteRoute :: Set SubmissionId -> DeleteRoute Submission
submissionDeleteRoute drRecords = DeleteRoute
  { drRecords
  , drUnjoin = \(submission `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> submission
  , drGetInfo = \(submission `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
      E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
      E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
      E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
      let lastEdit = E.subSelectMaybe . E.from $ \submissionEdit -> do
            E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
            return . E.max_ $ submissionEdit E.^. SubmissionEditTime
      E.orderBy [E.desc lastEdit]
      return (submission E.^. SubmissionId, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
  , drRenderRecord = \(E.Value subId', E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') -> do
      subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
      subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser
      return [whamlet|
        $newline never
        <ul .list--comma-separated .list--inline .list--iconless>
          $forall (dName, sName) <- subNames
            <li>^{nameWidget dName sName}
        &nbsp;(_{ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName}, #{shn'})
      |]
  , drRecordConfirmString = \(E.Value subId', E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') -> do
      subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
      subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
      let subNames' = Text.intercalate ", " subNames
      return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}/#{subNames'}|]
  , drFormMessage = \infos -> do
      let
        coSubWarning (E.Value subId, _, _, _, _, _, _) = do
          uid <- maybeAuthId
          subUsers <- selectList [SubmissionUserSubmission ==. subId] []
          if
            | not $ null subUsers
            , maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
              -> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
            | otherwise
              -> return Nothing

      coSubWarning' <- foldMapM (fmap First . coSubWarning) infos

      return $ getFirst coSubWarning'
  , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
  , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
  , drAbort = error "drAbort undefined"
  , drSuccess = error "drSuccess undefined"
  , drDelete = \subId del -> do
      Submission{..} <- getJust subId
      subUsers <- setOf (folded . _entityVal . _submissionUserUser) <$> selectList [SubmissionUserSubmission ==. subId] []
      audit $ TransactionSubmissionDelete subId submissionSheet

      uid <- requireAuthId
      forM_ (Set.delete uid subUsers) $ \subUid ->
        queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid submissionSheet subId

      del
  }

  
data CorrectionInvisibleReason
  = CorrectionInvisibleExamUnfinished
  | CorrectionInvisibleRatingNotDone
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)
embedRenderMessage ''UniWorX ''CorrectionInvisibleReason id

correctionInvisibleWidget :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission
                          -> Entity Submission
                          -> DB (Maybe Widget)
correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ do
  submittors <- lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \submissionUser -> do
    E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
    return $ submissionUser E.^. SubmissionUserUser

  corrVisible <- lift . allM submittors $ \bId -> is _Authorized <$> evalAccessFor (Just bId) (CSubmissionR tid ssh csh shn cID CorrectionR) False
  guard $ not corrVisible

  reasons <- lift . mapReaderT execWriterT $ do
    unless (submissionRatingDone sub) $
      tellPoint @(Set _) CorrectionInvisibleRatingNotDone
    maybeT_ $ do
      Sheet{..} <- MaybeT . get $ submissionSheet sub
      epId <- hoistMaybe $ sheetType ^? _examPart . from _SqlKey
      ExamPart{examPartExam} <- MaybeT $ get epId
      Exam{..} <- MaybeT $ get examPartExam
      now <- liftIO getCurrentTime
      unless (NTop (Just now) >= NTop examFinished) $
        tellPoint CorrectionInvisibleExamUnfinished

  return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible")