Merge branch 'feat/assign-correctors' into feat/pagination

config/settings.yml

@@ -19,6 +19,7 @@ should-log-all: "_env:LOG_ALL:false"
 # mutable-static: false
 # skip-combining: false
 auth-dummy-login: "_env:DUMMY_LOGIN:false"
+allow-deprecated: "_env:ALLOW_DEPRECATED:false"
 
 # NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
 # See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings

messages/de.msg

@@ -1,3 +1,12 @@
+BtnSubmit: Senden
+BtnAbort: Abbrechen
+BtnDelete: Löschen
+BtnRegister: Anmelden
+BtnDeregister: Abmelden
+
+RegisterFrom: Anmeldungen von
+RegisterTo: Anmeldungen bis
+
 SummerTerm year@Integer: Sommersemester #{tshow year}
 WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
 PSLimitNonPositive: “pagesize” muss größer als null sein
@@ -12,6 +21,7 @@ TermEditHeading: Semester editieren/anlegen
 LectureStart: Beginn Vorlesungen
 
 Course: Kurs
+CourseSecret: Zugangspasswort
 CourseNewOk        tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt.
 CourseEditOk       tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert.
 CourseNewDupShort  tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
@@ -44,6 +54,7 @@ UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung ein
 UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
 UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
 UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
+UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
 UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
 UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
 UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
@@ -53,6 +64,7 @@ UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein f
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
 
 Submission: Abgabenummer
+
 SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
 SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
@@ -63,12 +75,25 @@ SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem
 
 CorrectionsTitle: Zugewiesene Korrekturen
 CourseCorrectionsTitle: Korrekturen für diesen Kurs
-Corrector: Korrektor
 
 EMail: E-Mail
 EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer.
 NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs #{termToText tid}-#{csh} angemeldet.
 
+AddCorrector: Zusätzlicher Korrektor
+CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen
+SheetCorrectorsTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Korrektoren für #{termToText tid}-#{courseShortHand} #{sheetName}
+CountTutProp: Tutorien zählen gegen Proportion
+Corrector: Korrektor
+Correctors: Korrektoren
+CorByTut: Nach Tutorium
+CorProportion: Anteil
+DeleteRow: Zeile entfernen
+ProportionNegative: Anteile dürfen nicht negativ sein
+CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
+CorrectorsPlaceholder: Korrektoren...
+CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
+
 HomeHeading: Aktuelle Termine
 ProfileHeading: Benutzerprofil und Einstellungen
 ProfileDataHeading: Gespeicherte Benutzerdaten
@@ -97,4 +122,5 @@ NrColumn: Nr
 SelectColumn: Auswahl
 
 CorrDownload: Herunterladen
-CorrSetCorrector: Korrektor zuweisen
+CorrSetCorrector: Korrektor zuweisen
+NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!

models

@@ -60,7 +60,7 @@ Course
     term             TermId
     school           SchoolId
     capacity         Int Maybe
-    hasRegistration  Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
+    -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
     registerFrom     UTCTime Maybe
     registerTo       UTCTime Maybe
     deregisterUntil  UTCTime Maybe
@@ -119,6 +119,7 @@ SheetCorrector
     sheet           SheetId
     load            Load
     UniqueSheetCorrector user sheet
+    deriving Show Eq Ord
 SheetFile
     sheet           SheetId
     file            FileId

package.yaml

@@ -81,6 +81,7 @@ dependencies:
 - exceptions
 - lens
 - MonadRandom
+- email-validate
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -21,7 +21,7 @@
 --    !isRead     -- only if it is read-only access (i.e. GET but not POST)
 --    !isWrite    -- only if it is write access     (i.e. POST only) why needed???
 --
---    !deprecated -- like free, but logs and gives a warning
+--    !deprecated -- like free, but logs and gives a warning; entirely disabled in production
 --
 
 /static StaticR Static appStatic                              !free
@@ -30,9 +30,10 @@
 /favicon.ico FaviconR GET                                     !free
 /robots.txt RobotsR GET                                       !free
 
-/                           HomeR             GET                                         !free
+/                           HomeR             GET             !free
-/users                      UsersR            GET                                         -- no tags, i.e. admins only
+/users                      UsersR            GET             -- no tags, i.e. admins only
 /admin/test                 AdminTestR        GET POST
+/admin/user/#CryptoUUIDUser AdminUserR        GET
 
 /profile                    ProfileR          GET POST        !free                             !free
 /profile/data               ProfileDataR      GET             !free                             !free
@@ -47,7 +48,8 @@
 /course/                    CourseListR       GET             !free
 !/course/new                CourseNewR        GET POST        !lecturer
 /course/#TermId/#Text       CourseR                           !lecturer:
-  /show                       CShowR          GET POST        !free
+  /show                       CShowR          GET             !free
+  /register                   CRegisterR          POST        !time
   /edit                       CEditR          GET POST
   /corrections                CourseCorrectionsR   GET POST
   /ex                         SheetListR      GET             !registered !materials
@@ -60,9 +62,11 @@
     !/sub/new                   SubmissionNewR GET POST        !timeANDregistered
     !/sub/own                   SubmissionOwnR GET             !free
     !/sub/#CryptoFileNameSubmission SubmissionR    GET POST        !owner !corrector
+    /correctors                 SCorrR        GET POST
 
 /corrections  CorrectionsR GET POST !free
 
+
 -- TODO below
 !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
 !/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated

src/CryptoID.hs

@@ -39,7 +39,7 @@ instance PathPiece UUID where
 
 instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
   fromPathPiece = fmap CI.mk . fromPathPiece
