Mixed (external & direct) submissions

messages/uniworx/de.msg

@@ -456,9 +456,10 @@ UploadModeNone: Kein Upload
 UploadModeUnpack: Upload, einzelne Datei
 UploadModeNoUnpack: Upload, ZIP-Archive entpacken
 
-SheetNoSubmissions: Keine Abgabe
+NoSubmissions: Keine Abgabe
-SheetCorrectorSubmissions: Abgabe extern mit Pseudonym
+CorrectorSubmissions: Abgabe extern mit Pseudonym
-SheetUserSubmissions: Direkte Abgabe
+UserSubmissions: Direkte Abgabe
+BothSubmissions: Abgabe direkt & extern mit Pseudonym
 
 SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
 

models/sheets

@@ -10,8 +10,7 @@ Sheet   -- exercise sheet for a given course
     activeTo        UTCTime          -- Submission is only permitted before
     hintFrom        UTCTime Maybe    -- Additional files are made available
     solutionFrom    UTCTime Maybe    -- Solution is made available
-    uploadMode      UploadMode       -- Take apart Zip-Archives or not?
+    submissionMode  SubmissionMode   -- Submission upload by students and/or through tutors?
-    submissionMode  SheetSubmissionMode default='UserSubmissions'  -- Submission upload by students or through tutors only?
     autoDistribute  Bool default=false  -- Should correctors be assigned submissions automagically?
     CourseSheet course name
     deriving Generic

src/CryptoID.hs

@@ -58,21 +58,3 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
   parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where
   fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
-
-
-newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
-  deriving (Show, Read, Eq)
-
-pattern NewSubmission :: SubmissionMode
-pattern NewSubmission = SubmissionMode Nothing
-pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode
-pattern ExistingSubmission cID = SubmissionMode (Just cID)
-
-instance PathPiece SubmissionMode where
-    fromPathPiece "new" = Just $ SubmissionMode Nothing
-    fromPathPiece s     = SubmissionMode . Just <$> fromPathPiece s
-
-    toPathPiece (SubmissionMode Nothing)  = "new"
-    toPathPiece (SubmissionMode (Just x)) = toPathPiece x
-
-

src/Database/Persist/TH/Directory.hs

@@ -2,26 +2,35 @@ module Database.Persist.TH.Directory
   ( persistDirectoryWith
   ) where
 
-import ClassyPrelude hiding (mapM_, toList)
+import ClassyPrelude
 
 import Database.Persist.TH (parseReferences)
 import Database.Persist.Quasi (PersistSettings)
-import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Syntax hiding (lift)
 
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
 import qualified System.IO as SIO
 
+import System.FilePath
 import qualified System.Directory.Tree as DirTree
 
-import Data.Foldable (Foldable(..), mapM_)
+import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
+
+import Control.Lens
+  
 
 persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
 persistDirectoryWith settings dir = do
-  files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do
+  files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
-    h <- SIO.openFile fp SIO.ReadMode
+    fn <- MaybeT . return . fromNullable $ takeFileName fp
-    SIO.hSetEncoding h SIO.utf8_bom
+    guard . not $ head fn == '.'
-    Text.hGetContents h
+    guard . not $ head fn == '#' && last fn == '#'
-  mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files
+
+    lift $ do
+      h <- SIO.openFile fp SIO.ReadMode
+      SIO.hSetEncoding h SIO.utf8_bom
+      Text.hGetContents h
+  mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files
   
-  parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files
+  parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files

src/Foundation.hs

@@ -253,9 +253,13 @@ embedRenderMessage ''UniWorX ''RatingException id
 embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
 embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
-embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
 embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
 embedRenderMessage ''UniWorX ''LecturerType id
+embedRenderMessage ''UniWorX ''SubmissionModeDescr
+  $ let verbMap [_, _, "None"] = "NoSubmissions"
+        verbMap [_, _, v] = v <> "Submissions"
+        verbMap _ = error "Invalid number of verbs"
+     in verbMap . splitCamel
 
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@@ -742,15 +746,15 @@ tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
 tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-    Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
+    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
-    guard $ sheetSubmissionMode == UserSubmissions
+    guard $ is _Just submissionModeUser
     return Authorized
   r -> $unsupportedAuthPredicate AuthUserSubmissions r
 tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-    Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
