Overhaul SubmissonMode extensively

config/archive-types

@@ -0,0 +1,40 @@
+# Simple list of mime-types corresponding to archive-formats
+#
+# Comments are empty lines and any line for which the first non-whitespace symbol is ‘#’
+#
+# Format is a single mime-type per line (may not contain whitespace)
+#
+# Largely copied from https://en.wikipedia.org/wiki/List_of_archive_formats
+
+application/x-archive 
+application/x-cpio
+application/x-bcpio
+application/x-shar
+application/x-iso9660-image 
+application/x-sbx
+application/x-tar
+application/x-7z-compressed 
+application/x-ace-compressed
+application/x-astrotite-afa 
+application/x-alz-compressed
+application/vnd.android.package-archive 
+application/x-arj 
+application/x-b1 
+application/vnd.ms-cab-compressed 
+application/x-cfs-compressed 
+application/x-dar 
+application/x-dgc-compressed 
+application/x-apple-diskimage 
+application/x-gca-compressed 
+application/java-archive 
+application/x-lzh 
+application/x-lzx 
+application/x-rar-compressed 
+application/x-stuffit 
+application/x-stuffitx 
+application/x-gtar 
+application/x-ms-wim 
+application/x-xar 
+application/zip 
+application/x-zoo 
+application/x-par2 

messages/uniworx/de.msg

@@ -445,6 +445,7 @@ SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file}
 SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.
 SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich.
 SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen!
+SubmissionSinkExceptionInvalidFileTitleExtension file@FilePath: Dateiname #{show file} hat keine der für dieses Übungsblatt zulässigen Dateiendungen.
 
 MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error}
 
@@ -488,7 +489,7 @@ LastEdit: Letzte Änderung
 LastEditByUser: Ihre letzte Bearbeitung
 NoEditByUser: Nicht von Ihnen bearbeitet
 
-SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
+SubmissionFilesIgnored n@Int: Es #{pluralDE n "wurde" "wurden"} #{tshow n} #{pluralDE n "Datei" "Dateien"} in der hochgeladenen Abgabe ignoriert
 SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
 
 LDAPLoginTitle: Campus-Login
@@ -507,8 +508,22 @@ DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszei
 DayIsOutOfTerm    tid@TermId date@Text: #{date} liegt nicht im #{display tid}
 
 UploadModeNone: Kein Upload
-UploadModeUnpack: Upload, einzelne Datei
+UploadModeAny: Upload, beliebige Datei(en)
-UploadModeNoUnpack: Upload, ZIP-Archive entpacken
+UploadModeSpecific: Upload, vorgegebene Dateinamen
+
+UploadModeUnpackZips: Abgabe mehrerer Dateien
+UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden auch unterstützte Archiv-Formate zugelassen. Diese werden nach dann beim Hochladen automatisch entpackt.
+
+UploadModeExtensionRestriction: Zulässige Dateiendungen
+UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
+
+UploadSpecificFiles: Vorgegebene Dateinamen
+NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden.
+UploadSpecificFilesDuplicateNames: Vorgegebene Dateinamen müssen eindeutig sein
+UploadSpecificFilesDuplicateLabels: Bezeichner für vorgegebene Dateinamen müssen eindeutig sein
+UploadSpecificFileLabel: Bezeichnung
+UploadSpecificFileName: Dateiname
+UploadSpecificFileRequired: Zur Abgabe erforderlich
 
 NoSubmissions: Keine Abgabe
 CorrectorSubmissions: Abgabe extern mit Pseudonym

routes

@@ -104,11 +104,11 @@
     !/subs/new                  SubmissionNewR GET POST        !timeANDcourse-registeredANDuser-submissions
     !/subs/own                  SubmissionOwnR GET             !free -- just redirect
     /subs/#CryptoFileNameSubmission SubmissionR:
