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

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

import Utils.Lens

import Control.Monad.State as State (StateT)
import Control.Monad.State.Class as State
import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter)
import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST)
import qualified Control.Monad.Random as Rand
import qualified System.Random.Shuffle as Rand (shuffleM)

import Data.Maybe ()

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

import qualified Data.Text as Text

import Data.Monoid (Monoid, Any(..), Sum(..))
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 System.FilePath
import System.FilePath.Glob

import Text.Hamlet (ihamletFile)

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

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) -> case mCorrector of
      Just corrector -> do
        lift $ update subId [ SubmissionRatingBy       =. Just corrector
                            , SubmissionRatingAssigned =. Just now
                            ]
        tell (Set.singleton subId, mempty)
      Nothing ->
        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 =<< fmap (`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
                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 $ (byProportion / proportionSum) * 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 <- 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

      when (not $ 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

    unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a]
    unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp


submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery

submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
                        -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File))
submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
  E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
  return (sf, f)

submissionMultiArchive :: Set SubmissionId -> Handler TypedContent
submissionMultiArchive (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
      return (submission, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm))

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

  setContentDisposition' $ Just "submissions.zip"
  (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
    let
      fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File
      fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do
        cID <- encrypt submissionID

        let
          dirFrag :: PathPiece p => p -> FilePath
          dirFrag = Text.unpack . toPathPiece
          submissionDirectory  = dirFrag (cID :: CryptoFileNameSubmission)
          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
            submissionFileSource submissionID =$= Conduit.map entityVal
            yieldM (ratingFile cID rating)

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

        lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
        lastEditTime <- case lastEditMb of
          [(submissionEditTime.entityVal -> time)] -> return time
          _other -> liftIO getCurrentTime
        yield $ File
          { fileModified = lastEditTime
          , fileTitle = directoryName
          , fileContent = Nothing
          }

        fileEntitySource =$= mapC withinDirectory

    mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder





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

instance Monoid SubmissionSinkState where
  mempty = memptydefault
  mappend = mappenddefault

filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
filterSubmission = do
  $logDebugS "filterSubmission" $ tshow submissionBlacklist
  execWriterLC . awaitForever $ \case
    File{fileTitle}
      | any (`match'` fileTitle) submissionBlacklist -> tell $ Set.singleton fileTitle
    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
                  , MonadCatch m
                  , MonadLogger m
                  ) => ConduitM File SubmissionContent m (Set FilePath)
extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings

extractRatingsMsg :: ( MonadHandler m
                     , HandlerSite m ~ UniWorX
                     , MonadCatch m
                     , MonadLogger m
                     ) => Conduit File m SubmissionContent
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 :: RatingException)
    , 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
    ] . fmap Just


sinkSubmission :: UserId
               -> Either SheetId SubmissionId
               -> Bool -- ^ Is this a correction
               -> Sink SubmissionContent (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{..}
      -- now <- liftIO getCurrentTime
      -- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty
      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 = modify . mappend

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

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

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

        otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
          E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
          -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
          E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work
          return (f, sf)

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

        when anyChanges $ do
          touchSubmission
          when (not $ null collidingFiles) $
            lift $ deleteCascadeWhere [ FileId <-. [ fId | (Entity fId _, _) <- collidingFiles ] ]
          lift $ case () of
            _ | matchesUnderlying
              , isUpdate
                -> return ()
            _   -> do
              fileId <- insert file
              insert_ $ SubmissionFile
                { submissionFileSubmission = submissionId
                , submissionFileFile = fileId
                , submissionFileIsUpdate = isUpdate
                , submissionFileIsDeletion = False
                }
        when undoneDeletion $ do
          touchSubmission
          lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]

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

        unless (submissionId' == submissionId) $ do
          cID <- encrypt submissionId'
          throwM $ ForeignRating cID

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

        submission <- lift $ getJust submissionId

        now <- liftIO getCurrentTime
        let
          rated = submissionRatingBy submission == Just userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files
          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 <$ guard rated -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just 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 $ validateRating sheetType r'

          when (submissionRatingDone submission' && not (submissionRatingDone submission)) $
            tellSt mempty { sinkSubmissionNotifyRating = Any True }
          lift $ replace submissionId submission'
      where
        a /~ b = not $ a ~~ b

        (~~) :: File -> File -> Bool
        (~~) a b
          | isUpdate  = fileTitle a == fileTitle b && fileContent a == fileContent 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 <- gets $ getAny . sinkSubmissionTouched
          when (not alreadyTouched) $ do
            now <- liftIO getCurrentTime
            case isUpdate of
              False -> lift . insert_ $ SubmissionEdit userId now submissionId
              True  -> do
                Submission{submissionRatingTime} <- lift $ getJust submissionId
                when (is _Just submissionRatingTime) $
                  lift $ update submissionId [ SubmissionRatingTime =. Just now ]
            tellSt $ mempty{ sinkSubmissionTouched = Any True }

        finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()
        finalize SubmissionSinkState{..} = do
          missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
            E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
            E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
            when (not isUpdate) $
              E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
            E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
            E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]

            return (f, sf)

          case isUpdate of
            False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ]
            True  -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do
              shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
                E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
                E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
                E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate)
                E.where_ $ f E.^. FileTitle E.==. E.val fileTitle
                return $ f E.^. FileId

              case (shadowing, submissionFileIsUpdate) of
                ([], _) -> deleteCascade fileId
                (E.Value f:_, False) -> do
                  insert_ $ SubmissionFile
                    { submissionFileSubmission = submissionId
                    , submissionFileFile = f
                    , submissionFileIsUpdate = True
                    , submissionFileIsDeletion = True
                    }
                (E.Value f:_, True) -> do
                  update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
                  deleteCascade fileId

          if
            | isUpdate
            , isn't (_Wrapped . _Just) sinkSeenRating
              -> update submissionId
              [ SubmissionRatingTime =. Nothing
              , SubmissionRatingPoints =. Nothing
              , SubmissionRatingComment =. Nothing
              ]
            | isUpdate
            , getAny sinkSubmissionNotifyRating
              -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
            | otherwise -> return ()


sinkMultiSubmission :: UserId
                    -> Bool {-^ Are these corrections -}
                    -> Sink SubmissionContent (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 <- 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
            guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True
          return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
      sink' <- lift $ yield val ++$$ sink
      case sink' of
        Left _ -> error "sinkSubmission returned prematurely"
        Right nSink -> 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@File{..})  -> 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
            tryDecrypt (Text.pack -> ciphertext)
              | Just cID <- fromPathPiece ciphertext = do
                  sId <- decrypt (cID :: CryptoFileNameSubmission)
                  Just sId <$ get404 sId
              | otherwise = return Nothing
          msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
          return (msId, fp)
      (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
      case msId of
        Nothing -> do
          $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileTitle, msId, fileTitle')
        Just sId -> do
          $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle')
          cID <- encrypt sId
          handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
            lift . feed sId $ Left f{ fileTitle = fileTitle' }
  when (not $ 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


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.sub_select . 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'}|]
  , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
  , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
  , drAbort = error "drAbort undefined"
  , drSuccess = error "drSuccess undefined"
  }
