{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}


module Handler.Utils.Submission
  ( AssignSubmissionException(..)
  , assignSubmissions
  , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
  , submissionFileSource, submissionFileQuery
  , submissionMultiArchive 
  , SubmissionSinkException(..)
  , sinkSubmission, sinkMultiSubmission
  , submissionMatchesSheet
  ) where

import Import hiding ((.=), joinPath)
import Prelude (lcm)
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))

import Control.Lens
import Control.Lens.Extras (is)
import Utils.Lens

import Control.Monad.State hiding (forM_, mapM_,foldM)
import Control.Monad.Writer (MonadWriter(..), execWriterT)
import Control.Monad.RWS.Lazy (RWST)
import qualified Control.Monad.Random as Rand
import qualified System.Random.Shuffle as Rand (shuffleM)

import Data.Maybe

import qualified Data.List as List
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.Ratio

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

import Data.Monoid (Monoid, Any(..), Sum(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import Handler.Utils.Rating hiding (extractRatings)
import qualified Handler.Utils.Rating as Rating (extractRatings)
import Handler.Utils.Zip
import Handler.Utils.Sheet
import Handler.Utils.Submission.TH

import qualified Database.Esqueleto as E

import Data.Conduit
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 = NoCorrectorsByProportion
  deriving (Typeable, Show)

instance Exception AssignSubmissionException

-- | Assigns all submissions according to sheet corrector loads
assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
                  -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
                  -> YesodDB UniWorX ( Set SubmissionId -- ^ assigned submissions
                                     , Set SubmissionId -- ^ unassigend submissions (no tutors by load)
                                     )
assignSubmissions sid restriction = do
    Sheet{..} <- getJust sid
    correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
    let
      byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
      corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
      corrsProp  = filter hasPositiveLoad correctors
      countsToLoad' :: UserId -> Bool
      countsToLoad' uid = Map.findWithDefault True uid loadMap
      loadMap :: Map UserId Bool
      loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]

    currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor) -> do
        let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
              -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
              -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
                E.on (tutorial       E.^. TutorialId         E.==. tutorialUser E.^. TutorialUserTutorial)
                E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
                E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
                return $ tutorial E.^. TutorialTutor
        E.on $ tutor E.?. UserId `E.in_` E.justList tutors
        E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
             E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
        return (submission E.^. SubmissionId, tutor)

    let subTutor' :: Map SubmissionId (Set UserId)
        subTutor' = Map.fromListWith Set.union $ currentSubs
          & mapped._2 %~ maybe Set.empty Set.singleton
          & mapped._2 %~ Set.mapMonotonic entityKey
          & mapped._1 %~ E.unValue

    prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
        E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser)
        E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
        let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
              E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial
              E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser
              E.where_ $ tutorial E.^. TutorialTutor E.==. sheetCorrector E.^. SheetCorrectorUser
                   E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission)
        E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse
             E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors)
        return (sheetCorrector, isByTutorial, E.isNothing (submission E.?. SubmissionId))

    let
      prevSubs' :: Map SheetId (Map UserId (Rational, Integer))
      prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do
        (Entity _ sc@SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs
        guard $ maybe True (not isByTutorial ||) byTutorial
        let proportion
              | CorrectorExcused <- sheetCorrectorState = 0
              | otherwise                               = byProportion
        return . Map.singleton sheetCorrectorSheet $ Map.singleton sheetCorrectorUser (proportion, bool 1 0 isPlaceholder)

      deficit :: Map UserId Integer
      deficit = Map.filter (> 0) $ Map.foldr (Map.unionWith (+) . toDeficit) Map.empty prevSubs'

      toDeficit :: Map UserId (Rational, Integer) -> Map UserId Integer
      toDeficit assignments = toDeficit' <$> assignments
        where
          assigned' = getSum $ foldMap (Sum . snd) assignments
          props = getSum $ foldMap (Sum . fst) assignments

          toDeficit' (prop, assigned) = let
              target = round $ fromInteger assigned' * (prop / props)
            in target - assigned

    $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs'
    $logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit

    let
      lcd :: Integer
      lcd = foldr lcm 1 $ map (denominator . byProportion . sheetCorrectorLoad . entityVal) corrsProp
      wholeProps :: Map UserId Integer
      wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ]
      detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit
      detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps
    
    $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue
    
    queue <- liftIO . Rand.evalRandIO . execWriterT $ do
      tell $ map Just detQueue
      forever $
        tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ]

    $logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue)

    let
      assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m ()
      assignSubmission countsToLoad smid tutid = do
        _1 %= Map.insert smid tutid
        _3 . at tutid %= assertM' (> 0) . maybe (-1) pred
        when countsToLoad $
          _2 %= List.delete (Just tutid)

      maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId)
      maximumDeficit = do
        transposed <- uses _3 invertMap 
        traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed)

    subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor'
          
    subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do
      let
        restrictTuts
          | Set.null tuts = id
          | otherwise     = flip Map.restrictKeys tuts
      byDeficit <- withStateT (over _3 restrictTuts) maximumDeficit
      case byDeficit of
        Just q' -> do
          $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)"
          assignSubmission False smid q'
        Nothing 
          | Set.null tuts -> do
              q <- preuse $ _2 . _head . _Just
              case q of
                Just q' -> do
                  $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (queue)"
                  assignSubmission True smid q'
                Nothing -> return ()
          | otherwise -> do
              q <- liftIO . Rand.evalRandIO $ Rand.uniform tuts
              $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)"
              assignSubmission (countsToLoad' q) smid q

    forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
        
    let assignedSubmissions   = Map.keysSet subTutor
        unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
    return (assignedSubmissions, unassigendSubmissions)
    where
      hasPositiveLoad = (> 0)  . byProportion . sheetCorrectorLoad . entityVal
      hasTutorialLoad = isJust . byTutorial   . sheetCorrectorLoad . entityVal


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 <- selectList [ SubmissionId <-. ids ] []
    forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
  
  (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
    let
      fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
      fileEntitySource' (rating, Entity submissionID Submission{..}) = do
        cID <- encrypt submissionID

        let
          directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
              
          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 :: Any
  , sinkSubmissionTouched :: Any
  , sinkFilenames :: Set FilePath
  } deriving (Show, Eq, Generic, Typeable)

instance Monoid SubmissionSinkState where
  mempty = memptydefault
  mappend = mappenddefault

data SubmissionSinkException = DuplicateFileTitle FilePath
                             | DuplicateRating
                             | RatingWithoutUpdate
                             | ForeignRating CryptoFileNameSubmission
  deriving (Typeable, Show)

instance Exception SubmissionSinkException

submissionBlacklist :: [Pattern]
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")

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 ignored :: Set (Either CryptoFileNameSubmission FilePath)
      ignored = Right `Set.map` ignored'
  unless (null ignored) $ do
    mr <- (toHtml . ) <$> getMessageRender
    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)

