Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

ChangeLog.md

@@ -10,6 +10,8 @@
 
     Intelligente Verteilung von Abgaben auf Korrektoren (z.B. bei Krankheit)
     
+    Übungsblätter können Abgabe von Dateien verbieten und angeben ob ZIP-Archive entpackt werden sollen
+
   * Version 06.08.2018
   
     Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen

db.hs

@@ -196,11 +196,11 @@ fillDb = do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp
   void . insert $ Lecturer gkleen ffp
-  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
-  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
-  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
   -- EIP
   eip <- insert Course
@@ -284,6 +284,7 @@ fillDb = do
     , sheetVisibleFrom = Just now
     , sheetActiveFrom = now
     , sheetActiveTo = (14 * nominalDay) `addUTCTime` now 
+    , sheetUploadMode = Upload True
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     }

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
@@ -289,3 +290,11 @@ CorrectorExcused: Entschuldigt
 DayIsAHoliday     tid@TermId date@Text: #{date} ist ein Feiertag
 DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid}
 DayIsOutOfTerm    tid@TermId date@Text: #{date} liegt nicht im #{display tid}
+UploadModeNone: Kein Upload
+UploadModeUnpack: Upload, einzelne Datei
+UploadModeNoUnpack: Upload, ZIP-Archive entpacken
+
+SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
+
+FieldPrimary: Hauptfach
+FieldSecondary: Nebenfach

models

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

src/Foundation.hs

@@ -178,6 +178,12 @@ instance RenderMessage UniWorX TermIdentifier where
     Winter -> renderMessage' $ MsgWinterTerm year
     where renderMessage' = renderMessage foundation ls
 
+instance RenderMessage UniWorX StudyFieldType where
+  renderMessage foundation ls = \case
+    FieldPrimary -> renderMessage' MsgFieldPrimary
+    FieldSecondary -> renderMessage' MsgFieldSecondary
+    where renderMessage' = renderMessage foundation ls
+
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving (Eq, Ord, Read, Show)
 

src/Handler/Profile.hs

@@ -130,10 +130,14 @@ getProfileR = do
                 E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
                 E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
                 E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
-                return  (studydegree E.^. StudyDegreeName
+                return  ( ( studydegree E.^. StudyDegreeName
-                        ,studyterms  E.^. StudyTermsName
+                          , studydegree E.^. StudyDegreeKey
-                        ,studyfeat   E.^. StudyFeaturesType
+                          )
-                        ,studyfeat   E.^. StudyFeaturesSemester)
+                        , ( studyterms  E.^. StudyTermsName
+                          , studyterms  E.^. StudyTermsKey
+                          )
+                        , studyfeat   E.^. StudyFeaturesType
+                        , studyfeat   E.^. StudyFeaturesSemester)
             )
   let formText  = Just MsgSettings
       actionUrl = ProfileR

src/Handler/Sheet.hs

@@ -82,6 +82,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))
@@ -119,6 +120,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)                 (sfHintFrom     <$> template)
@@ -364,6 +366,7 @@ getSheetNewR tid ssh csh = do
           , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
           , sfActiveFrom   = addOneWeek     sheetActiveFrom
           , sfActiveTo     = addOneWeek     sheetActiveTo
+          , sfUploadMode   = sheetUploadMode
           , sfSheetF       = Nothing
           , sfHintFrom     = addOneWeek <$> sheetHintFrom
           , sfHintF        = Nothing