-      /                         SubShowR       GET POST        !ownerANDtime !ownerANDread !correctorANDread
+      /                         SubShowR       GET POST        !ownerANDtimeANDuser-submissions !ownerANDread !correctorANDread
-      /delete                   SubDelR        GET POST        !ownerANDtime
+      /delete                   SubDelR        GET POST        !ownerANDtimeANDuser-submissions
       /assign                   SAssignR       GET POST        !lecturerANDtime
       /correction               CorrectionR    GET POST        !corrector !ownerANDreadANDrated
-      /invite                   SInviteR       GET POST        !ownerANDtime
+      /invite                   SInviteR       GET POST        !ownerANDtimeANDuser-submissions
       !/#SubmissionFileType     SubArchiveR    GET             !owner !corrector
       !/#SubmissionFileType/*FilePath SubDownloadR  GET        !owner !corrector
     /correctors                 SCorrR         GET POST

src/Foundation.hs

@@ -280,18 +280,12 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr
         verbMap [_, _, v] = v <> "Submissions"
         verbMap _ = error "Invalid number of verbs"
      in verbMap . splitCamel
+embedRenderMessage ''UniWorX ''UploadModeDescr id
+embedRenderMessage ''UniWorX ''SecretJSONFieldException id
 
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
 
-instance RenderMessage UniWorX UploadMode where
-  renderMessage foundation ls uploadMode = case uploadMode of
-    NoUpload     -> mr MsgUploadModeNone
-    Upload False -> mr MsgUploadModeNoUnpack
-    Upload True  -> mr MsgUploadModeUnpack
-    where
-      mr = renderMessage foundation ls
-
 instance RenderMessage UniWorX SheetType where
   renderMessage foundation ls sheetType = case sheetType of
       NotGraded -> mr $ SheetTypeHeader NotGraded

src/Handler/Admin.hs

@@ -2,7 +2,6 @@ module Handler.Admin where
 
 import Import
 import Handler.Utils
-import Handler.Utils.Form.MassInput
 import Jobs
 import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
 
@@ -261,7 +260,11 @@ postAdminErrMsgR = do
     [whamlet|
       $maybe t <- plaintext
         <pre style="white-space:pre-wrap; font-family:monospace">
-          #{encodePrettyToTextBuilder t}
+          $case t
+            $of String t'
+              #{t'}
+            $of t'
+              #{encodePrettyToTextBuilder t'}
 
       ^{ctView'}
     |]

src/Handler/Corrections.hs

@@ -644,7 +644,7 @@ postCorrectionR tid ssh csh shn cid = do
             }
 
       ((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
-            areq (zipFileField True) (fslI MsgRatingFiles) Nothing
+            areq (zipFileField True Nothing) (fslI MsgRatingFiles) Nothing
       let uploadForm = wrapForm uploadForm' def
             { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
             , formEncoding = uploadEncoding
@@ -720,7 +720,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
 getCorrectionsUploadR = postCorrectionsUploadR
 postCorrectionsUploadR = do
   ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
-       areq (zipFileField True) (fslI MsgCorrUploadField & addAttr "uw-file-input" "") Nothing
+       areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing
 
   case uploadRes of
     FormMissing -> return ()

src/Handler/Course.hs

@@ -11,7 +11,6 @@ import Handler.Utils
 import Handler.Utils.Course
 import Handler.Utils.Tutorial
 import Handler.Utils.Communication
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Delete
 import Handler.Utils.Database
 import Handler.Utils.Table.Cells

src/Handler/Sheet.hs

@@ -14,7 +14,6 @@ import Handler.Utils.Table.Cells
 -- import Handler.Utils.Table.Columns
 import Handler.Utils.SheetType
 import Handler.Utils.Delete
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Invitations
 
 -- import Data.Time
@@ -116,7 +115,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
-      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
+      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
       <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)

src/Handler/Submission.hs

@@ -14,7 +14,6 @@ import Handler.Utils
 import Handler.Utils.Delete
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Invitations
 
 -- import Control.Monad.Trans.Maybe
@@ -130,8 +129,19 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
     fileUploadForm = case uploadMode of
       NoUpload
         -> pure Nothing
-      (Upload unpackZips)
+      UploadAny{..}
-        -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+        -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips extensionRestriction) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+      UploadSpecific{..}
+        -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
+
+    specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File))
+    specificFileForm spec@UploadSpecificFile{..}
+      = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
+
+    mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File)
+    mergeFileSources (catMaybes -> sources) = case sources of
+      [] -> Nothing
+      fs -> Just $ sequence_ fs
 
     miCell' :: Markup -> Either UserEmail UserId -> Widget
     miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