+    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
-    guard $ sheetSubmissionMode == CorrectorSubmissions
+    guard submissionModeCorrector
     return Authorized
   r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
 tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do
@@ -1891,7 +1895,7 @@ pageActions (CorrectionsR) =
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
           uid <- MaybeT $ liftHandlerT maybeAuthId
-          [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+          sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
             E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
             let
               isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
@@ -1900,10 +1904,9 @@ pageActions (CorrectionsR) =
               isLecturer = E.exists . E.from $ \lecturer -> E.where_
                     $ lecturer E.^. LecturerUser E.==. E.val uid
                 E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+            E.where_ $ isCorrector' E.||. isLecturer
-                 E.&&. ( isCorrector' E.||. isLecturer )
+            return $ sheet E.^. SheetSubmissionMode
-            return E.countRows
+          return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
-          return $ (sheetCount :: Int) /= 0
       }
   , MenuItem
       { menuItemType = PageActionPrime
@@ -1931,7 +1934,7 @@ pageActions (CorrectionsGradeR) =
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
           uid <- MaybeT $ liftHandlerT maybeAuthId
-          [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+          sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
             E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
             let
               isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
@@ -1940,10 +1943,9 @@ pageActions (CorrectionsGradeR) =
               isLecturer = E.exists . E.from $ \lecturer -> E.where_
                     $ lecturer E.^. LecturerUser E.==. E.val uid
                 E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+            E.where_ $ isCorrector' E.||. isLecturer
-                 E.&&. ( isCorrector' E.||. isLecturer )
+            return $ sheet E.^. SheetSubmissionMode
-            return E.countRows
+          return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
-          return $ (sheetCount :: Int) /= 0
       }
   ]
 pageActions _ = []

src/Handler/Corrections.hs

@@ -80,9 +80,6 @@ courseIs cid  (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO
 sheetIs :: Key Sheet -> CorrectionTableWhere
 sheetIs shid  ((_course `E.InnerJoin`  sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
 
-submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere
-submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
-
 
 -- Columns
 colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
@@ -731,7 +728,7 @@ getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
 getCorrectionsCreateR = postCorrectionsCreateR
 postCorrectionsCreateR = do
   uid <- requireAuthId
-  let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+  let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
         E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
         let
           isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_
@@ -740,10 +737,9 @@ postCorrectionsCreateR = do
           isLecturer = E.exists . E.from $ \lecturer -> E.where_
                 $ lecturer E.^. LecturerUser E.==. E.val uid
             E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-        E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+        E.where_ $ isCorrector E.||. isLecturer
-             E.&&. ( isCorrector E.||. isLecturer )
         E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
-        return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
+        return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName))
       mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
       mkOptList opts = do
         opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts

src/Handler/Profile.hs

@@ -515,9 +515,9 @@ mkCorrectionsTable =
         , sortable (toNothing "cload")  (i18nCell MsgCorProportion) $
             correctorLoadCell  <$> view (_dbrOutput . _3 . _entityVal)
         , sortable (toNothing "assigned")  (i18nCell MsgCorProportion) $
-            int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue)
+            int64Cell <$> view (_dbrOutput . _4 . _1 . _Value)
         , sortable (toNothing "corrected")  (i18nCell MsgCorProportion) $
-            int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
+            int64Cell <$> view (_dbrOutput . _4 . _2 . _Value)
         ]
 
       validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]

src/Handler/Sheet.hs

@@ -71,8 +71,7 @@ data SheetForm = SheetForm
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
-      , sfSubmissionMode :: SheetSubmissionMode
+      , sfSubmissionMode :: SubmissionMode
-      , sfUploadMode   :: UploadMode
       , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
       , sfHintF        :: Maybe (Source Handler (Either FileId File))
@@ -112,8 +111,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
-      <*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
+      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
-      <*> areq uploadModeField (fslI MsgSheetUploadMode)      ((sfUploadMode   <$> template) <|> pure (Upload True))
       <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
@@ -464,7 +462,6 @@ getSheetNewR tid ssh csh = do
             , sfActiveFrom   = addTime     sheetActiveFrom
             , sfActiveTo     = addTime     sheetActiveTo
             , sfSubmissionMode = sheetSubmissionMode
-            , sfUploadMode   = sheetUploadMode
             , sfSheetF       = Nothing
             , sfHintFrom     = addTime <$> sheetHintFrom
             , sfHintF        = Nothing