-  toPathPiece = toPathPiece . CI.original
+  toPathPiece = toPathPiece . CI.foldedCase
 
 instance {-# OVERLAPS #-} PathMultiPiece FilePath where
   fromPathMultiPiece = Just . unpack . intercalate "/"
@@ -47,12 +47,13 @@ instance {-# OVERLAPS #-} PathMultiPiece FilePath where
   
 instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
   fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
-  toPathMultiPiece = toPathMultiPiece . CI.original
+  toPathMultiPiece = toPathMultiPiece . CI.foldedCase
 
 
 -- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
              , ''FileId
+             , ''UserId
              ]
 {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
 

src/Foundation.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -236,12 +235,13 @@ adminAP = APDB $ \case
 
 
 knownTags :: Map (CI Text) AccessPredicate
-knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
+knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId
   [("free", trueAP)
   ,("deprecated", APHandler $ \r -> do
       $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
       addMessageI "error" MsgDeprecatedRoute
-      return Authorized
+      allow <- appAllowDeprecated . appSettings <$> getYesod
+      return $ bool (Unauthorized "Deprecated Route") Authorized allow
     )
   ,("lecturer", APDB $ \case
       CourseR tid csh _ -> exceptT return return $ do
@@ -289,20 +289,28 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
            return Authorized
    )
   ,("time", APDB $ \case
-       CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
+      CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
-         Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
+        Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
-         Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
+        Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
-         cTime <- liftIO getCurrentTime
+        cTime <- liftIO getCurrentTime
-         let started = sheetActiveFrom <= cTime  ||  NTop sheetVisibleFrom <= (NTop $ Just cTime)
+        let started = sheetActiveFrom <= cTime  ||  NTop sheetVisibleFrom <= (NTop $ Just cTime)
-         case subRoute of
+        case subRoute of
-           SFileR SheetExercise _ -> guard started
+          SFileR SheetExercise _ -> guard started
-           SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
+          SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
-           SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
+          SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
-           SFileR SheetMarking  _ -> mzero -- only for correctors and lecturers
+          SFileR SheetMarking  _ -> mzero -- only for correctors and lecturers
-           SubmissionNewR         -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+          SubmissionNewR         -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
-           _ -> guard started
+          _ -> guard started
-         return Authorized
+        return Authorized
-       r -> do
+
+      CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
+        Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
+        cTime <- (NTop . Just) <$> liftIO getCurrentTime
+        guard $ NTop courseRegisterFrom <= cTime
+             && NTop courseRegisterTo   >= cTime
+        return Authorized
+
+      r -> do
          $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
          unauthorizedI MsgUnauthorized
    )
@@ -406,9 +414,9 @@ instance Yesod UniWorX where
     -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
     yesodMiddleware handler = do
-      res <- defaultYesodMiddleware handler
       void . runMaybeT $ do
         route <- MaybeT getCurrentRoute
+        guardM . lift $ (== Authorized) <$> isAuthorized route False
         case route of -- update Course Favourites here
           CourseR tid csh _  -> do
             uid <- MaybeT maybeAuthId
@@ -431,7 +439,7 @@ instance Yesod UniWorX where
               lift $ mapM_ delete oldFavs
 
           _other -> return ()
-      return res
+      defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately
 
     defaultLayout widget = do
         master <- getYesod
@@ -568,7 +576,6 @@ instance Yesod UniWorX where
     makeLogger = return . appLogger
 
 
-
 -- Define breadcrumbs.
 instance YesodBreadcrumbs UniWorX where
   breadcrumb TermShowR = return ("Semester", Just HomeR)
@@ -579,38 +586,55 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (TermCourseListR term)    = return (toPathPiece term, Just TermShowR)
   breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term)
   breadcrumb  CourseNewR               = return ("Neu", Just CourseListR)
-  breadcrumb (CourseR _ _ CEditR)         = return ("Editieren", Just CourseListR)
+  breadcrumb (CourseR tid csh CEditR)  = return ("Editieren", Just $ CourseR tid csh CShowR)
 
   breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR)
   breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu",    Just $ CourseR tid csh SheetListR)
   breadcrumb (CSheetR tid csh shn SShowR) = return (shn,      Just $ CourseR tid csh SheetListR)
   breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit",   Just $ CSheetR tid csh shn SShowR)
   breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
+  breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR)
   breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
 
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
 
 
-  breadcrumb HomeR = return ("UniWorkY", Nothing)
+  breadcrumb HomeR        = return ("UniWorkY", Nothing)
-  breadcrumb (AuthR _) = return ("Login", Just HomeR)
+  breadcrumb (AuthR _)    = return ("Login", Just HomeR)
-  breadcrumb ProfileR = return ("Profile", Just HomeR)
+  breadcrumb ProfileR     = return ("Profile", Just HomeR)
   breadcrumb ProfileDataR = return ("Data", Just ProfileR)
   breadcrumb  _ = return ("home", Nothing)
 
 pageActions :: Route UniWorX -> [MenuTypes]
 pageActions (CourseR tid csh CShowR) =
   [ PageActionPrime $ MenuItem
-      { menuItemLabel = "Übungsblätter"
-      , menuItemIcon  = Nothing
-      , menuItemRoute = CourseR tid csh SheetListR
-      , menuItemAccessCallback' = return True
-      }
-  , PageActionPrime $ MenuItem
       { menuItemLabel = "Kurs Editieren"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid csh CEditR
       , menuItemAccessCallback' = return True
       }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Übungsblätter"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid csh SheetListR
+      , menuItemAccessCallback' = do --TODO always show for lecturer
+          let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid csh shn SShowR) False)
+          muid <- maybeAuthId
+          (sheets,lecturer) <- runDB $ do
+            cid <- getKeyBy404 $ CourseTermShort tid csh
+            sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
+            lecturer <- case muid of
+                Nothing    -> return False
+                (Just uid) -> existsBy $ UniqueLecturer uid cid
+            return (sheets,lecturer)
+          or2M (return lecturer) $ anyM sheets sheetRouteAccess
+      }
+  , PageActionSecondary $ MenuItem
+      { menuItemLabel = "Neues Übungsblatt anlegen"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid csh SheetNewR
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CourseR tid csh SheetListR) =
   [ PageActionPrime $ MenuItem
@@ -628,11 +652,17 @@ pageActions (CSheetR tid csh shn SShowR) =
       , menuItemAccessCallback' = return True -- TODO: check that no submission already exists
       }
   , PageActionPrime $ MenuItem