@@ -352,7 +362,9 @@ submissionHelper tid ssh csh shn mcid = do
               return (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
         return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
-  ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
+  -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
+  -- Therefore we do not restrict upload behaviour in any way in that case
+  ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies 
   let formWidget = wrapForm' BtnHandIn formWidget' def
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype

src/Handler/Term.hs

@@ -3,7 +3,6 @@ module Handler.Term where
 import Import
 import Handler.Utils
 import Handler.Utils.Table.Cells
-import Handler.Utils.Form.MassInput
 import qualified Data.Map as Map
 
 import Utils.Lens

src/Handler/Tutorial.hs

@@ -8,7 +8,6 @@ import Handler.Utils.Tutorial
 import Handler.Utils.Table.Cells
 import Handler.Utils.Delete
 import Handler.Utils.Communication
-import Handler.Utils.Form.MassInput
 import Handler.Utils.Form.Occurences
 import Handler.Utils.Invitations
 import Jobs.Queue

src/Handler/Utils/Communication.hs

@@ -9,7 +9,6 @@ module Handler.Utils.Communication
 
 import Import
 import Handler.Utils
-import Handler.Utils.Form.MassInput
 import Utils.Lens
 
 import Jobs.Queue

src/Handler/Utils/Form.hs

@@ -1,5 +1,6 @@
 module Handler.Utils.Form
   ( module Handler.Utils.Form
+  , module Handler.Utils.Form.MassInput
   , module Utils.Form
   , MonadWriter(..)
   ) where
@@ -35,6 +36,7 @@ import qualified Data.Map as Map
 import Control.Monad.Trans.Writer (execWriterT, WriterT)
 import Control.Monad.Trans.Except (throwE, runExceptT)
 import Control.Monad.Writer.Class
+import Control.Monad.Error.Class (MonadError(..))
 
 import Data.Scientific (Scientific)
 import Text.Read (readMaybe)
@@ -49,6 +51,13 @@ import Data.Proxy
 
 import qualified Text.Email.Validate as Email
 
+import Yesod.Core.Types (FileInfo(..))
+
+import System.FilePath (isExtensionOf)
+import Data.Text.Lens (unpacked)
+
+import Handler.Utils.Form.MassInput
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -341,14 +350,88 @@ studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do
           }
 
 