@@ -497,7 +494,6 @@ getSEditR tid ssh csh shn = do
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
         , sfSubmissionMode = sheetSubmissionMode
-        , sfUploadMode   = sheetUploadMode
         , sfSheetF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
         , sfHintFrom     = sheetHintFrom
         , sfHintF        = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
@@ -539,7 +535,6 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               , sheetActiveTo       = sfActiveTo
               , sheetHintFrom       = sfHintFrom
               , sheetSolutionFrom   = sfSolutionFrom
-              , sheetUploadMode     = sfUploadMode
               , sheetSubmissionMode = sfSubmissionMode
               , sheetAutoDistribute = fromMaybe False oldAutoDistribute
               }

src/Handler/Submission.hs

@@ -75,12 +75,12 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FI
 
 getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSubmissionNewR = postSubmissionNewR
-postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
+postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn Nothing
 
 
 getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
 getSubShowR = postSubShowR
-postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
+postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid
 
 getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSubmissionOwnR tid ssh csh shn = do
@@ -98,8 +98,8 @@ getSubmissionOwnR tid ssh csh shn = do
   cID <- encrypt sid
   redirect $ CSubmissionR tid ssh csh shn cID SubShowR
 
-submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
+submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
-submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
+submissionHelper tid ssh csh shn mcid = do
   (Entity uid userData) <- requireAuth
   msmid     <- traverse decrypt mcid
   actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
@@ -168,7 +168,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
               return (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
         return (csheet,buddies,lastEdits)
-  ((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
+  ((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies)
   let formWidget = wrapForm formWidget' def
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype

src/Handler/Utils/Form.hs

@@ -140,7 +140,47 @@ linkButton lbl cls url = do
       ^{lbl}
   |]
 
+--------------------------
+-- Interactive fieldset --
+--------------------------
 
+multiAction :: forall action a.
+               ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
+            => Map action (AForm (HandlerT UniWorX IO) a)
+            -> FieldSettings UniWorX
+            -> Maybe action
+            -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
+multiAction acts fs@FieldSettings{..} defAction csrf = do
+  mr <- getMessageRender
+
+  let
+    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
+  (actionRes, actionView) <- mreq (selectField $ return options) fs defAction
+  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
+
+  let actionResults = view _1 <$> results
+      actionViews = Map.foldrWithKey accViews [] results
+
+      accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
+      accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
+
+  return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
+
+multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+             => Map action (AForm (HandlerT UniWorX IO) a)
+             -> FieldSettings UniWorX
+             -> Maybe action
+             -> AForm Handler a
+multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
+
+multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+             => Map action (AForm (HandlerT UniWorX IO) a)
+             -> FieldSettings UniWorX
+             -> Maybe action
+             -> (Html -> MForm Handler (FormResult a, Widget))
+multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
+
+  
 ------------
 -- Fields --
 ------------
@@ -277,8 +317,26 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
 uploadModeField :: Field Handler UploadMode
 uploadModeField = selectField optionsFinite
 
-submissionModeField :: Field Handler SheetSubmissionMode
+submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
-submissionModeField = selectField optionsFinite
+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
+        , pure $ SubmissionMode False Nothing
+        )
+      , ( SubmissionModeCorrector
+        , pure $ SubmissionMode True  Nothing
+        )
+      , ( SubmissionModeUser
+        , SubmissionMode False . Just <$> uploadModeForm
+        )
+      , ( SubmissionModeBoth
+        , SubmissionMode True  . Just <$> uploadModeForm
+        )
+      ]
 
 pseudonymWordField :: Field Handler PseudonymWord
 pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
@@ -605,42 +663,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
                  , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                  }) cPairs
 