-      { menuItemLabel = "Abgabe"
+      { menuItemLabel = "Abgabe ansehen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CSheetR tid csh shn SubmissionOwnR
       , menuItemAccessCallback' = return True -- TODO: check that a submission already exists
       }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Korrektoren"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CSheetR tid csh shn SCorrR
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions TermShowR =
   [ PageActionPrime $ MenuItem

src/Handler/Admin.hs

@@ -58,3 +58,14 @@ postAdminTestR = do
     _other -> return ()
   getAdminTestR
 
+
+getAdminUserR :: CryptoUUIDUser -> Handler Html
+getAdminUserR uuid = do
+  uid <- decrypt uuid
+  User{..} <- runDB $ get404 uid
+  defaultLayout $
+    [whamlet|
+      <h1>TODO
+      <h2>Admin Page for User #{display userDisplayName}
+    |]
+

src/Handler/Course.hs

@@ -16,9 +16,9 @@ import Handler.Utils
 -- import Data.Time
 import qualified Data.Text as T
 import Data.Function ((&))
-import Yesod.Form.Bootstrap3
+-- import Yesod.Form.Bootstrap3
 
-import Colonnade hiding (fromMaybe)
+import Colonnade hiding (fromMaybe,bool)
 import Yesod.Colonnade
 
 import qualified Data.UUID.Cryptographic as UUID
@@ -79,7 +79,7 @@ getTermCourseListR tidini = do
 getCShowR :: TermId -> Text -> Handler Html
 getCShowR tid csh = do
   mbAid <- maybeAuthId
-  (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
+  (courseEnt,(schoolMB,participants,registered)) <- runDB $ do
       courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
       dependent <- (,,)
           <$> get (courseSchool course)               -- join
@@ -91,38 +91,45 @@ getCShowR tid csh = do
                                 return $ isJust regL)
       return $ (courseEnt,dependent)
   let course = entityVal courseEnt
-  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
+  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
+  registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid csh CRegisterR) True
   defaultLayout $ do
     setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")
 
-registerButton :: Bool -> Form ()
-registerButton registered = renderAForm FormStandard $
-      pure () <*  bootstrapSubmit regMsg
-  where
-    msg    = if registered then "Abmelden" else "Anmelden"
-    regMsg = msg :: BootstrapSubmit Text
 
-postCShowR :: TermId -> Text -> Handler Html
+registerForm :: Bool -> Maybe Text -> Form Bool
-postCShowR tid csh = do
+registerForm registered msecret extra = do
+  (msecretRes', msecretView) <- case msecret of
+    (Just _) | not registered -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing)
+    _ -> return (Nothing,Nothing)
+  (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
+  let widget = $(widgetFile "widgets/registerForm")
+  let msecretRes | Just res <- msecretRes' = Just <$> res
+                 | otherwise               = FormSuccess Nothing
+  return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
+
+
+postCRegisterR :: TermId -> Text -> Handler Html
+postCRegisterR tid csh = do
   aid <- requireAuthId
-  (cid, registered) <- runDB $ do
+  (cid, course, registered) <- runDB $ do
-      (Entity cid _) <- getBy404 $ CourseTermShort tid csh
+      (Entity cid course) <- getBy404 $ CourseTermShort tid csh
       registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
-      return (cid, registered)
+      return (cid, course, registered)
-  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered
+  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
   case regResult of
-    (FormSuccess _)
+    (FormSuccess codeOk)
       | registered -> do
           runDB $ deleteBy $ UniqueParticipant aid cid
           addMessage "info" "Sie wurden abgemeldet."
-      | otherwise  -> do
+      | codeOk -> do
           actTime <- liftIO $ getCurrentTime
           regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
           when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
+      | otherwise -> addMessage "danger" "Falsches Kennwort!"
     (_other) -> return () -- TODO check this!
-  -- redirect or not?! I guess not, since we want GET now
+  redirect $ CourseR tid csh CShowR
-  getCShowR tid csh
 
 getCourseNewR :: Handler Html
 getCourseNewR = do
@@ -174,11 +181,10 @@ courseEditHandler isGet course = do
             , courseTerm            = cfTerm     res
             , courseSchool          = cfSchool   res
             , courseCapacity        = cfCapacity res
-            , courseHasRegistration = cfHasReg   res
+            , courseRegisterSecret  = cfSecret   res
             , courseRegisterFrom    = cfRegFrom  res
             , courseRegisterTo      = cfRegTo    res
             , courseDeregisterUntil = Nothing -- TODO
-            , courseRegisterSecret  = Nothing -- TODO
             , courseMaterialFree    = True    -- TODO
             }
           case insertOkay of
@@ -230,11 +236,10 @@ courseEditHandler isGet course = do
                             ,  courseTerm            = cfTerm     res
                             ,  courseSchool          = cfSchool   res
                             ,  courseCapacity        = cfCapacity res
-                            ,  courseHasRegistration = cfHasReg   res
+                            ,  courseRegisterSecret  = cfSecret   res
                             ,  courseRegisterFrom    = cfRegFrom  res
                             ,  courseRegisterTo      = cfRegTo    res
                             ,  courseDeregisterUntil = Nothing -- TODO
-                            ,  courseRegisterSecret  = Nothing -- TODO
                             ,  courseMaterialFree    = True    -- TODO
                     }
                   )
@@ -263,7 +268,7 @@ data CourseForm = CourseForm
         , cfTerm     :: TermId
         , cfSchool   :: SchoolId
         , cfCapacity :: Maybe Int