@@ -397,6 +400,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
@@ -425,7 +429,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
@@ -436,6 +440,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 System.FilePath
 -- 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 (csheet,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/default-layout.lucius

@@ -156,6 +156,7 @@ h4 {
   position: relative;
   min-height: calc(100vh - var(--header-height));
   padding: 20px;
+  overflow: hidden;
 }
 
 @media (max-width: 768px) {
@@ -169,7 +170,6 @@ h4 {
 .main__content {
   position: relative;
   background-color: white;
-  overflow: hidden;
   transition: padding-left .2s ease-out;
   max-width: 1200px;
   margin: 0 auto;

templates/profile.hamlet

@@ -49,12 +49,20 @@
               <th .table__th> Studienart
               <th .table__th> Semester
 
-            $forall (degree,field,fieldtype,semester) <- studies
+            $forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
               <tr.table__row>
-                <td .table__td> #{display degree}
+                <td .table__td>
-                <td .table__td> #{display field}
+                  $maybe name <- E.unValue degree
-                <td .table__td> #{display fieldtype}
+                    #{display name}
-                <td .table__td> #{display semester}
+                  $nothing
+                    #{display degreeKey}
+                <td .table__td>
+                  $maybe name <- E.unValue field
+                    #{display name}
+                  $nothing
+                    #{display fieldKey}
+                <td .table__td>_{E.unValue fieldtype}
+                <td .table__td>#{display semester}
 
     $if not $ null participant
       <dt .deflist__dt> Teilnehmer

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}

templates/widgets/breadcrumbs.hamlet

@@ -4,4 +4,4 @@ $newline never
     $forall bc <- parents
       <li .breadcrumbs__item>
         <a .breadcrumbs__link href="@{fst bc}">#{snd bc}
-    <li .breadcrumbs__item>#{title}
+    <li .breadcrumbs__last-item>#{title}

templates/widgets/breadcrumbs.lucius

@@ -1,13 +1,28 @@
 .breadcrumbs__container {
   position: relative;
-  color: var(--color-font);
+  color: var(--color-lightwhite);
-  margin-bottom: 10px;
+  margin-top: -11px;
+  margin-right: -20px;
+  margin-bottom: 20px;
+  margin-left: -42px;
+  padding: 4px 13px;
+  padding-left: 42px;
+  background-color: var(--color-dark);
+  line-height: 30px;
+}
+
+@media (min-width: 768px) {
+
+  .breadcrumbs__container {
+    margin-top: -22px;
+  }
 }
 
 .breadcrumbs__link {
+  color: var(--color-lightwhite);
 
   &:hover {
-    color: var(--color-fontsec);
+    color: var(--color-white);
   }
 }
 
@@ -19,24 +34,10 @@
   z-index: 1;
   margin-right: 10px;
 
-  &:last-child {
-    margin-right: 0;
-    font-weight: 800;
-    color: var(--color-dark);
-    top: 1px;
-
-    &::after {
-      content: none;
-    }
-  }
-
-  --color-separator: var(--color-primary);
-
   &:hover {
     opacity: 1;
   }
 
-
   &::after {
     content: '';
     position: absolute;
@@ -44,9 +45,18 @@
     right: 0;
     width: 7px;
     height: 7px;
-    border-bottom: 1px solid var(--color-separator);
+    border-style: solid;
-    border-right: 1px solid var(--color-separator);
+    border-width: 0;
+    border-bottom-width: 1px;
+    border-right-width: 1px;
+    border-color: var(--color-white);
     transform: rotate(-45deg);
     z-index: 10;
   }
 }
+
+.breadcrumbs__last-item {
+  line-height: 28px;
+  vertical-align: bottom;
+  font-weight: 600;
+}

templates/widgets/navbar.hamlet

@@ -1,5 +1,6 @@
 $newline never
 <div .navbar-container>
+  <div .navbar-shadow>
   <nav .navbar.js-sticky-navbar>
 
     <a href="/" .navbar__logo>

templates/widgets/navbar.lucius

@@ -1,3 +1,30 @@
+.navbar-container {
+  position: relative;
+}
+
+.navbar-shadow {
+  position: absolute;
+  right: 0;
+  height: var(--header-height-collapsed);
+  width: 20px;
+  z-index: 50;
+  background-image: linear-gradient(to left, rgba(0, 0, 0, 0.4), transparent);
+}
+
+@media (min-width: 768px) {
+
+  .navbar-shadow {
+    height: var(--header-height);
+  }
+}
+
+@media (min-width: 1024px) {
+
+  .navbar-shadow {
+    display: none;
+  }
+}
+
 .navbar {
   position: fixed;
   display: flex;
@@ -5,26 +32,26 @@
   align-items: center;
   justify-content: flex-start;
   width: 100%;
+  top: 0;
+  left: 0;
   height: var(--header-height);
   background: var(--color-darker); /* Old browsers */
   background: -moz-linear-gradient(bottom, var(--color-dark) 0%, var(--color-darker) 100%); /* FF3.6-15 */
   background: -webkit-linear-gradient(bottom, var(--color-dark) 0%,var(--color-darker) 100%); /* Chrome10-25,Safari5.1-6 */
   background: linear-gradient(to top, var(--color-dark) 0%,var(--color-darker) 100%); /* W3C, IE10+, FF16+, Chrome26+, Opera12+, Safari7+ */
   color: white;
+  margin-right: 40px;
   z-index: 10;
-  top: 0;
-  left: 0;
-  overflow: hidden;
   box-shadow: 0 0 4px rgba(0, 0, 0, 0.2);
-  transition: all .2s cubic-bezier(0.03, 0.43, 0.58, 1);
-  width: 100%;
   overflow: auto;
+  transition: all .2s cubic-bezier(0.03, 0.43, 0.58, 1);
 }
 
 @media (max-width: 768px) {
 
   .navbar {
     padding: 0px;
+    margin-right: 0;
   }
 }
 
@@ -167,6 +194,10 @@
   + .navbar__list {
     margin-left: 12px;
   }
+
+  &:last-of-type {
+    padding-right: 40px;
+  }
 }
 
 @media (min-width: 768px) {