-uploadModeField :: Field Handler UploadMode
+uploadModeForm :: Maybe UploadMode -> AForm Handler UploadMode
-uploadModeField = selectField optionsFinite
+uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUploadMode <$> prev)
+  where
+    actions :: Map UploadModeDescr (AForm Handler UploadMode)
+    actions = Map.fromList
+      [ ( UploadModeNone, pure NoUpload)
+      , ( UploadModeAny
+        , UploadAny
+          <$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips)
+          <*> apreq extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
+        )
+      , ( UploadModeSpecific
+        , UploadSpecific <$> specificFileForm
+        )
+      ]
+  
+    extensionRestrictionField :: Field Handler (Maybe (NonNull (Set Extension)))
+    extensionRestrictionField = convertField (fromNullable . toSet) (maybe "" $ intercalate ", " . Set.toList . toNullable) textField
+      where
+        toSet = Set.fromList . filter (not . Text.null) . map (stripDot . Text.strip) . Text.splitOn ","
+        stripDot ext
+          | Just nExt <- Text.stripPrefix "." ext = nExt
+          | otherwise = ext
+    
+    specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile))
+    specificFileForm = wFormToAForm $ do
+      Just currentRoute <- getCurrentRoute
+      let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+          miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
+      miIdent <- ("specific-files--" <>) <$> newIdent
+      postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles)
+      where
+        preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile)
+        preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable
+        
+        postProcess :: FormResult (Map ListPosition (UploadSpecificFile, UploadSpecificFile)) -> WForm Handler (FormResult (NonNull (Set UploadSpecificFile)))
+        postProcess mapResult = do
+          MsgRenderer mr <- getMsgRenderer
+          return $ do
+            mapResult' <- Set.fromList . map snd . Map.elems <$> mapResult
+            case fromNullable mapResult' of
+              Nothing -> throwError [mr MsgNoUploadSpecificFilesConfigured]
+              Just lResult -> do
+                let names = Set.map specificFileName mapResult'
+                    labels = Set.map specificFileLabel mapResult'
+                if
+                  | Set.size names /= Set.size mapResult'
+                    -> throwError [mr MsgUploadSpecificFilesDuplicateNames]
+                  | Set.size labels /= Set.size mapResult'
+                    -> throwError [mr MsgUploadSpecificFilesDuplicateLabels]
+                  | otherwise
+                    -> return lResult
+
+        sFileForm :: (Text -> Text) -> Maybe UploadSpecificFile -> Form UploadSpecificFile
+        sFileForm nudge mPrevUF csrf = do
+          (labelRes, labelView) <- mpreq textField ("" & addName (nudge "label")) $ specificFileLabel <$> mPrevUF
+          (nameRes, nameView) <- mpreq textField ("" & addName (nudge "name")) $ specificFileName <$> mPrevUF
+          (reqRes, reqView) <- mpreq checkBoxField ("" & addName (nudge "required")) $ specificFileRequired <$> mPrevUF
+
+          return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes
+                 , $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
+                 )
+
+        miAdd _ _ nudge submitView = Just $ \csrf -> do
+          (formRes, formWidget) <- sFileForm nudge Nothing csrf
+          let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add")
+              addRes' = formRes <&> \fileRes oldRess ->
+                let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
+                 in pure $ Map.singleton iStart fileRes
+          return (addRes', formWidget')
+        miCell _ initFile initFile' nudge csrf =
+          sFileForm nudge (Just $ fromMaybe initFile initFile') csrf
+        miDelete = miDeleteList
+        miAllowAdd _ _ _ = True
+        miAddEmpty _ _ _ = Set.empty
+        miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
+        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
+                                               
 
 submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
 submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
   where
-    uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)
-
     actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
     actions = Map.fromList
       [ ( SubmissionModeNone
@@ -358,10 +441,10 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c
         , pure $ SubmissionMode True  Nothing
         )
       , ( SubmissionModeUser
-        , SubmissionMode False . Just <$> uploadModeForm
+        , SubmissionMode False . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
         )
       , ( SubmissionModeBoth
-        , SubmissionMode True  . Just <$> uploadModeForm
+        , SubmissionMode True  . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
         )
       ]
 
@@ -374,17 +457,41 @@ pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (re
       | otherwise
       = return . Left $ MsgUnknownPseudonymWord (CI.original w)
 
-zipFileField :: Bool -- ^ Unpack zips?
+specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File)
-             -> Field Handler (Source Handler File)
+specificFileField UploadSpecificFile{..} = Field{..}
-zipFileField doUnpack = Field{..}
   where
     fieldEnctype = Multipart
     fieldParse _ files