sinkSubmission :: UserId
               -> Either SheetId SubmissionId
               -> Bool -- ^ Is this a correction
               -> Sink SubmissionContent (YesodDB 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
        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

  sId <$ sinkSubmission' sId isUpdate
  where
    tell = modify . mappend

    sinkSubmission' :: SubmissionId
                    -> Bool -- ^ Is this a correction
                    -> Sink SubmissionContent (YesodDB UniWorX) ()
    sinkSubmission' submissionId isUpdate = 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
        tell $ 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', Rating'{..}) -> do
        $logDebugS "sinkSubmission" $ tshow submissionId'

        unless (submissionId' == submissionId) $ do
          cID <- encrypt submissionId'
          throwM $ ForeignRating cID
        
        alreadySeen <- gets $ getAny . sinkSeenRating
        when alreadySeen $ throwM DuplicateRating
        tell $ mempty{ sinkSeenRating = Any True }

        unless isUpdate $ throwM RatingWithoutUpdate

        Submission{..} <- lift $ getJust submissionId

        let anyChanges = or $ 
              [ submissionRatingPoints /= ratingPoints
              , submissionRatingComment /= ratingComment
              ]
        -- 'ratingTime' is ignored for consistency with 'File's:
        -- 
        -- 'fileModified' is simply stored and never inspected while
        -- 'submissionChanged' is always set to @now@.

        when anyChanges $ do
          touchSubmission
          lift $ update submissionId
            [ SubmissionRatingPoints =. ratingPoints
            , SubmissionRatingComment =. ratingComment
            ]
      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 (YesodDB UniWorX) ()
        touchSubmission = do
          alreadyTouched <- gets $ getAny . sinkSubmissionTouched
          when (not alreadyTouched) $ do
            now <- liftIO getCurrentTime
            lift $ case isUpdate of
              False -> insert_ $ SubmissionEdit userId now submissionId
              True  -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
            tell $ mempty{ sinkSubmissionTouched = Any True }

        finalize :: SubmissionSinkState -> YesodDB 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

          when (isUpdate && not (getAny sinkSeenRating)) $
            update submissionId
              [ SubmissionRatingTime =. Nothing
              , SubmissionRatingPoints =. Nothing
              , SubmissionRatingBy =. Nothing
              , SubmissionRatingComment =. Nothing
              ]

data SubmissionMultiSinkException
  = SubmissionSinkException
    { submissionSinkId :: CryptoFileNameSubmission
    , submissionSinkFedFile :: Maybe FilePath
    , submissionSinkException :: SubmissionSinkException
    }                                   
  deriving (Typeable, Show)

instance Exception SubmissionMultiSinkException

sinkMultiSubmission :: UserId
                    -> Bool {-^ Are these corrections -}
                    -> Sink SubmissionContent (YesodDB 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 (YesodDB UniWorX) SubmissionId))
              (YesodDB 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, ignored) <- 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 ignored) $ do
    mr <- (toHtml .) <$> getMessageRender
    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
  fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
    cID <- encrypt sId
    handle (throwM . SubmissionSinkException cID Nothing) $
      void $ 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