-multiAction :: forall action a.
-               ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
-            => Map action (AForm (HandlerT UniWorX IO) a)
-            -> FieldSettings UniWorX
-            -> Maybe action
-            -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
-multiAction acts fs@FieldSettings{..} defAction csrf = do
-  mr <- getMessageRender
-
-  let
-    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
-  (actionRes, actionView) <- mreq (selectField $ return options) fs defAction
-  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
-
-  let actionResults = view _1 <$> results
-      actionViews = Map.foldrWithKey accViews [] results
-
-      accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
-      accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
-
-  return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
-
-multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-             => Map action (AForm (HandlerT UniWorX IO) a)
-             -> FieldSettings UniWorX
-             -> Maybe action
-             -> AForm Handler a
-multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
-
-multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-             => Map action (AForm (HandlerT UniWorX IO) a)
-             -> FieldSettings UniWorX
-             -> Maybe action
-             -> (Html -> MForm Handler (FormResult a, Widget))
-multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
-
 formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
 formResultModal res finalDest handler = maybeT_ $ do
   messages <- case res of

src/Model/Migration.hs

@@ -223,6 +223,23 @@ customMigrations = Map.fromListWith (>>)
         whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
         whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
     )
+  , ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
+    , whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
+        sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |]
+        [executeQQ|
+          ALTER TABLE "sheet" DROP COLUMN "upload_mode";
+          ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT;
+          ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb;
+        |]
+        forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do
+          let submissionMode' = case (submissionMode, uploadMode) of
+                ( 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 False ) -> SubmissionMode False (Just $ Upload False)
+          [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
+    )
   ]
 
 

src/Model/Migration/Types.hs

@@ -1,11 +1,17 @@
 module Model.Migration.Types where 
 
 import ClassyPrelude.Yesod
+import Data.Aeson
 import Data.Aeson.TH (deriveJSON, defaultOptions)
 
+import Utils.PathPiece
+
 import qualified Model as Current
 import qualified Model.Types.JSON as Current
 
+import Data.Universe
+
+
 data SheetType
   = Bonus  { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
   | Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben
@@ -19,6 +25,40 @@ sheetType Normal {..} = Current.Normal Current.Points {..}
 sheetType Pass {..}   = Current.Normal Current.PassPoints {..}
 sheetType NotGraded   = Current.NotGraded
 
+
+data UploadMode = NoUpload | Upload { unpackZips :: Bool }
+  deriving (Show, Read, Eq, Ord, Generic)
+
+deriveJSON defaultOptions ''UploadMode
+Current.derivePersistFieldJSON ''UploadMode
+
+instance Universe UploadMode where
+  universe = NoUpload : (Upload <$> universe)
+instance Finite UploadMode
+
+instance PathPiece UploadMode where
+  toPathPiece = \case
+    NoUpload     -> "no-upload"
+    Upload True  -> "unpack"
+    Upload False -> "no-unpack"
+  fromPathPiece = finiteFromPathPiece
+
+data SheetSubmissionMode = NoSubmissions
+                         | CorrectorSubmissions
+                         | UserSubmissions
+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''SheetSubmissionMode
+derivePersistField "SheetSubmissionMode"
+
+instance Universe SheetSubmissionMode
+instance Finite SheetSubmissionMode
+
+nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
+
+  
 {- TODO:
   * RenderMessage instance for newtype(SheetType) if needed
 -}

src/Model/Types.hs

@@ -16,6 +16,7 @@ import Utils
 import Control.Lens hiding (universe)
 import Utils.Lens.TH
 
+import Data.Map ((!))
 import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -24,6 +25,7 @@ import Data.Monoid (Sum(..))
 import Data.Maybe (fromJust)
 import Data.Universe
 import Data.Universe.Helpers
+import Data.Universe.TH
 import Data.UUID.Types (UUID)
 import qualified Data.UUID.Types as UUID
 
@@ -289,12 +291,14 @@ instance DisplayAble DA where
 data UploadMode = NoUpload | Upload { unpackZips :: Bool }
   deriving (Show, Read, Eq, Ord, Generic)
 
-deriveJSON defaultOptions ''UploadMode
+deriveFinite ''UploadMode
-derivePersistFieldJSON ''UploadMode
 
-instance Universe UploadMode where
+deriveJSON defaultOptions
-  universe = NoUpload : (Upload <$> universe)
+  { constructorTagModifier = camelToPathPiece
-instance Finite UploadMode
+  , fieldLabelModifier = camelToPathPiece
+  , sumEncoding = TaggedObject "mode" "settings"
+  }''UploadMode
+derivePersistFieldJSON ''UploadMode
 
 instance PathPiece UploadMode where
   toPathPiece = \case
@@ -303,20 +307,49 @@ instance PathPiece UploadMode where
     Upload False -> "no-unpack"
   fromPathPiece = finiteFromPathPiece
 
-data SheetSubmissionMode = NoSubmissions
+data SubmissionMode = SubmissionMode
-                         | CorrectorSubmissions
+  { submissionModeCorrector :: Bool
-                         | UserSubmissions
+  , submissionModeUser :: Maybe UploadMode
-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
+  }
+  deriving (Show, Read, Eq, Ord, Generic)
+
+deriveFinite ''SubmissionMode
 
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece
+  { fieldLabelModifier = camelToPathPiece' 2
-  } ''SheetSubmissionMode
+  } ''SubmissionMode
-derivePersistField "SheetSubmissionMode"
+derivePersistFieldJSON ''SubmissionMode
 