-      | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
+      | [f] <- files
+      = return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName)
+      | null files   = return $ Right Nothing
+      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
+    fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")
+
+    extensions = fileNameExtensions specificFileName
+    acceptRestricted = not $ null extensions
+    accept = Text.intercalate "," . map ("." <>) $ extensions
+
+
+zipFileField :: Bool -- ^ Unpack zips?
+             -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
+             -> Field Handler (Source Handler File)
+zipFileField doUnpack permittedExtensions = Field{..}
+  where
+    fieldEnctype = Multipart
+    fieldParse _ files
+      | [f@FileInfo{..}] <- files
+      , maybe True (anyOf (re _nullable . folded . unpacked) (`isExtensionOf` unpack fileName)) permittedExtensions || doUnpack
+      = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
       | null files   = return $ Right Nothing
       | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
     fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
 
+    zipExtensions = mimeExtensions "application/zip"
+
+    acceptRestricted = isJust permittedExtensions
+    accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
+
 multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
 multiFileField permittedFiles' = Field{..}
   where
@@ -590,23 +697,6 @@ jsonField hide = Field{..}
     |]
     fieldEnctype = UrlEncoded
 
-secretJsonField :: ( ToJSON a, FromJSON a
-                   , MonadHandler m
-                   , HandlerSite m ~ UniWorX
-                   )
-                => Field m a
-secretJsonField = Field{..}
-  where
-    fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
-    fieldParse [] [] = return $ Right Nothing
-    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
-    fieldView theId name attrs val _isReq = do
-      val' <- traverse (encodedSecretBox SecretBoxShort) val
-      [whamlet|
-        <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
-      |]
-    fieldEnctype = UrlEncoded
-
 boolField :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              )

src/Handler/Utils/Form/MassInput.hs

@@ -17,7 +17,6 @@ module Handler.Utils.Form.MassInput
 import Import
 import Utils.Form
 import Utils.Lens
-import Handler.Utils.Form (secretJsonField)
 import Handler.Utils.Form.MassInput.Liveliness
 import Handler.Utils.Form.MassInput.TH
 

src/Handler/Utils/Form/Occurences.hs

@@ -4,7 +4,6 @@ module Handler.Utils.Form.Occurences
 
 import Import
 import Handler.Utils.Form
-import Handler.Utils.Form.MassInput
 import Handler.Utils.DateTime
 
 import qualified Data.Set as Set

src/Handler/Utils/Submission.hs

@@ -318,8 +318,10 @@ extractRatingsMsg = do
   let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
       ignoredFiles = Right `Set.map` ignored'
   unless (null ignoredFiles) $ do
-    mr <- (toHtml . ) <$> getMessageRender
+    let ignoredModal = msgModal
-    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+          [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)
@@ -362,10 +364,28 @@ sinkSubmission userId mExists isUpdate = do
       return sId
     Right sId -> return sId
 
-  sId <$ sinkSubmission' 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

src/Import/NoFoundation.hs

@@ -99,6 +99,8 @@ import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
 
 import Data.Ratio as Import ((%))
 
+import Network.Mime as Import
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Model/Migration.hs

@@ -279,8 +279,8 @@ customMigrations = Map.fromListWith (>>)
                 ( Legacy.NoSubmissions       , _                   ) -> SubmissionMode False Nothing
                 ( Legacy.CorrectorSubmissions, _                   ) -> SubmissionMode True Nothing
                 ( Legacy.UserSubmissions     , Legacy.NoUpload     ) -> SubmissionMode False (Just NoUpload)
-                ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ Upload True)
+                ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction)
-                ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
+                ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction)
           [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
     )
   , ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]

src/Model/Submission.hs

@@ -7,6 +7,7 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
                              | DuplicateRating
                              | RatingWithoutUpdate
                              | ForeignRating CryptoFileNameSubmission
+                             | InvalidFileTitleExtension FilePath
   deriving (Typeable, Show)
 
 instance Exception SubmissionSinkException

src/Model/Types/Sheet.hs

@@ -16,7 +16,6 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 import Data.Typeable (Typeable)
 import Data.Universe
 import Data.Universe.Helpers
