CourseForm works without redirect only

FragenSJ.txt

@@ -9,3 +9,11 @@
 
  - Handler.Utils.Form.FormIdentifier: Still needed?
  - Verification of Ownership during Edit?
+ - Versionen für Studenten/Korrektoren/Lecturers/Admins?!
+
+ - Sheets: Multiple Files
+
+** Page pageActions
+ - i18n der Links?
+ - Berechtigungen prüfen?
+ => Eigener Constructor statt NavbarLeft/Right?!

models

@@ -96,9 +96,11 @@ Sheet
     name            Text
     description     Html Maybe
     type            SheetType
+    grouping        SheetGroup
     markingText     Html Maybe
     activeFrom      UTCTime
     activeTo        UTCTime
+    visibleFrom     UTCTime Maybe
     hintFrom        UTCTime Maybe
     solutionFrom    UTCTime Maybe
     created         UTCTime

src/Foundation.hs

@@ -200,7 +200,10 @@ isAuthorizedDB TermEditR              _ = adminAccess Nothing
 isAuthorizedDB (TermEditExistR _)     _ = adminAccess Nothing
 isAuthorizedDB CourseNewR             _ = lecturerAccess Nothing
 isAuthorizedDB (CourseEditR t c)      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (SheetNewR t c) _        = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (SheetListR  t c)      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (SheetNewR   t c)      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (SheetEditR  t c s)    _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (SheetDelR   t c s)    _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (CourseEditIDR cID)    _ = do
   courseId <- decrypt cID
   courseLecturerAccess courseId

src/Handler/Course.hs

@@ -198,7 +198,7 @@ courseEditHandler course = do
                     })) -> do -- edit existing course
           let tident = unTermKey tid
           actTime <- liftIO getCurrentTime