-instance Universe SheetSubmissionMode
+instance PathPiece SubmissionMode where
-instance Finite SheetSubmissionMode
+  toPathPiece = (Map.fromList (zip universeF verbs) !)
+    where
+      verbs = [ "no-submissions"
+              , "no-upload"
+              , "no-unpack"
+              , "unpack"
+              , "correctors"
+              , "correctors+no-upload"
+              , "correctors+no-unpack"
+              , "correctors+unpack"
+              ]
+  fromPathPiece = finiteFromPathPiece
 
-nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
+data SubmissionModeDescr = SubmissionModeNone
+                         | SubmissionModeCorrector
+                         | SubmissionModeUser
+                         | SubmissionModeBoth
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe SubmissionModeDescr
+instance Finite SubmissionModeDescr
+
+nullaryPathPiece ''SubmissionModeDescr $ camelToPathPiece' 2
+
+classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
+classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
+classifySubmissionMode (SubmissionMode True  Nothing ) = SubmissionModeCorrector
+classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
+classifySubmissionMode (SubmissionMode True  (Just _)) = SubmissionModeBoth
+  
 
 data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)

src/Utils/Lens.hs

@@ -11,9 +11,6 @@ import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
 
 
-_unValue :: Lens' (E.Value a) a
-_unValue f (E.Value a) = E.Value <$> f a
-
 _PathPiece :: PathPiece v => Prism' Text v
 _PathPiece = prism' toPathPiece fromPathPiece
 
@@ -102,6 +99,10 @@ makePrisms ''ErrorResponse
 
 makeLenses_ ''SheetCorrectorInvitation
 
+makeLenses_ ''SubmissionMode
+
+makePrisms ''E.Value
+
 
 -- makeClassy_ ''Load
 

templates/sheetShow.hamlet

@@ -18,15 +18,15 @@ $maybe descr <- sheetDescription sheet
       <dt .deflist__dt>_{MsgSheetSolutionFrom}
       <dd .deflist__dd>#{solution}
     <dt .deflist__dt>_{MsgSheetSubmissionMode}
-    <dd .deflist__dd>_{sheetSubmissionMode sheet}
+    <dd .deflist__dd>_{classifySubmissionMode (sheetSubmissionMode sheet)}
       $case sheetSubmissionMode sheet
-        $of CorrectorSubmissions
+        $of SubmissionMode True _
           <div .tooltip>
             <div .tooltip__handle>
             <div .tooltip__content>_{MsgSheetCorrectorSubmissionsTip}
         $of _
     $case sheetSubmissionMode sheet
-      $of CorrectorSubmissions
+      $of SubmissionMode True _
         <dt .deflist__dt>_{MsgSheetPseudonym}
         <dd .deflist__dd #pseudonym>
           $maybe pseudonym <- mPseudonym

templates/submission.hamlet

@@ -1,7 +1,10 @@
 $maybe cID <- mcid
   <section>
-    $case sheetUploadMode
+    $case sheetSubmissionMode
-      $of Upload _
+      $of SubmissionMode False Nothing
+        <p>
+          _{MsgSubmissionNoUploadExpected}
+      $of _
         <h2>
           <a href=@{urlArchive cID}>Archiv
           (<a href=@{urlOriginal cID}>Original</a>)
@@ -9,9 +12,6 @@ $maybe cID <- mcid
         $maybe fileTable <- mFileTable
           <h3>_{MsgSubmissionFiles}
           ^{fileTable}
-      $of _
-        <p>
-          _{MsgSubmissionNoUploadExpected}
 
     $if maySubmit && not (null lastEdits)
       <h3>_{MsgLastEdits}