-import Data.Universe.TH
 import Data.Universe.Instances.Reverse ()
 
 import Data.NonNull.Instances ()
@@ -34,6 +33,8 @@ import Database.Persist.TH hiding (derivePersistFieldJSON)
 import Model.Types.JSON
 import Yesod.Core.Dispatch (PathPiece(..))
 
+import Network.Mime
+
 
 
 ----
@@ -210,9 +211,11 @@ partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
 
-instance Universe SubmissionFileType where universe = universeDef
+instance Universe SubmissionFileType
 instance Finite SubmissionFileType
 
+nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
+
 submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
 submissionFileTypeIsUpdate SubmissionOriginal  = False
 submissionFileTypeIsUpdate SubmissionCorrected = True
@@ -221,41 +224,52 @@ isUpdateSubmissionFileType :: Bool -> SubmissionFileType
 isUpdateSubmissionFileType False = SubmissionOriginal
 isUpdateSubmissionFileType True  = SubmissionCorrected
 
-instance PathPiece SubmissionFileType where
-  toPathPiece SubmissionOriginal  = "original"
-  toPathPiece SubmissionCorrected = "corrected"
-  fromPathPiece = finiteFromPathPiece
 
--- instance DisplayAble SubmissionFileType where
+data UploadSpecificFile = UploadSpecificFile
---   display SubmissionOriginal  = "Abgabe"
+  { specificFileLabel :: Text
---   display SubmissionCorrected = "Korrektur"
+  , specificFileName :: FileName
+  , specificFileRequired :: Bool
+  } deriving (Show, Read, Eq, Ord, Generic)
 
-{-
+deriveJSON defaultOptions
-data DA = forall a . (DisplayAble a) => DA a
+  { fieldLabelModifier = camelToPathPiece' 2
+  } ''UploadSpecificFile
+derivePersistFieldJSON ''UploadSpecificFile
 
-instance DisplayAble DA where
+data UploadMode = NoUpload
-  display (DA x) = display x
+                | UploadAny
--}
+                  { unpackZips :: Bool
-
+                  , extensionRestriction :: Maybe (NonNull (Set Extension))
-
+                  }
-data UploadMode = NoUpload | Upload { unpackZips :: Bool }
+                | UploadSpecific
+                  { specificFiles :: NonNull (Set UploadSpecificFile)
+                  }
   deriving (Show, Read, Eq, Ord, Generic)
 
-deriveFinite ''UploadMode
+defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
+defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece
   , fieldLabelModifier = camelToPathPiece
   , sumEncoding = TaggedObject "mode" "settings"
+  , omitNothingFields = True
   }''UploadMode
 derivePersistFieldJSON ''UploadMode
 
-instance PathPiece UploadMode where
+data UploadModeDescr = UploadModeNone
-  toPathPiece = \case
+                     | UploadModeAny
-    NoUpload     -> "no-upload"
+                     | UploadModeSpecific
-    Upload True  -> "unpack"
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-    Upload False -> "no-unpack"
+instance Universe UploadModeDescr
-  fromPathPiece = finiteFromPathPiece
+instance Finite UploadModeDescr
+
+nullaryPathPiece ''UploadModeDescr $ camelToPathPiece' 2
+
+classifyUploadMode :: UploadMode -> UploadModeDescr
+classifyUploadMode NoUpload = UploadModeNone
+classifyUploadMode UploadAny{} = UploadModeAny
+classifyUploadMode UploadSpecific{} = UploadModeSpecific
 
 data SubmissionMode = SubmissionMode
   { submissionModeCorrector :: Bool
@@ -263,24 +277,11 @@ data SubmissionMode = SubmissionMode
   }
   deriving (Show, Read, Eq, Ord, Generic)
 
-deriveFinite ''SubmissionMode
-
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 2
   } ''SubmissionMode
 derivePersistFieldJSON ''SubmissionMode
 