-        , cfHasReg   :: Bool
+        , cfSecret   :: Maybe Text
         , cfRegFrom  :: Maybe UTCTime
         , cfRegTo    :: Maybe UTCTime
         }
@@ -282,7 +287,7 @@ courseToForm cEntity = CourseForm
         , cfTerm     = courseTerm               course
         , cfSchool   = courseSchool             course
         , cfCapacity = courseCapacity           course
-        , cfHasReg   = courseHasRegistration    course
+        , cfSecret   = courseRegisterSecret     course
         , cfRegFrom  = courseRegisterFrom       course
         , cfRegTo    = courseRegisterTo         course
         }
@@ -309,9 +314,15 @@ newCourseForm template = identForm FIDcourse $ \html -> do
       <*> areq termActiveField        (fsb "Semester")       (cfTerm     <$> template)
       <*> areq schoolField            (fsb "Institut")       (cfSchool   <$> template)
       <*> aopt (natField "Kapazität") (fsb "Kapazität")      (cfCapacity <$> template)
-      <*> areq checkBoxField          (fsb "Anmeldung")      (cfHasReg   <$> template)
+      <*> aopt textField              (fslpI MsgCourseSecret "beliebige Zeichenkette"
-      <*> aopt utcTimeField           (fsb "Anmeldung von:") (cfRegFrom  <$> template)
+            & setTooltip "Optional: Anmeldung zum Kurs benötigt ein Passwort")
-      <*> aopt utcTimeField           (fsb "Anmeldung bis:") (cfRegTo    <$> template)
+                                                             (cfSecret   <$> template)
+      <*> aopt utcTimeField           (fslpI MsgRegisterFrom "(ohne Datum keine Anmeldung möglich)"
+            & setTooltip "Ohne Datum ist keine Anmeldung zu diesem Kurs möglich!")
+                                                             (cfRegFrom  <$> template)
+      <*> aopt utcTimeField           (fslpI MsgRegisterTo   "(ohne Datum unbegrenzte Anmeldung möglich)"
+            & setTooltip "Die Anmeldung darf ohne Begrenzung sein")
+                                                             (cfRegTo    <$> template)
       <*  submitButton
     return $ case result of
       FormSuccess courseResult
@@ -338,20 +349,12 @@ validateCourse :: CourseForm -> [Text]
 validateCourse (CourseForm{..}) =
   [ msg | (False, msg) <-
     [
-      ( cfRegFrom <= cfRegTo
+      ( NTop cfRegFrom <= NTop cfRegTo
       , "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
       )
-    ,
 --    No starting date is okay: effective immediately
 --       ( cfHasReg <= (isNothing cfRegFrom)
 --       , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
 --       )
 --     ,
-      ( cfHasReg == (isJust cfRegTo)
-      , "Ende des Anmeldezeitraums angeben oder Anmeldungen deaktivieren"
-      )
-    ,
-      ( isJust cfRegFrom <= cfHasReg
-      , "Anmeldungen aktivieren oder Anmeldezeitraum löschen"
-      )
   ] ]

src/Handler/CryptoIDDispatch.hs

@@ -54,7 +54,11 @@ instance CryptoRoute (CI FilePath) SubmissionId where
       Course{..} <- get404 sheetCourse
       return (courseTerm, courseShorthand, sheetName)
     return $ CSheetR tid csh shn $ SubmissionR cID
-  
+
+instance CryptoRoute UUID UserId where
+  cryptoIDRoute _ (CryptoID -> cID) = do
+    (_ :: UserId) <- decrypt cID
+    return $ AdminUserR cID
 
 class Dispatch ciphertext (x :: [*]) where
   dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
@@ -79,6 +83,7 @@ getCryptoUUIDDispatchR :: UUID -> Handler ()
 getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
   where
     p :: Proxy '[ SubmissionId
+                , UserId
                 ]
     p = Proxy
 

src/Handler/Home.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -15,6 +14,8 @@ module Handler.Home where
 import Import
 import Handler.Utils
 
+import qualified Data.Map as Map
+
 import Data.Time
 -- import qualified Data.Text as T
 -- import Yesod.Form.Bootstrap3
@@ -56,10 +57,10 @@ homeAnonymous = do
   let tableData :: E.SqlExpr (Entity Course)
                   -> E.SqlQuery (E.SqlExpr (Entity Course))
       tableData course = do