-          addMessage "debug" [shamlet| #{show res}|]
+          -- addMessage "debug" [shamlet| #{show res}|]
           runDB $ do
             old <- get cid
             case old of
@@ -208,7 +208,7 @@ courseEditHandler course = do
             -- if ((entityKey <$> existing) /= Just cid)
             --  then addMessageI "danger" $ MsgCourseEditDupShort tident csh
             --   else do
-                addMessage "debug" $ fromMaybe [shamlet|No description given.|] $ cfDesc res
+                -- addMessage "debug" $ fromMaybe [shamlet|No description given.|] $ cfDesc res
 --                 update cid
 --                   [ CourseName         =. cfName     res
 --                   , CourseDescription  =. cfDesc     res
@@ -242,7 +242,7 @@ courseEditHandler course = do
 --                 if (isNothing updOkay)
 --                   then do
                 addMessageI "info" $ MsgCourseEditOk tident csh
-                redirect $ CourseListTermR tid
+                -- redirect $ CourseListTermR tid
 --                   else addMessageI "danger" $ MsgCourseEditDupShort tident csh
 
       (FormFailure _) -> addMessageI "warning" MsgInvalidInput

src/Handler/Sheet.hs

@@ -38,7 +38,9 @@ data SheetForm = SheetForm
       { sfName         :: Text
       , sfComment      :: Maybe Html
       , sfType         :: SheetType
+      , sfGroup        :: SheetGroup
       , sfMarkingText  :: Maybe Html
+      , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
       , sfSheetF       :: Maybe FileInfo
@@ -46,6 +48,7 @@ data SheetForm = SheetForm
       , sfHintF        :: Maybe FileInfo
       , sfSolutionFrom :: Maybe UTCTime
       , sfSolutionF    :: Maybe FileInfo
+      , sfSheetId      :: Maybe SheetId
       }
 
 
@@ -54,18 +57,21 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do
     -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
     -- Erstmal nur mit ZIP arbeiten
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
-      <$> areq textField    (fsb "Name")        (sfName <$> template)
+      <$> areq textField     (fsb "Name")        (sfName <$> template)
-      <*> aopt htmlField    (fsb "Hinweise für Teilnehmer")  (sfMarkingText <$> template)
+      <*> aopt htmlField     (fsb "Hinweise für Teilnehmer")  (sfMarkingText <$> template)
-      <*> sheetTypeAFormReq (fsb "Bewertung")   (sfType <$> template)
+      <*> sheetTypeAFormReq  (fsb "Bewertung")     (sfType <$> template)
+      <*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGroup <$> template)
       --TODO: SICHTBARKEIT hinzunehmen
-      <*> aopt htmlField    (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
+      <*> aopt htmlField     (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
-      <*> areq utcTimeField (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
+      <*> aopt utcTimeField  (fsb "Sichtbar ab") (sfVisibleFrom  <$> template)
-      <*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo     <$> template)
+      <*> areq utcTimeField  (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
-      <*> fileAFormOpt      (fsb "Aufgaben")
+      <*> areq utcTimeField  (fsb "Abgabefrist") (sfActiveTo     <$> template)
-      <*> aopt utcTimeField (fsb "Hinweis ab")  (sfHintFrom     <$> template)
+      <*> fileAFormOpt       (fsb "Aufgabenstellung")
-      <*> fileAFormOpt      (fsb "Hinweis")
+      <*> aopt utcTimeField  (fsb "Hinweis ab")  (sfHintFrom     <$> template)
-      <*> aopt utcTimeField (fsb "Lösung ab")   (sfSolutionFrom <$> template)
+      <*> fileAFormOpt       (fsb "Hinweis")
-      <*> fileAFormOpt      (fsb "Lösung")
+      <*> aopt utcTimeField  (fsb "Lösung ab")   (sfSolutionFrom <$> template)
+      <*> fileAFormOpt       (fsb "Lösung")
+      <*> aopt hiddenField "EditSheetId"         (sfSheetId <$> template)
     return $ case result of
       FormSuccess sheetResult
         | errorMsgs <- validateSheet sheetResult
@@ -82,7 +88,18 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do
                 )
       _ -> (result, widget)
   where
-    validateSheet _ = [] -- TODO
+    validateSheet :: SheetForm -> [Text]
+    validateSheet (SheetForm{..}) =
+      [ msg | (False, msg) <-
+        [ ( maybe True (sfActiveFrom >=) sfVisibleFrom
+          , "Sichtbarkeit muss vor Beginn der Abgabefrist liegen."
+          )
+        , ( sfActiveTo >= sfActiveFrom
+          , "Ende der Abgabefrist muss nach deren Beginn liegen."
+          )
+        -- TODO: continue here!!!
+      ] ]
+
 
 
 fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
@@ -115,16 +132,23 @@ getSheetList courseEnt = do
         rated       <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
         return (sid, sheet, (submissions, rated))
   let colSheets = mconcat
-       [ headed "Blatt"       $ toWgt . sheetName . snd3
+        [ headed "Blatt"       $ toWgt . sheetName . snd3
-       , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
+        , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
-       , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
+        , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
-       , headed "Bewertung"   $ toWgt . show . sheetType . snd3
+        , headed "Bewertung"   $ toWgt . show . sheetType . snd3
-       , headed "Korrigiert"  $ toWgt . snd . trd3
+        , headed "Korrigiert"  $ toWgt . snd . trd3
-       , headed "Eingereicht" $ toWgt . fst . trd3
+        , headed "Eingereicht" $ toWgt . fst . trd3
-       -- TODO: only show edit button for allowed course assistants
+        -- TODO: only show edit button for allowed course assistants
-       , headed ""            $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s
+        , headed ""            $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s
-       ]
+        ]
-  defaultLayout $ do
+  let pageActions =
+        [ NavbarLeft $ MenuItem
+          { menuItemLabel = "Neues Übungsblatt"
+          , menuItemRoute = SheetNewR tid csh
+          , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False
+          }
+        ]
+  defaultLinkLayout pageActions $ do
     setTitle $ toHtml $ T.append "Übungsblätter " csh
     if null sheets
       then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]

src/Handler/Utils.hs

@@ -53,6 +53,8 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
 whenIsJust Nothing  _ = return ()
 
+
+
 ----------
 -- Maps --
 ----------

src/Handler/Utils/Form.hs

@@ -274,6 +274,14 @@ sheetTypeAFormReq d (Just (Normal p)) =
   -- TODO, offer options to choose between Normal/Bonus/Pass
   (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
 
+sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
+sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
+  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
+  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
+sheetGroupAFormReq d _other = -- TODO
+  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
+  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
+
 utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
 -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
 -- TODO: Verify whether this is UTC or local time from Browser

src/Model/Types.hs

@@ -54,6 +54,15 @@ data SheetType
 deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON "SheetType"
 
+data SheetGroup
+  = Arbitrary { maxParticipants :: Int }
+  | RegisteredGroups
+  | NoGroups
+  deriving (Show, Read, Eq)
+deriveJSON defaultOptions ''SheetGroup
+derivePersistFieldJSON "SheetGroup"
+
+
 data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded) 
 derivePersistField "ExamStatus"