-finitePathPiece ''SubmissionMode
-  [ "no-submissions"
-  , "no-upload"
-  , "no-unpack"
-  , "unpack"
-  , "correctors"
-  , "correctors+no-upload"
-  , "correctors+no-unpack"
-  , "correctors+unpack"
-  ]
-
 data SubmissionModeDescr = SubmissionModeNone
                          | SubmissionModeCorrector
                          | SubmissionModeUser
@@ -336,4 +337,4 @@ instance Monoid Load where
   isByTutorial :: Load -> Bool
   isByTutorial (ByTutorial {}) = True
   isByTutorial _               = False
--}
+-}

src/Network/Mime/TH.hs

@@ -1,11 +1,12 @@
 module Network.Mime.TH
-  ( mimeMapFile
+  ( mimeMapFile, mimeSetFile
   ) where
 
 import ClassyPrelude.Yesod hiding (lift)
 import Language.Haskell.TH hiding (Extension)
 import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
 
+import qualified Data.Set as Set
 import qualified Data.Map as Map
 
 import Data.Text (Text)
@@ -18,7 +19,7 @@ import Network.Mime
 import Instances.TH.Lift ()
 
 
-mimeMapFile :: FilePath -> ExpQ
+mimeMapFile, mimeSetFile :: FilePath -> ExpQ
 mimeMapFile file = do
   qAddDependentFile file
   
@@ -36,6 +37,15 @@ mimeMapFile file = do
 
 
   lift mimeMap
+mimeSetFile file = do
+  qAddDependentFile file
+  
+  ls <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
+
+  let mimeSet :: Set MimeType
+      mimeSet = Set.fromList $ map (encodeUtf8 . Text.strip) ls
+
+  lift mimeSet
 
 isComment :: Text -> Bool
 isComment line = or

src/Settings.hs

@@ -73,6 +73,9 @@ import Handler.Utils.Submission.TH
 import Network.Mime
 import Network.Mime.TH
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
 
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
@@ -431,8 +434,17 @@ widgetFileSettings = def
 submissionBlacklist :: [Pattern]
 submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
 
+mimeMap :: MimeMap
+mimeMap = $(mimeMapFile "config/mimetypes")
+
 mimeLookup :: FileName -> MimeType
-mimeLookup = mimeByExt $(mimeMapFile "config/mimetypes") defaultMimeType
+mimeLookup = mimeByExt mimeMap defaultMimeType
+
+mimeExtensions :: MimeType -> Set Extension
+mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ]
+
+archiveTypes :: Set MimeType
+archiveTypes = $(mimeSetFile "config/archive-types")
 
 -- The rest of this file contains settings which rarely need changing by a
 -- user.

src/Utils/Form.hs

