Add UploadMode to Sheet

Fixes #181

messages/uniworx/de.msg

@@ -85,6 +85,7 @@ SheetDelHead       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheet
 SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
 SheetDelOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht.
 
+SheetUploadMode: Abgabe von Dateien
 SheetExercise: Aufgabenstellung
 SheetHint: Hinweis
 SheetHintFrom: Hinweis ab
@@ -285,3 +286,9 @@ DummyLoginTitle: Development-Login
 CorrectorNormal: Normal
 CorrectorMissing: Abwesend
 CorrectorExcused: Entschuldigt
+
+UploadModeNone: Kein Upload
+UploadModeUnpack: Upload, einzelne Datei
+UploadModeNoUnpack: Upload, ZIP-Archive entpacken
+
+SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.

models

@@ -108,6 +108,7 @@ Sheet
     activeTo        UTCTime
     hintFrom        UTCTime Maybe
     solutionFrom    UTCTime Maybe
+    uploadMode      UploadMode
     CourseSheet course name
 SheetEdit
     user            UserId

src/Handler/Sheet.hs

@@ -81,6 +81,7 @@ data SheetForm = SheetForm
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
+      , sfUploadMode   :: UploadMode
       , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
       , sfHintF        :: Maybe (Source Handler (Either FileId File))
@@ -118,6 +119,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
+      <*> 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)
@@ -367,6 +369,7 @@ getSheetNewR tid ssh csh = do
           , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
           , sfActiveFrom   = addOneWeek     sheetActiveFrom
           , sfActiveTo     = addOneWeek     sheetActiveTo
+          , sfUploadMode   = sheetUploadMode
           , sfSheetF       = Nothing
           , sfHintFrom     = addOneWeek <$> sheetHintFrom
           , sfHintF        = Nothing
@@ -400,6 +403,7 @@ getSEditR tid ssh csh shn = do
         , sfVisibleFrom  = sheetVisibleFrom
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
+        , sfUploadMode   = sheetUploadMode
         , sfSheetF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
         , sfHintFrom     = sheetHintFrom
         , sfHintF        = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
@@ -428,7 +432,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
         actTime <- liftIO getCurrentTime
         cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
         let newSheet = Sheet
-              { sheetCourse     = cid
+              { sheetCourse       = cid
               , sheetName         = sfName
               , sheetDescription  = sfDescription
               , sheetType         = sfType
@@ -439,6 +443,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               , sheetActiveTo     = sfActiveTo
               , sheetHintFrom     = sfHintFrom
               , sheetSolutionFrom = sfSolutionFrom
+              , sheetUploadMode   = sfUploadMode
               }
         mbsid <- dbAction newSheet
         case mbsid of

src/Handler/Submission.hs

@@ -63,10 +63,14 @@ import qualified Text.Blaze.Html5.Attributes as HA
 -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
 
 
-makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
+makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
-makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
+makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do
+    let
+      fileUpload = case uploadMode of
+        NoUpload -> pure Nothing
+        (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
     flip (renderAForm FormStandard) html $ (,)
-      <$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+      <$> fileUpload
       <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
                                     | g <- [1..(max groupNr $ length buddies)]             -- groupNr might have decreased meanwhile
                                     | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
@@ -173,8 +177,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 (sheet,buddies,lastEdits)
-  let unpackZips = True -- undefined -- TODO
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
-  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
   mCID <- runDB $ do
     res' <- case res of
       (FormMissing )           -> return $ FormMissing
@@ -231,7 +234,14 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
               -> return smid
             (Just files, _)  -- new files
               -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
-            _ -> error "Impossible, because of definition of `makeSubmissionForm`"
+            (Nothing, Nothing) -- new submission, no file upload requested
+              -> insert Submission
+                  { submissionSheet = shid
+                  , submissionRatingPoints = Nothing
+                  , submissionRatingComment = Nothing
+                  , submissionRatingBy = Nothing
+                  , submissionRatingTime = Nothing
+                  }
           -- Determine members of pre-registered group
           groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
             E.on $ submissionGroup E.^. SubmissionGroupId  E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup

src/Handler/Utils/Form.hs

@@ -249,6 +249,13 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
 schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
 schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
 
+uploadModeField :: Field Handler UploadMode
+uploadModeField = selectFieldList
+  [ (MsgUploadModeNone    , NoUpload      )
+  , (MsgUploadModeNoUnpack, Upload   False)
+  , (MsgUploadModeUnpack  , Upload   True )
+  ]
+
 zipFileField :: Bool -- ^ Unpack zips?
              -> Field Handler (Source Handler File)
 zipFileField doUnpack = Field{..}

src/Model/Migration.hs

@@ -168,12 +168,18 @@ customMigrations = Map.fromListWith (>>)
     , whenM (tableExists "user") $ do
         userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
         [executeQQ|
-          ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' ';
+          ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT '';
         |]
         forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
           Just name -> update uid [UserSurname =. name]
           _other    -> error $ "Empty userDisplayName found"
     )
+  , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
+    , whenM (tableExists "sheet") $ do
+        [executeQQ|
+          ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
+        |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -193,6 +193,12 @@ instance DisplayAble DA where
 -}
 
 
+data UploadMode = NoUpload | Upload { unpackZips :: Bool }
+  deriving (Show, Read, Eq, Ord)
+
+deriveJSON defaultOptions ''UploadMode
+derivePersistFieldJSON ''UploadMode
+
 data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "ExamStatus"

templates/submission.hamlet

@@ -1,12 +1,17 @@
 $maybe cID <- mcid
   <section>
-    <h2>
+    $case sheetUploadMode
-      <a href=@{urlArchive cID}>Archiv
+      $of Upload _
-      (<a href=@{urlOriginal cID}>Original</a>)
+        <h2>
+          <a href=@{urlArchive cID}>Archiv
+          (<a href=@{urlOriginal cID}>Original</a>)
 
-    $maybe fileTable <- mFileTable
+        $maybe fileTable <- mFileTable
-      <h3>_{MsgSubmissionFiles}
+          <h3>_{MsgSubmissionFiles}
-      ^{fileTable}
+          ^{fileTable}
+      $of _
+        <p>
+          _{MsgSubmissionNoUploadExpected}
 
     $if not (null lastEdits)
       <h3>_{MsgLastEdits}