Implement submission blacklist

Fixes #130

config/submission-blacklist

@@ -0,0 +1,12 @@
+$# Syntax:
+$#   - Leere zeilen werden ignoriert
+$#   - Zeilen, die mit '$#' beginnen, werden ignoriert
+$#   - Verbleibende Zeilen werden jeweils als `Glob`-Pattern kompiliert
+
+$# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt
+**/__MACOSX
+**/__MACOSX/*
+**/__MACOSX/**/*
+
+$# Ignoriere rekursiv alle Dateien .DS_Store
+**/.DS_Store

messages/de.msg

@@ -221,3 +221,5 @@ AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC ko
 LastEdits: Letzte Änderungen
 EditedBy name@Text time@Text: Durch #{name} um #{time}
 LastEdit: Letzte Änderung
+
+SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:

package.yaml

@@ -87,6 +87,7 @@ dependencies:
 - system-locale
 - th-lift-instances
 - gitrev
+- Glob
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Handler/Corrections.hs

@@ -403,7 +403,7 @@ postCorrectionR tid csh shn cid = do
         FormSuccess fileSource -> do
           uid <- requireAuthId
           
-          runDB . runConduit $ transPipe lift fileSource .| extractRatings .| sinkSubmission uid (Right sub) True
+          runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
 
           addMessageI "success" MsgRatingFilesUpdated
           redirect $ CSubmissionR tid csh shn cid CorrectionR
@@ -438,7 +438,7 @@ postCorrectionsUploadR = do
     FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
     FormSuccess files -> do
       uid <- requireAuthId
-      subs <- runDB . runConduit $ transPipe lift files .| extractRatings .| sinkMultiSubmission uid True
+      subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
       subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
       mr <- (toHtml .) <$> getMessageRender
       addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)

src/Handler/Submission.hs

@@ -220,7 +220,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
             (Nothing, Just smid)   -- no new files, existing submission partners updated
               -> return smid
             (Just files, _)  -- new files
-              -> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission uid (maybe (Left shid) Right msmid) False
+              -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
             _ -> error "Impossible, because of definition of `makeSubmissionForm`"
           -- Determine members of pre-registered group
           groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do

src/Handler/Utils.hs

@@ -17,7 +17,7 @@ import Handler.Utils.Table as Handler.Utils
 import Handler.Utils.Table.Pagination as Handler.Utils
 
 import Handler.Utils.Zip        as Handler.Utils
-import Handler.Utils.Rating     as Handler.Utils
+import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
 import Handler.Utils.Templates  as Handler.Utils

src/Handler/Utils/Submission.hs

@@ -15,6 +15,7 @@
 module Handler.Utils.Submission
   ( AssignSubmissionException(..)
   , assignSubmissions
+  , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
   , submissionFileSource, submissionFileQuery
   , submissionMultiArchive 
   , SubmissionSinkException(..)
@@ -29,6 +30,7 @@ import Control.Lens.Extras (is)
 import Utils.Lens
 
 import Control.Monad.State hiding (forM_, mapM_,foldM)
+import Control.Monad.Writer (MonadWriter(..))
 import qualified Control.Monad.Random as Rand
 
 import Data.Maybe
@@ -45,16 +47,22 @@ import qualified Data.CaseInsensitive as CI
 import Data.Monoid (Monoid, Any(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
-import Handler.Utils.Rating
+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)
 
 
 data AssignSubmissionException = NoCorrectorsByProportion
@@ -191,6 +199,39 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
 
 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
+  mr <- (toHtml . ) <$> getMessageRender
+  addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId
                -> Bool -- ^ Is this a correction
@@ -228,7 +269,7 @@ sinkSubmission userId mExists isUpdate = do
     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  }

src/Handler/Utils/Submission/TH.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , ViewPatterns
+           , OverloadedStrings
+           , StandaloneDeriving
+           , DeriveLift
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Utils.Submission.TH
+  ( patternFile
+  ) where
+
+import ClassyPrelude.Yesod
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
+
+import System.FilePath.Glob
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+
+deriving instance Lift CompOptions
+
+-- $(patternFile compDefault file) :: [System.FilePath.Glob.Pattern]
+patternFile :: CompOptions -> FilePath -> ExpQ
+patternFile opts file = do
+  qAddDependentFile file
+  patternStrings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
+  listE $ map (\(Text.unpack -> pat) -> [|compileWith opts pat|]) patternStrings
+
+isComment :: Text -> Bool
+isComment line = or
+  [ commentSymbol `Text.isPrefixOf` Text.stripStart line
+  , Text.null $ Text.strip line
+  ]
+  where
+    commentSymbol = "$#"

templates/messages/submissionFilesIgnored.hamlet

@@ -0,0 +1,4 @@
+_{MsgSubmissionFilesIgnored}
+<ul style="font-family: monospace">
+  $forall fileTitle <- ignored
+    <li>#{fileTitle}