@@ -24,6 +24,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Reader.Class (MonadReader(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Trans.RWS (mapRWST)
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
 
 import Data.List ((!!))
 
@@ -445,6 +446,29 @@ optionsFinite = do
 rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
 rationalField = convertField toRational fromRational doubleField
 
+data SecretJSONFieldException = SecretJSONFieldDecryptFailure
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Exception SecretJSONFieldException
+
+secretJsonField :: ( ToJSON a, FromJSON a
+                   , MonadHandler m
+                   , MonadSecretBox (ExceptT EncodedSecretBoxException m)
+                   , MonadSecretBox (WidgetT (HandlerSite m) IO)
+                   , RenderMessage (HandlerSite m) FormMessage
+                   , RenderMessage (HandlerSite m) SecretJSONFieldException
+                   )
+                => Field m a
+secretJsonField = Field{..}
+  where
+    fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
+    fieldParse [] [] = return $ Right Nothing
+    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+    fieldView theId name attrs val _isReq = do
+      val' <- traverse (encodedSecretBox SecretBoxShort) val
+      [whamlet|
+        <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
+      |]
+    fieldEnctype = UrlEncoded
 
 -----------
 -- Forms --

src/Utils/Lens.hs

@@ -103,6 +103,8 @@ makePrisms ''HandlerContents
 
 makePrisms ''ErrorResponse
 
+makeLenses_ ''UploadMode
+
 makeLenses_ ''SubmissionMode
 
 makePrisms ''E.Value

stack.yaml

@@ -51,4 +51,6 @@ extra-deps:
 
   - systemd-1.2.0
 
+  - filepath-1.4.2
+
 resolver: lts-10.5

templates/messages/submissionFilesIgnored.hamlet

@@ -1,4 +1,4 @@
-_{MsgSubmissionFilesIgnored}
+<h2>_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}
 <ul>
   $forall ident <- ignoredFiles
     $case ident

templates/widgets/massinput/uploadSpecificFiles/add.hamlet

@@ -0,0 +1,4 @@
+$newline never
+^{formWidget}
+<td>
+  ^{fvInput submitView}

templates/widgets/massinput/uploadSpecificFiles/form.hamlet

@@ -0,0 +1,4 @@
+$newline never
+<td>#{csrf}^{fvInput labelView}
+<td>^{fvInput nameView}
+<td>^{fvInput reqView}

templates/widgets/massinput/uploadSpecificFiles/layout.hamlet

@@ -0,0 +1,16 @@
+$newline never
+<table>
+  <thead>
+    <th>_{MsgUploadSpecificFileLabel}
+    <th>_{MsgUploadSpecificFileName}
+    <th>_{MsgUploadSpecificFileRequired}
+    <th>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/specificFileField.hamlet

@@ -0,0 +1,8 @@
+$newline never
+<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required :acceptRestricted:accept=#{accept}>
+$if acceptRestricted
+  <br>
+  _{MsgUploadModeExtensionRestriction}: 
+  <ul .list--inline .list--comma-separated .list--iconless>
+    $forall ext <- extensions
+      <li style="font-family: monospace">#{ext}

templates/widgets/zipFileField.hamlet

@@ -1,2 +1,8 @@
 $newline never
-<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required>
+<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required :acceptRestricted:accept=#{accept}>
+$maybe exts <- fmap toNullable permittedExtensions
+  <br>
+  _{MsgUploadModeExtensionRestriction}: 
+  <ul .list--inline .list--comma-separated .list--iconless>
+    $forall ext <- zipExtensions <> exts
+      <li style="font-family: monospace">#{ext}

test/Database.hs

@@ -393,11 +393,11 @@ fillDb = do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp CourseLecturer
   void . insert $ Lecturer gkleen ffp CourseAssistant
-  adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now adhoc
-  feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now feste
-  keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
+  keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now keine
   void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
     [(fhamann   , Nothing)
@@ -484,7 +484,7 @@ fillDb = do
     ]
   sh1 <- insert Sheet
     { sheetCourse = pmo
-    , sheetName = "Blatt 1"
+    , sheetName = "Papierabgabe"
     , sheetDescription = Nothing
     , sheetType = Normal $ Points 6
     , sheetGrouping = Arbitrary 3
@@ -516,6 +516,60 @@ fillDb = do
   void . insert $ SubmissionUser maxMuster sub1
   sub1fid1 <- insertFile "AbgabeH10-1.hs"
   void . insert $ SubmissionFile sub1 sub1fid1 False False
+  sh2 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Spezifische Abgabe"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False $ Just UploadSpecific
+      { specificFiles = impureNonNull $ Set.fromList
+        [ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False
+        , UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False
+        , UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True
+        ]
+      }
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh2
+  sh3 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Dateiendung-eingeschränkte Abgabe"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh3
+  sh4 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Uneingeschränkte Abgabe, einzelne Datei"
+    , sheetDescription = Nothing
+    , sheetType = Normal $ Points 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now
+    , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny False Nothing
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
+    }
+  void . insert $ SheetEdit jost now sh4
   tut1 <- insert Tutorial
     { tutorialName = "Di08"
     , tutorialCourse = pmo