-            E.where_ $ course E.^. CourseHasRegistration E.==. E.val True
+            E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom)
-                 E.&&. course E.^. CourseRegisterFrom    E.<=. E.val (Just cTime)
+                E.&&.  (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
-                 E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
+                E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
-                        E.||.         (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
+                        E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
             E.limit nrSheetDeadlines
             E.orderBy [ E.asc  $ course E.^. CourseRegisterTo
                       , E.desc $ course E.^. CourseShorthand
@@ -74,13 +75,14 @@ homeAnonymous = do
             let tid = courseTerm course
                 csh = courseShorthand course
             cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
-        , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
+        , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
             textCell $ display $ courseRegisterTo course
         ]
   courseTable <- dbTable def $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
-    , dbtSorting   =  [ ( "term"
+    , dbtSorting   = Map.fromList
+                      [ ( "term"
                         , SortColumn $ \(course) -> course E.^. CourseTerm
                         )
                       , ( "course"
@@ -147,7 +149,8 @@ homeUser uid = do
   sheetTable <- dbTable def $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
-    , dbtSorting   =  [ ( "term"
+    , dbtSorting   = Map.fromList
+                      [ ( "term"
                         , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ ) -> course E.^. CourseTerm
                         )
                       , ( "course"

src/Handler/Profile.hs

@@ -28,7 +28,7 @@ makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template = identForm FIDsettings $ \html -> do
     let themeList = [(display t,t) | t <- allThemes]
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
-      <$> areq (natField "Favoriten") -- TODO: natFieldI not working here
+      <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
       <*> areq (selectFieldList themeList)
             (fslI  MsgTheme         ) (stgTheme         <$> template)
@@ -58,8 +58,9 @@ getProfileR = do
                                       , OffsetBy $ stgMaxFavourties
                                       ]
             mapM_ delete oldFavs
-
         addMessageI "info" $ MsgSettingsUpdate
+        redirect ProfileR -- TODO: them change does not happen without redirect
+
     (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
     _ -> return ()
 

src/Handler/Sheet.hs

@@ -8,8 +8,12 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE MultiWayIf, LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
 
 module Handler.Sheet where
 
@@ -23,9 +27,10 @@ import Handler.Utils.Zip
 import qualified Data.Text as T
 -- import Data.Function ((&))
 --
-import Colonnade hiding (fromMaybe, singleton)
+import Colonnade hiding (fromMaybe, singleton, bool)
 import qualified Yesod.Colonnade as Yesod
---
+import Text.Blaze (text)
+-- 
 import qualified Data.UUID.Cryptographic as UUID
 import qualified Data.Conduit.List as C
 
@@ -33,12 +38,24 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 
 import Control.Monad.Writer (MonadWriter(..), execWriterT)
+import Control.Monad.Trans.RWS.Lazy (RWST, local)
+
+import qualified Text.Email.Validate as Email
+
+import qualified Data.List as List
 
 import Network.Mime
 
+import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
+import Data.Map (Map, (!), (!?))
+import qualified Data.Map as Map
+
+import Control.Lens
+import Utils.Lens
+
 
 instance Eq (Unique Sheet) where
   (CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
@@ -65,7 +82,6 @@ data SheetForm = SheetForm
       , sfSolutionFrom :: Maybe UTCTime
       , sfSolutionF    :: Maybe FileInfo
       -- Keine SheetId im Formular!
-      , sfCorrectors   :: [(UserId,Load)]
       }
 
 
@@ -93,7 +109,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <*> fileAFormOpt        (fsb "Hinweis")
       <*> aopt utcTimeField   (fsb "Lösung ab")   (sfSolutionFrom <$> template)
       <*> fileAFormOpt        (fsb "Lösung")
-      <*> formToAForm (correctorForm msId (maybe [] sfCorrectors template))
       <*  submitButton
     return $ case result of
       FormSuccess sheetResult
@@ -124,16 +139,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
         -- TODO: continue validation here!!!
       ] ]
 
-correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX])
-correctorForm _msid templates = return mempty -- TODO deprecated
-  -- Datenbank UserId -> UserName
-  -- Eingabelist für Colonnade
-     -- enthält die benötigten Felder
-  -- FormResult konstruieren
-  -- Eingabebox für Korrektor hinzufügen
-  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
-
-
 -- List Sheets
 getSheetListCID :: CourseId -> Handler Html
 getSheetListCID cid = getSheetList =<<
@@ -160,7 +165,7 @@ getSheetList courseEnt = do
   let colBase = mconcat
         [ headed "Blatt"       $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR
         , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
-        , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
+        , headed "Abgabe lbis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
         , headed "Bewertung"   $ toWgt . display . sheetType . snd3
         ]
   let colAdmin = mconcat -- only show edit button for allowed course assistants
@@ -178,7 +183,7 @@ getSheetList courseEnt = do
         then colBase `mappend` colAdmin
         else colBase
   defaultLayout $ do
-    setTitle $ toHtml $ T.append "Übungsblätter " csh
+    setTitle $ toHtml $ csh <> " Übungsblätter"
     if null sheets
       then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
       else Yesod.encodeWidgetTable tableDefault colSheets sheets
@@ -304,7 +309,6 @@ getSEditR tid csh shn = do
         , sfHintF        = Nothing -- TODO
         , sfSolutionFrom = sheetSolutionFrom
         , sfSolutionF    = Nothing -- TODO
-        , sfCorrectors   = [] -- TODO read correctors from list
         }
   let action newSheet = do
         replaceRes <- myReplaceUnique sid $ newSheet
@@ -413,3 +417,201 @@ insertSheetFile' sid ftype fs = do
     finsert (Right file) = lift $ do
       fid <- insert file
       void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
+
+  
+data CorrectorForm = CorrectorForm
+  { cfUserId :: UserId
+  , cfUserName :: Text
+  , cfResult :: FormResult Load
+  , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
+  }
+
+type Loads = Map UserId Load
+
+defaultLoads :: SheetId -> DB Loads
+-- ^ Generate `Loads` in such a way that minimal editing is required
+--
+-- For every user, that ever was a corrector for this course, return their last `Load`.
+-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
+defaultLoads shid = do
+  cId <- sheetCourse <$> getJust shid
+  fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
+    E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+
+    let creationTime = E.sub_select . E.from $ \sheetEdit -> do
+          E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
+          return . E.min_ $ sheetEdit E.^. SheetEditTime
+
+    E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
+    
+    E.orderBy [E.desc creationTime]
+  
+    return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad)
+  where
+    toMap :: [(E.Value UserId, E.Value Load)] -> Loads
+    toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
+
+
+correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
+correctorForm shid = do
+  cListIdent <- newFormIdent
+  let
+    guardNonDeleted :: UserId -> Handler (Maybe UserId)
+    guardNonDeleted uid = do
+      cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser
+      deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
+      return $ bool Just (const Nothing) (isJust deleted) uid
+  formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
+  let
+    currentLoads :: DB Loads
+    currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
+  (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
+  loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
+    | Map.null currentLoads'
+    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted)
+    | otherwise              -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
+
+  deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
+
+  let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
+      didDelete = any (flip Set.member deletions) formCIDs
+
+  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
+  let
+    tutorField :: Field Handler [Text]
+    tutorField = multiEmailField
+      { fieldView = \theId name attrs val isReq -> asWidgetT $ do
+          listIdent <- newIdent
+          userId <- handlerToWidget requireAuthId
+          previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
+            E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+            E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+            E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
+            return $ user E.^. UserEmail
+          [whamlet|
+            $newline never
+            <input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
+            <datalist id=#{listIdent}>
+              $forall E.Value prev <- previousCorrectors
+                <option value=#{prev}>
+          |]
+      }
+  (addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
+
+  loads <- case addTutRes of
+    FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
+      mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
+      case mUid of
+        Nothing  -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
+        Just uid
+          | not (Map.member uid loads') -> return $ Map.insert uid mempty loads''
+          | otherwise                   -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
+    FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
+    _ -> return loads''
+
+  let deletions' = deletions `Set.difference` Map.keysSet loads
+  
+  names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
+    E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys  loads)
+    return $ (user E.^. UserId, user E.^. UserDisplayName)
+    
+  let
+    constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm
+    constructFields (uid, uname, Load{..}) = do
+      cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
+      let
+        fs name = ""
+          { fsName = Just $ tshow ciphertext <> "-" <> name
+          }
+        rationalField = convertField toRational fromRational doubleField
+
+      (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
+      (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
+      (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
+      let
+        cfResult :: FormResult Load
+        cfResult = Load <$> tutRes' <*> propRes
+        tutRes'
+          | FormSuccess True <- byTutRes  = Just <$> countTutRes
+          | otherwise                     = Nothing <$ byTutRes
+        cfUserId = uid
+        cfUserName = uname
+      return CorrectorForm{..}
+
+  corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
+
+  mr <- getMessageRender
+
+  $logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
+
+  let
+    corrColonnade = mconcat
+      [ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
+      , headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
+      , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
+      , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
+      ]
+    corrResults
+      | FormSuccess (Just es) <- addTutRes
+      , not $ null es = FormMissing
+      | didDelete = FormMissing
+      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
+                                                  | CorrectorForm{..} <- corrData
+                                                  ]
+    idField CorrectorForm{..} = do
+      cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
+      toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
+
+    delField uid = do
+      cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
+      toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
+
+  return (corrResults, [ countTutView
+                       , FieldView
+                           { fvLabel = text $ mr MsgCorrectors
+                           , fvTooltip = Nothing
+                           , fvId = ""
+                           , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions
+                           , fvErrors = Nothing
+                           , fvRequired = True
+                           }
+                       , addTutView
+                           { fvInput = [whamlet|
+                               <div>
+                                 ^{fvInput addTutView}
+                                 <button type=submit formnovalidate>Hinzufügen
+                             |]
+                           }
+                       ])
+  
+  -- Eingabebox für Korrektor hinzufügen
+  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
+
+getSCorrR, postSCorrR :: TermId
+                      -> Text -- ^ Course shorthand
+                      -> Text -- ^ Sheet name
+                      -> Handler Html
+postSCorrR = getSCorrR
+getSCorrR tid@(unTermKey -> tident) csh shn = do
+  Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
+
+  ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+
+  case res of
+    FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+    FormSuccess res -> runDB $ do
+      deleteWhere [SheetCorrectorSheet ==. shid]
+      insertMany_ $ Set.toList res
+      addMessageI "success" MsgCorrectorsUpdated
+    FormMissing -> return ()
+
+  let
+    formTitle = MsgSheetCorrectorsTitle tident csh shn
+    formText  = Nothing :: Maybe (SomeMessage UniWorX)
+    actionUrl = CSheetR tid csh shn SCorrR
+    -- actionUrl = CSheetR tid csh shn SShowR
+  defaultLayout $ do
+    setTitleI $ MsgSheetCorrectorsTitle tident csh shn
+    $(widgetFile "formPageI18n")

src/Handler/Users.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -34,7 +35,10 @@ getUsersR = do
           Nothing -> "???"
           (Just school) -> schoolShorthand school
   let colonnadeUsers = mconcat $
-        [ headed "User" $ text2widget.userDisplayName.entityVal.fst3
+        [ headed "User" $ \u -> do
+            cID <- encrypt $ entityKey $ fst3 u
+            let name = display $ userDisplayName $ entityVal $ fst3 u
+            [whamlet|<a href=@{AdminUserR cID}>#{name}|]
         , headed "Admin for Schools"   $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool   .entityVal) $ snd3 u)
         , headed "Lecturer at Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u)
         ]

src/Handler/Utils/Form.hs

@@ -52,7 +52,7 @@ import Control.Monad.Writer.Class
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 
@@ -104,8 +104,8 @@ instance PathPiece BtnDelete where    -- for displaying the button only, not rea
   fromPathPiece = readFromPathPiece
 
 instance Button BtnDelete where
-  label BtnDelete = "Löschen"
+  label BtnDelete = [whamlet|_{MsgBtnDelete}|]
-  label BtnAbort  = "Abrechen"
+  label BtnAbort  = [whamlet|_{MsgBtnAbort}|]
 
   cssClass BtnDelete = BCDanger
   cssClass BtnAbort  = BCDefault
@@ -119,10 +119,26 @@ instance PathPiece SubmitButton where
   fromPathPiece = readFromPathPiece
 
 instance Button SubmitButton where
-  label BtnSubmit = "Submit"
+  label BtnSubmit = [whamlet|_{MsgBtnSubmit}|]
 
   cssClass BtnSubmit = BCPrimary
 
+
+data RegisterButton = BtnRegister  | BtnDeregister
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece RegisterButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button RegisterButton where
+  label BtnRegister   = [whamlet|_{MsgBtnRegister}|]
+  label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
+
+  cssClass BtnRegister   = BCPrimary
+  cssClass BtnDeregister = BCDanger
+
+
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
 -- data LinkButton = LinkButton (Route UniWorX)
 --   deriving (Enum, Eq, Ord, Bounded, Read, Show)
@@ -142,7 +158,7 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 simpleLink :: Widget -> Route UniWorX -> Widget
 simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
 
-buttonField :: Button a => a -> Field Handler a
+buttonField :: Button a => a -> Field Handler a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
 buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
   where
     fieldEnctype = UrlEncoded
@@ -231,7 +247,7 @@ buttonForm csrf = do
 ------------
 
 
-natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => FormMessage -> Field m i
+natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
 natFieldI msg = checkBool (>= 0) msg intField
 
 natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
@@ -471,7 +487,7 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass)
 setTooltip :: String -> FieldSettings site -> FieldSettings site
 setTooltip tt fs
   | null tt   = fs { fsTooltip = Nothing }
-  | otherwise = fs { fsTooltip = Just $ fromString tt }
+  | otherwise = fs { fsTooltip = Just $ fromString tt, fsAttrs=("info",fromString tt):(fsAttrs fs) }
 
 optionsPersistCryptoId :: forall site backend a msg.
                           ( YesodPersist site

src/Model/Types.hs

@@ -101,7 +101,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
     = Load { byTutorial :: Maybe Bool  -- ^ Just all from Tutorial, True if counting towards overall workload
            , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
            }
-  deriving (Show, Read, Eq)
+  deriving (Show, Read, Eq, Ord)
 derivePersistField "Load"
 
 instance Semigroup Load where

src/Settings.hs

@@ -71,6 +71,8 @@ data AppSettings = AppSettings
 
     , appAuthDummyLogin         :: Bool
     -- ^ Indicate if auth dummy login should be enabled.
+    , appAllowDeprecated        :: Bool
+    -- ^ Indicate if deprecated routes are accessible for everyone
     }
 
 instance FromJSON AppSettings where
@@ -104,6 +106,7 @@ instance FromJSON AppSettings where
         appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
 
         appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= defaultDev
+        appAllowDeprecated        <- o .:? "allow-deprecated"      .!= defaultDev
 
         return AppSettings {..}
 

src/Utils.hs

@@ -13,6 +13,7 @@ module Utils
 import ClassyPrelude.Yesod
 
 import Data.List (foldl)
+import Data.Foldable as Fold
 import qualified Data.Char as Char
 
 import Utils.DB as Utils
@@ -211,3 +212,38 @@ shortCircuitM sc mx my op = do
   case sc x of
     True  -> return x
     False -> op <$> pure x <*> my
+
+
+guardM :: MonadPlus m => m Bool -> m ()
+guardM f = guard =<< f
+
+-- Some Utility Functions from Agda.Utils.Monad
+-- | Monadic if-then-else.
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM c m m' =
+    do  b <- c
+        if b then m else m'
+
+-- | @ifNotM mc = ifM (not <$> mc)@
+ifNotM :: Monad m => m Bool -> m a -> m a -> m a
+ifNotM c = flip $ ifM c
+
+-- | Lazy monadic conjunction.
+and2M :: Monad m => m Bool -> m Bool -> m Bool
+and2M ma mb = ifM ma mb (return False)
+
+andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+andM = Fold.foldr and2M (return True)
+
+allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+allM xs f = andM $ fmap f xs
+
+-- | Lazy monadic disjunction.
+or2M :: Monad m => m Bool -> m Bool -> m Bool
+or2M ma mb = ifM ma (return True) mb
+
+orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+orM = Fold.foldr or2M (return False)
+
+anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+anyM xs f = orM $ fmap f xs

src/Utils/DB.hs

@@ -25,6 +25,10 @@ getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity
   => Unique record -> ReaderT backend m (Key record)
 getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
 
+existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+  => Unique record -> ReaderT backend m Bool
+existsBy = fmap isJust . getBy
+
 
 myReplaceUnique
     :: (MonadIO m

start.sh

@@ -4,5 +4,6 @@ unset HOST
 export DETAILED_LOGGING=true
 export LOG_ALL=true
 export DUMMY_LOGIN=true
+export ALLOW_DEPRECATED=true
 
 exec -- stack exec -- yesod devel

templates/course.hamlet

@@ -1,54 +1,53 @@
 <div .container>
-  <table>
+  <div .scrolltable>
-    $maybe school <- schoolMB
+    <table .table.table--striped.table--hover.table--vertical>
-      <tr>
+      $maybe school <- schoolMB
-        <th #school>Fakultät/Institut
+        <tr .table__row>
+          <th #school>Fakultät/Institut
+          <td>
+            #{schoolName school}
+      $maybe descr <- courseDescription course
+        <tr .table__row>
+          <th #description>Beschreibung
+          <td>
+            #{descr}
+      $maybe link <- courseLinkExternal course
+        <tr .table__row>
+          <th #website>Website
+          <td>
+            <a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
+      <tr .table__row>
+        <th #participants>Teilnehmer
         <td>
-          #{schoolName school}
+          #{participants}
-    $maybe descr <- courseDescription course
+          $maybe capacity <- courseCapacity course
-      <tr>
+            \ von #{capacity}
-        <th #description>Beschreibung
+      <tr .table__row>
+        <th #registration>Anmeldezeitraum
         <td>
-          #{descr}
+          $maybe regFrom <- courseRegisterFrom course
-    $maybe link <- courseLinkExternal course
+            #{formatTimeGerWD regFrom}
-      <tr>
+          $maybe regTo   <- courseRegisterTo   course
-        <th #website>Website
+            \ bis #{formatTimeGerWD regTo}
+
+      <tr .table__row>
+        <th>
         <td>
-          <a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
+          $if registrationOpen
-    <tr>
+            <div .course__registration.container>
-      <th #participants>Teilnehmer
+              <form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}>
-      <td>
+                $# regWidget is defined through templates/widgets/registerForm
-        #{participants}
+                ^{regWidget}
-        $maybe capacity <- courseCapacity course
-          \ von #{capacity}
-    <tr>
-      <th #registration>Anmeldezeitraum
-      <td>
-        $maybe regFrom <- courseRegisterFrom course
-          #{formatTimeGerWD regFrom}
-        $maybe regTo   <- courseRegisterTo   course
-          \ bis #{formatTimeGerWD regTo}
 
-    <tr>
+$# <div .container>
-      <th>
+$#   <div .tab-group>
-      <td>
+$#     <div .tab data-tab-name="Übungsblätter">
-        $# if allowed to register
+$#       ^{modal "#modal-toggler__new-sheet" Nothing}
-        <div .course__registration.container>
+$#       <h3 .tab-title>Übungsblätter
-          <button class="btn btn-primary">
+$#       <h1>TODO: Sortierbare Tabelle der bisherigen Übungsblätter
-            <a href="#">TODO: Kurs-Anmeldung
+$#     <div .tab data-tab-name="Übungsgruppen">
-
+$#       <h3 .tab-title>Übungsgruppen
-  $# <form method=post action=@{CourseR tid csh CShow} enctype=#{regEnctype}>
+$#       <h1>TODO: Sortierbare Tabelle der Übungsgruppen
-  $#   ^{regWidget}
+$#     <div .tab data-tab-name="Klausuren">
-
+$#       <h3 .tab-title>Klausuren
-<div .container>
+$#       <div>...
-  <div .tab-group>
-    <div .tab data-tab-name="Übungsblätter">
-      ^{modal "#modal-toggler__new-sheet" Nothing}
-      <h3 .tab-title>Übungsblätter
-      <h1>TODO: Sortierbare Tabelle der bisherigen Übungsblätter
-    <div .tab data-tab-name="Übungsgruppen">
-      <h3 .tab-title>Übungsgruppen
-      <h1>TODO: Sortierbare Tabelle der Übungsgruppen
-    <div .tab data-tab-name="Klausuren">
-      <h3 .tab-title>Klausuren
-      <div>...

templates/course.lucius

@@ -1,7 +1,3 @@
-.course__registration {
-  margin-top: 20px;
-}
-
 th {
   vertical-align: top;
   text-align: left;

templates/default-layout.lucius

@@ -118,11 +118,11 @@ h1 {
 }
 h2 {
   font-size: 24px;
-  margin: 10px 0 5px;
+  margin: 10px 0;
 }
 h3 {
   font-size: 20px;
-  margin: 5px 0;
+  margin: 10px 0;
 }
 h4 {
   font-size: 16px;

templates/formPageI18n.hamlet

@@ -1,5 +1,5 @@
 $maybe text <- formText
-  <p>
+  <h3>
     _{text}
 <form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
-   ^{formWidget}                        
+   ^{formWidget}

templates/standalone/inputs.lucius

@@ -1,7 +1,4 @@
 /* GENERAL STYLES FOR FORMS */
-form {
-  margin: 20px 0;
-}
 
 /* FORM GROUPS */
 .form-group {
@@ -12,7 +9,7 @@ form {
   grid-gap: 5px;
   justify-content: flex-start;
   align-items: flex-start;
-  padding: 4px;
+  padding: 4px 0;
   border-left: 2px solid transparent;
 
   + .form-group {
@@ -75,10 +72,16 @@ input[type*="time"] {
   padding: 4px 13px;
 }
 
+input[type="number"] {
+  width: 100px;
+  text-align: right;
+}
+
 input[type*="date"],
-input[type*="time"] {
+input[type*="time"],
+.flatpickr-input[type="text"] {
   width: 50%;
-  min-width: 240px;
+  width: 250px;
 }
 
 input[type="text"]:focus,
@@ -130,6 +133,7 @@ option {
   border-radius: 2px;
   outline: 0;
   color: #363636;
+  min-width: 200px;
   background-color: #f3f3f3;
   box-shadow: inset 0 1px 2px 1px rgba(50,50,50,.05);
 }
@@ -206,7 +210,7 @@ input[type="checkbox"]:checked::after {
   }
 
   :checked + label {
-    background-color: var(--color-light);
+    background-color: var(--color-primary);
     text-decoration: underline;
   }
 
@@ -249,9 +253,7 @@ input[type="checkbox"]:checked::after {
   padding: 10px 17px;
   border-radius: 3px;
 }
-.file-input__list {
 
-}
 .file-input__input--hidden {
   display: none;
 }

templates/widgets/navbar.julius

@@ -18,8 +18,7 @@
     }
 
     function update() {
-      var sticky = window.scrollY > 0;
+      var sticky = window.scrollY > 30;
-      sticky = sticky && window.innerHeight < (document.scrollingElement.scrollHeight - 200);
       nav.classList.toggle('navbar--sticky', sticky);
       ticking = false;
     }
@@ -28,7 +27,5 @@
 })();
 
 document.addEventListener('DOMContentLoaded', function () {
-
+  // utils.stickynav(document.querySelector('.js-sticky-navbar'));
-  utils.stickynav(document.querySelector('.js-sticky-navbar'));
-
 });

templates/widgets/navbar.lucius

@@ -208,3 +208,19 @@
     height: var(--header-height-collapsed);
   }
 }
+
+@media (max-height: 768px) {
+
+  .navbar,
+  .navbar__pushdown {
+    height: var(--header-height-collapsed);
+  }
+
+  .navbar__link-wrapper {
+    height: var(--header-height-collapsed);
+  }
+
+  .navbar__logo {
+    top: 5px;
+  }
+}

templates/widgets/registerForm.hamlet

@@ -0,0 +1,8 @@
+$# extra protects us against CSRF
+#{extra}
+$# Maybe display textField for passcode
+$maybe secretView <- msecretView
+  ^{fvInput secretView}
+$# Always display register/deregister button
+^{fvInput btnView}
+