Merge branch 'master' into course-teaser

CHANGELOG.md

@@ -2,6 +2,49 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+### [1.4.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v1.4.0...v1.4.1) (2019-07-04)
+
+
+
+## [1.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v1.3.0...v1.4.0) (2019-07-03)
+
+
+### Bug Fixes
+
+* **home:** fix build ([551c4cb](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/551c4cb))
+* **massinput:** properly render massInputList ([7c28448](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7c28448))
+
+
+### Features
+
+* **exam:** audit exam registrations ([31931e7](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/31931e7))
+* **exam:** save registration timestamp ([78e4369](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/78e4369))
+
+
+
+## [1.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v1.1.0...v1.3.0) (2019-07-03)
+
+
+### Features
+
+* **home:** show immediate exams on home page ([242cff3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/242cff3))
+
+
+
+## [1.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v1.0.0...v1.1.0) (2019-07-03)
+
+
+### Bug Fixes
+
+* **displayable:** fixed faulty display of db keys (SchoolId, TermId) ([c7312e8](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c7312e8))
+
+
+### Features
+
+* **exams:** add extremely rudimentary registration table ([31e6b72](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/31e6b72))
+
+
+
 ## 1.0.0 (2019-07-03)
 
 

build.sh

@@ -1,4 +1,7 @@
 #!/usr/bin/env bash
 
-exec -- stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@
+set -e
-echo Build task completed.
+
+echo "Building..."
+stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@
+echo "Done."

frontend/src/utils/tooltips/tooltips.scss

@@ -86,3 +86,10 @@
     }
   }
 }
+
+
+/* fix font color when used in tableheaders */
+th .tooltip__content {
+  color: var(--color-font);
+  font-weight: normal;
+}

messages/uniworx/de.msg

@@ -356,6 +356,7 @@ TokensResetSuccess: Authorisierungs-Tokens invalidiert
 
 HomeOpenCourses: Kurse mit offener Registrierung
 HomeUpcomingSheets: Anstehende Übungsblätter
+HomeUpcomingExams: Bevorstehende Klausuren
 
 NumCourses num@Int64: #{num} Kurse
 CloseAlert: Schliessen
@@ -448,6 +449,7 @@ RatingPercent: Erreicht
 RatingFiles: Korrigierte Dateien
 PointsNotPositive: Punktzahl darf nicht negativ sein
 PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{maxPoints} sein
+PointsTooLow minPoints@Points: Punktzahl darf nicht kleiner als #{minPoints} sein
 RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
 ColumnRatingPoints: Punktzahl
 Pseudonyms: Pseudonyme
@@ -489,6 +491,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget
 
 NoTableContent: Kein Tabelleninhalt
 NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
+NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Klausur mit offener Registrierung in Ihren Kursen
 
 AdminHeading: Administration
 AdminUserHeading: Benutzeradministration
@@ -864,6 +867,7 @@ MenuTutorialComm: Mitteilung an Teilnehmer
 MenuExamList: Klausuren
 MenuExamNew: Neue Klausur anlegen
 MenuExamEdit: Bearbeiten
+MenuExamUsers: Teilnehmer
 
 AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
@@ -1165,3 +1169,5 @@ ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
 
 VersionHistory: Versionsgeschichte
 KnownBugs: Bekannte Bugs
+
+ExamUsersHeading: Klausurteilnehmer

models/audit

@@ -0,0 +1,12 @@
+-- Table recording all significant changes of database-state for auditing purposes
+TransactionLog
+  time UTCTime
+  instance InstanceId
+  initiator UserIdent Maybe -- Case-insensitive user-identifier associated with performing this action
+  remote IP Maybe -- Remote party that triggered this action via HTTP
+  info Value -- JSON-encoded `Transaction`
+-- Best guess of users affected by a change in database-state at time of transaction
+TransactionLogAffected
+  transaction TransactionLogId
+  user UserIdent -- Case-insensitive user-identifier
+  UniqueTransactionLogAffected transaction user

models/exams

@@ -34,6 +34,7 @@ ExamRegistration
   exam ExamId
   user UserId
   occurrence ExamOccurrenceId Maybe
+  time UTCTime default=now()
   UniqueExamRegistration exam user
 ExamPartResult
   examPart ExamPartId

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "1.0.0",
+  "version": "1.4.1",
   "description": "",
   "keywords": [],
   "author": "",
@@ -85,6 +85,7 @@
     "webpack-cli": "^3.3.4"
   },
   "dependencies": {
-    "flatpickr": "^4.5.7"
+    "flatpickr": "^4.5.7",
+    "npm": "^6.9.2"
   }
 }

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 1.0.0
+version: 1.4.1
 
 dependencies:
   # Due to a bug in GHC 8.0.1, we block its usage
@@ -118,6 +118,8 @@ dependencies:
   - lattices
   - hsass
   - semigroupoids
+  - http-types
+  - ip
   - jose-jwt
   - mono-traversable
   - lens-aeson
@@ -204,6 +206,7 @@ library:
         ghc-options:
           - -O0
           - -ddump-splices
+          - -ddump-to-file
         cpp-options: -DDEVELOPMENT
       else:
         ghc-options:

src/Audit.hs

@@ -0,0 +1,84 @@
+module Audit
+  ( module Audit.Types
+  , AuditException(..)
+  , audit, audit'
+  , AuditRemoteException(..)
+  , getRemote
+  ) where
+
+
+import Import.NoModel
+import Model
+import Database.Persist.Sql
+import Audit.Types
+
+import Utils.Lens
+import qualified Network.Wai as Wai
+import qualified Network.Socket as Wai
+
+import qualified Net.IP as IP
+
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+
+data AuditRemoteException
+  = ARUnsupportedSocketKind
+  deriving (Show, Generic, Typeable)
+instance Exception AuditRemoteException
+
+
+getRemote :: (MonadHandler m, MonadThrow m) => m IP
+getRemote = do
+  wai <- waiRequest
+  case Wai.remoteHost wai of
+    Wai.SockAddrInet _ hAddr -> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr in return $ IP.ipv4 b1 b2 b3 b4
+    Wai.SockAddrInet6 _ _ hAddr _ -> let (w1, w2, w3, w4, w5, w6, w7, w8) = Wai.hostAddress6ToTuple hAddr in return $ IP.ipv6 w1 w2 w3 w4 w5 w6 w7 w8
+    _other -> throwM ARUnsupportedSocketKind
+
+
+data AuditException
+  = AuditRemoteException AuditRemoteException
+  | AuditUserNotFound UserId
+  deriving (Show, Generic, Typeable)
+instance Exception AuditException
+
+
+audit :: ( AuthId site ~ Key User
+         , AuthEntity site ~ User
+         , IsSqlBackend (YesodPersistBackend site)
+         , SqlBackendCanWrite (YesodPersistBackend site)
+         , HasInstanceID site InstanceId
+         , YesodAuthPersist site
+         )
+      => Transaction -- ^ Transaction to record
+      -> [UserId] -- ^ Affected users
+      -> YesodDB site ()
+-- ^ Log a transaction using information available from `HandlerT`:
+--
+--   - `transactionLogTime` is now
+--   - `transactionLogInitiator` is currently logged in user (or none)
+--   - `transactionLogRemote` is determined from current HTTP-Request
+audit (toJSON -> transactionLogInfo) affected = do
+  uid <- liftHandlerT maybeAuthId
+
+  transactionLogTime <- liftIO getCurrentTime
+  transactionLogInstance <- getsYesod $ view instanceID
+  transactionLogInitiator <- for uid $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
+  transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
+
+  tlId <- insert TransactionLog{..}
+
+  affectedUsers <- forM affected $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
+  insertMany_ $ map (TransactionLogAffected tlId) affectedUsers
+
+audit' :: ( AuthId site ~ Key User
+          , AuthEntity site ~ User
+          , IsSqlBackend (YesodPersistBackend site)
+          , SqlBackendCanWrite (YesodPersistBackend site)
+          , HasInstanceID site InstanceId
+          , YesodAuthPersist site
+          )
+       => Transaction -- ^ Transaction to record
+       -> YesodDB site ()
+-- ^ Special case of `audit` for when there are no affected users
+audit' = flip audit []

src/Audit/Types.hs

@@ -0,0 +1,40 @@
+module Audit.Types
+  ( Transaction(..)
+  ) where
+
+import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
+import Model.Types.TH.JSON
+import Model
+
+import Data.Aeson.TH
+import Utils.PathPiece
+
+
+data Transaction
+  = TransactionTermEdit
+    { transactionTerm   :: TermIdentifier
+    }
+  | TransactionExamRegister
+    { transactionTerm   :: TermIdentifier
+    , transactionSchool :: SchoolShorthand
+    , transactionCourse :: CourseShorthand
+    , transactionExam   :: ExamName
+    , transactionUser   :: UserIdent
+    }
+  | TransactionExamDeregister
+    { transactionTerm   :: TermIdentifier
+    , transactionSchool :: SchoolShorthand
+    , transactionCourse :: CourseShorthand
+    , transactionExam   :: ExamName
+    , transactionUser   :: UserIdent
+    }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "transaction" "data"
+  } ''Transaction
+
+derivePersistFieldJSON ''Transaction

src/Foundation.hs

@@ -5,7 +5,7 @@
 module Foundation where
 
 import Import.NoFoundation hiding (embedFile)
-import qualified ClassyPrelude.Yesod as Yesod (addMessage)
+import qualified ClassyPrelude.Yesod as Yesod (addMessage, getHttpManager)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 
@@ -123,6 +123,8 @@ instance HasInstanceID UniWorX InstanceId where
   instanceID = _appInstanceID
 instance HasJSONWebKeySet UniWorX Jose.JwkSet where
   jsonWebKeySet = _appJSONWebKeySet
+instance HasHttpManager UniWorX Manager where
+  httpManager = _appHttpManager
 instance HasAppSettings UniWorX where
   appSettings = _appSettings'
 
@@ -746,6 +748,14 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
     guard visible
     return Authorized
 
+  CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm
+    cTime <- liftIO getCurrentTime
+    let visible = NTop materialVisibleFrom <= NTop (Just cTime)
+    guard visible
+    return Authorized
+
   CourseR tid ssh csh CRegisterR -> do
     now <- liftIO getCurrentTime
     mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
@@ -1522,6 +1532,7 @@ instance YesodBreadcrumbs UniWorX where
 
   breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
   breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
+  breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
 
   breadcrumb (CTutorialR tid ssh csh tutn TUsersR)   = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR)
   breadcrumb (CTutorialR tid ssh csh tutn TEditR)    = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
@@ -2205,6 +2216,14 @@ pageActions (CExamR tid ssh csh examn EShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamUsers
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CSheetR tid ssh csh shn SShowR) =
   [ MenuItem
@@ -2815,18 +2834,12 @@ instance YesodAuth UniWorX where
       , dummyLogin <$ guard appAuthDummyLogin
       ]
 
-    authHttpManager = getHttpManager
+    authHttpManager = Yesod.getHttpManager
 
     renderAuthMessage _ _ = Auth.germanMessage -- TODO
 
 instance YesodAuthPersist UniWorX
 
--- Useful when writing code that is re-usable outside of the Handler context.
--- An example is background jobs that send email.
--- This can also be useful for writing code that works across multiple Yesod applications.
-instance HasHttpManager UniWorX where
-    getHttpManager = appHttpManager
-
 unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler f h = do
   logger <- makeLogger f

src/Handler/Corrections.hs

@@ -215,11 +215,11 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _) } mkUnique -> case sheetType of
       NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
-      _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints)
+      _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
   )
 
 colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
-colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ formCell id
+colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (addCellAttrs [("style","width:60%")]) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
 
@@ -1085,12 +1085,13 @@ assignHandler tid ssh csh cid assignSids = do
   (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions
 
   -- gather data
-  (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
+  (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
       -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
       nrParticipants <- count [CourseParticipantCourse ==. cid]
 
-      sheetList <- selectList [SheetCourse ==. cid] [Asc SheetName]
+      sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
-      let sheets = entities2map sheetList
+      let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList
+          sheets = entities2map sheetList
           sheetIds = Map.keys sheets
           groupsPossible :: Bool
           groupsPossible =
@@ -1179,15 +1180,12 @@ assignHandler tid ssh csh cid assignSids = do
                             }
               in Map.insertWith (Map.unionWith (<>)) shnm cinf m
 
-      return (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
+      return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
 
   let -- infoMap  :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
       -- create aggregate maps
 
-      -- Always iterate over sheetList for consistent sorting!
+      -- Always iterate over orderedSheetNames for consistent sorting!
-      sheetList :: [(SheetName, CorrectionInfo)]
-      sheetList = Map.toDescList sheetMap -- newest Sheet first, except for CorrectionSheetTable
-
       sheetMap :: Map SheetName CorrectionInfo
       sheetMap = Map.map fold infoMap
 
@@ -1214,13 +1212,13 @@ assignHandler tid ssh csh cid assignSids = do
 
   let -- whamlet convenience functions
       -- avoid nestes hamlet $maybe with duplicated $nothing
-      getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector)
+      getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text)
       getCorrector (Just uid)
         | Just (User{..},loadMap) <- Map.lookup uid correctorMap
-        = (nameEmailWidget userEmail userDisplayName userSurname, loadMap)
+        = (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName)
-        --  |  Just (User{..} ) <- Map.lookup uid lecturerNames
+        --  | Just (User{..} ) <- Map.lookup uid lecturerNames
         --  = (nameEmailWidget userEmail userDisplayName userSurname, mempty)  -- lecturers may also correct in rare cases
-      getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty)
+      getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty)
       -- avoid nestes hamlet $maybe with duplicated $nothing
       getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo
       getCorrSheetStatus corr shn

src/Handler/Exam.hs

@@ -7,6 +7,7 @@ import Import
 import Handler.Utils
 import Handler.Utils.Exam
 import Handler.Utils.Invitations
+import Handler.Utils.Table.Columns
 import Handler.Utils.Table.Cells
 import Jobs.Queue
 
@@ -14,6 +15,7 @@ import Utils.Lens hiding (parts)
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
 
 import Data.Map ((!), (!?))
 import qualified Data.Map as Map
@@ -731,9 +733,68 @@ getEShowR tid ssh csh examn = do
       examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
     $(widgetFile "exam-show")
 
+type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
+type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence))
+
+instance HasEntity ExamUserTableData User where
+  hasEntity = _dbrOutput . _2
+
+instance HasUser ExamUserTableData where
+  hasUser = _dbrOutput . _2 . _entityVal
+
+_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
+_userTableOccurrence = _dbrOutput . _3
+
+queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
+queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)
+  
+queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
+queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
+
 getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEUsersR = postEUsersR
-postEUsersR = error "postEUsersR"
+postEUsersR tid ssh csh examn = do
+  eid <- runDB $ fetchExamId tid ssh csh examn
+  
+  let
+    examUsersDBTable = DBTable{..}
+      where
+        dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence) = do
+          E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
+           E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
+          E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
+          E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
+          return (examRegistration, user, occurrence)
+        dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
+        dbtProj = return
+        dbtColonnade = dbColonnade $ mconcat
+          [ colUserNameLink (CourseR tid ssh csh . CUserR)
+          , colUserMatriclenr
+          -- , colUserDegreeShort
+          -- , colUserField
+          -- , colUserSemester
+          , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence)
+          ] 
+        dbtSorting = Map.fromList
+          [ sortUserNameLink    queryUser
+          , sortUserSurname     queryUser
+          , sortUserDisplayName queryUser
+          , sortUserMatriclenr  queryUser
+          ]
+        dbtFilter = Map.empty
+        dbtFilterUI = const mempty
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "exam-users"
+
+    examUsersDBTableValidator = def
+  ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable
+
+  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
+    setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
+    $(widgetFile "exam-users")
+
 
 getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEAddUserR = postEAddUserR
@@ -745,7 +806,7 @@ postEInviteR = error "postEInviteR"
 
 postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 postERegisterR tid ssh csh examn = do
-  uid <- requireAuthId
+  Entity uid User{..} <- requireAuth
 
   Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
 
@@ -753,11 +814,16 @@ postERegisterR tid ssh csh examn = do
 
   formResult btnResult $ \case
     BtnRegister -> do
-      runDB . void . insert $ ExamRegistration eId uid Nothing
+      runDB $ do
+        now <- liftIO getCurrentTime
+        insert_ $ ExamRegistration eId uid Nothing now
+        audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
       addMessageI Success $ MsgExamRegisteredSuccess examn
       redirect $ CExamR tid ssh csh examn EShowR
     BtnDeregister -> do
-      runDB . deleteBy $ UniqueExamRegistration eId uid
+      runDB $ do
+        deleteBy $ UniqueExamRegistration eId uid
+        audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
       addMessageI Success $ MsgExamDeregisteredSuccess examn
       redirect $ CExamR tid ssh csh examn EShowR
 

src/Handler/Home.hs

@@ -1,17 +1,24 @@
 module Handler.Home where
 
 import Import
+
+import Utils.Lens
 import Handler.Utils
+import Handler.Utils.Table.Cells
+
 
 import qualified Data.Map as Map
+import Database.Esqueleto.Utils.TH
 import qualified Database.Esqueleto as E
-
+import qualified Database.Esqueleto.Utils as E
 
 getHomeR :: Handler Html
 getHomeR = do
   muid <- maybeAuthId
+  upcomingExamsWidget <- for muid $ runDB . homeUpcomingExams
   defaultLayout $ do
     setTitleI MsgHomeHeading
+    fromMaybe mempty upcomingExamsWidget
     maybe mempty homeUpcomingSheets muid
     homeOpenCourses
 
@@ -33,9 +40,9 @@ homeOpenCourses = do
       colonnade = mconcat
         [ -- dbRow
           sortable (Just "term")   (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
-            textCell $ toMessage $ courseTerm course
+            msgCell $ courseTerm course
         , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
-            textCell $ toMessage $ courseSchool course
+            msgCell $ courseSchool course
         , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
             let tid = courseTerm      course
                 ssh = courseSchool    course
@@ -174,3 +181,115 @@ homeUpcomingSheets uid = do
     , dbtIdent     = "upcoming-sheets" :: Text
     }
   $(widgetFile "home/upcomingSheets")
+
+
+
+homeUpcomingExams :: UserId -> DB Widget
+homeUpcomingExams uid = do
+  now <- liftIO getCurrentTime
+  let fortnight = addWeeks 2 now
+  let -- code copied and slightly adapted from Handler.Course.getCShowR:
+    examDBTable = DBTable{..}
+      where
+        -- for ease of refactoring:
+        queryCourse = $(sqlIJproj 2 1)
+        queryExam   = $(sqlIJproj 2 2)
+        lensCourse  = _1
+        lensExam    = _2
+
+        dbtSQLQuery (course `E.InnerJoin` exam) = do
+          E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+          E.where_ $ E.exists $ E.from $ \participant ->
+            E.where_ $ participant E.^. CourseParticipantUser   E.==. E.val uid
+              E.&&.    participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+          E.where_ $ E.isJust (exam E.^. ExamRegisterFrom)
+                     E.&&.     exam E.^. ExamRegisterFrom  E.<=. E.just (E.val fortnight)
+          E.where_ $ E.isJust (exam E.^. ExamEnd)
+                     E.&&.     exam E.^. ExamEnd           E.>=. E.just (E.val now)
+          return (course, exam)
+        dbtRowKey = queryExam >>> (E.^. ExamId)
+        dbtProj r@DBRow{ dbrOutput } = do
+          let Entity _ Exam{..}   = view lensExam   dbrOutput
+              Entity _ Course{..} = view lensCourse dbrOutput
+          guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
+          return r
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just "term") (i18nCell MsgTerm)           $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
+              msgCell courseTerm
+          , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
+              msgCell  courseSchool
+          , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
+              anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
+          -- continue here
+          , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
+              let Entity _ Exam{..}   = view lensExam   dbrOutput
+                  Entity _ Course{..} = view lensCourse dbrOutput
+              indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) (toWidget examName)
+          , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
+          , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
+          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> cell $ do
+              startT <- formatTime SelFormatDateTime examStart
+              endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
+              [whamlet|
+                $newline never
+                #{startT}
+                $maybe endT' <- endT
+                  \ – #{endT'}
+              |]
+          {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
+             Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
+          , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
+              let Entity eId Exam{..}   = view lensExam   dbrOutput
+                  Entity _ Course{..} = view lensCourse dbrOutput
+              mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
+              isRegistered <- existsBy $ UniqueExamRegistration eId uid
+              if
+                | mayRegister -> do
+                    (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
+                    return $ wrapForm examRegisterForm def
+                      { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
+                      , formEncoding = examRegisterEnctype
+                      , formSubmit = FormNoSubmit
+                      }
+                | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
+                | otherwise -> return mempty
+            -}
+          , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
+              let Entity eId Exam{..}   = view lensExam   dbrOutput
+                  Entity _ Course{..} = view lensCourse dbrOutput
+              mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
+              isRegistered <- existsBy $ UniqueExamRegistration eId uid
+              let label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
+                  examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
+              if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
+                 | otherwise   -> return [whamlet|_{label}|]
+          ]
+        dbtSorting = Map.fromList
+          [ ("demo-both",     SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
+          , ("term",          SortColumn $ queryCourse >>> (E.^. CourseTerm      ))
+          , ("school",        SortColumn $ queryCourse >>> (E.^. CourseSchool    ))
+          , ("course",        SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
+          , ("name",          SortColumn $ queryExam >>> (E.^. ExamName ))
+          , ("time",          SortColumn $ queryExam >>> (E.^. ExamStart ))
+          , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
+          , ("register-to",   SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
+          , ("visible",       SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
+          , ("registered",    SortColumn $ queryExam >>> (\exam ->
+              E.exists $ E.from $ \registration -> do
+                E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
+                E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
+            ))
+          ]
+        dbtFilter = Map.empty
+        dbtFilterUI = const mempty
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "exams"
+
+    examDBTableValidator = def
+      & defaultSorting [SortAscBy "time"]
+  (Any hasExams, examTable) <- dbTable examDBTableValidator examDBTable
+  return $(widgetFile "home/upcomingExams")
+
+

src/Handler/Term.hs

@@ -183,7 +183,9 @@ termEditHandler term = do
       (FormSuccess res) -> do
           let tid = TermKey $ termName res
           -- term <- runDB $ get $ TermKey termName
-          runDB $ repsert tid res
+          runDB $ do
+            repsert tid res
+            audit' . TransactionTermEdit $ unTermKey tid
 -- VOR INTERNATIONALISIERUNG:
 --           let tid = termToText $ termName res
 --           let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."

src/Handler/Utils/Form.hs

@@ -241,30 +241,38 @@ htmlField' = htmlField
   }
 
 natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
-natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg intField
+natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg $ intMinField 0
 
 natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
-natField d = convertField fromInteger toInteger $ checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") intField
+natField d = convertField fromInteger toInteger $ checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") $ intMinField 0
 
 natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
 natIntField = natField
 
 posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
-posIntField d = convertField fromInteger toInteger $ checkBool (> 0) (T.append  d " muss eine positive Zahl sein.") intField
+posIntField d = convertField fromInteger toInteger $ checkBool (> 0) (T.append  d " muss eine positive Zahl sein.") $ intMinField 1
 
 posIntFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
-posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg intField
+posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg $ intMinField 0
 
 -- | Field to request integral number > 'm'
 minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
-minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField
+minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intMinField m
 
 pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
-pointsField = checkBool (>= 0) MsgPointsNotPositive fixedPrecField
+pointsField = pointsFieldMinMax (Just 0) Nothing
 
 pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points
-pointsFieldMax Nothing = pointsField
+pointsFieldMax limit = pointsFieldMinMax (Just 0) limit
-pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField
+
+pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points
+pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet
+  where
+    checklower | Just   0  <- lower = checkBool (>=   0)    MsgPointsNotPositive
+               | Just minp <- lower = checkBool (>= minp) $ MsgPointsTooLow minp
+               | otherwise          = id
+    checkupper | Just maxp <- upper = checkBool (<= maxp) $ MsgPointsTooHigh maxp
+               | otherwise          = id
 
 matriculationField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
 matriculationField = textField -- no restrictions, since not everyone has a matriculation and pupils need special tags here
@@ -358,7 +366,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
         , UploadSpecific <$> specificFileForm
         )
       ]
-  
+
     extensionRestrictionField :: Field Handler (NonNull (Set Extension))
     extensionRestrictionField = checkMMap (return . maybe (Left MsgUploadModeExtensionRestrictionEmpty) Right . fromNullable . toSet) (intercalate ", " . Set.toList . toNullable) textField
       where
@@ -366,7 +374,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
         stripDot ext
           | Just nExt <- Text.stripPrefix "." ext = nExt
           | otherwise = ext
-    
+
     specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile))
     specificFileForm = wFormToAForm $ do
       Just currentRoute <- getCurrentRoute
@@ -377,7 +385,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
       where
         preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile)
         preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable
-        
+
         postProcess :: FormResult (Map ListPosition (UploadSpecificFile, UploadSpecificFile)) -> WForm Handler (FormResult (NonNull (Set UploadSpecificFile)))
         postProcess mapResult = do
           MsgRenderer mr <- getMsgRenderer
@@ -420,7 +428,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
         miAddEmpty _ _ _ = Set.empty
         miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
         miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
-                                               
+
 
 submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
 submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
@@ -524,7 +532,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
         )
       ]
 
-    
+
     gradingKeyForm :: FieldSettings UniWorX -> Maybe [Points] -> AForm Handler [Points]
     gradingKeyForm FieldSettings{..} template = formToAForm . over (mapped . _2) pure $ do
       MsgRenderer mr <- getMsgRenderer

src/Handler/Utils/Submission.hs

@@ -322,7 +322,7 @@ submissionMultiArchive (Set.toList -> ids) = do
 
 
 data SubmissionSinkState = SubmissionSinkState
-  { sinkSeenRating :: Any
+  { sinkSeenRating :: Last Rating'
   , sinkSubmissionTouched :: Any
   , sinkSubmissionNotifyRating :: Any
   , sinkFilenames :: Set FilePath
@@ -481,39 +481,53 @@ sinkSubmission userId mExists isUpdate = do
           touchSubmission
           lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
 
-      Right (submissionId', r'@Rating'{..}) -> do
+      Right (submissionId', r) -> do
         $logDebugS "sinkSubmission" $ tshow submissionId'
 
         unless (submissionId' == submissionId) $ do
           cID <- encrypt submissionId'
           throwM $ ForeignRating cID
 
-        alreadySeen <- gets $ getAny . sinkSeenRating
+        alreadySeen <- gets $ is (_Wrapped . _Just) . sinkSeenRating
         when alreadySeen $ throwM DuplicateRating
-        tellSt $ mempty{ sinkSeenRating = Any True }
-
-        unless isUpdate $ throwM RatingWithoutUpdate
 
         Submission{..} <- lift $ getJust submissionId
 
-        let anyChanges = or $
+        now <- liftIO getCurrentTime
-              [ submissionRatingPoints /= ratingPoints
+        let
-              , submissionRatingComment /= ratingComment
+          rated = submissionRatingBy == Just userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files
-              ]
+          r' = let Rating'{..} = r
+                in Rating'
+                   { ratingTime = now <$ guard rated
+                   , ..
+                   }
+        let Rating'{..} = r'
+        tellSt $ mempty{ sinkSeenRating = Last $ Just r' }
+
+        unless isUpdate $ throwM RatingWithoutUpdate
+
         -- 'ratingTime' is ignored for consistency with 'File's:
         --
         -- 'fileModified' is simply stored and never inspected while
         -- 'submissionChanged' is always set to @now@.
+        let anyChanges = or $
+              [ submissionRatingPoints /= ratingPoints
+              , submissionRatingComment /= ratingComment
+              ]
+
         when anyChanges $ do
+          touchSubmission
 
           Sheet{..} <- lift $ getJust submissionSheet
-          --TODO: should display errorMessages
+  
           mapM_ throwM $ validateRating sheetType r'
 
-          touchSubmission
+          when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
           lift $ update submissionId
-            [ SubmissionRatingPoints =. ratingPoints
+            [ SubmissionRatingPoints  =. ratingPoints
             , SubmissionRatingComment =. ratingComment
+            , SubmissionRatingTime    =. ratingTime
+            , SubmissionRatingBy      =. (userId <$ guard rated) -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just userId`)
             ]
       where
         a /~ b = not $ a ~~ b
@@ -541,9 +555,8 @@ sinkSubmission userId mExists isUpdate = do
             case isUpdate of
               False -> lift . insert_ $ SubmissionEdit userId now submissionId
               True  -> do
-                Submission{submissionRatingTime, submissionRatingBy} <- lift $ getJust submissionId
+                Submission{submissionRatingTime} <- lift $ getJust submissionId
-                when (submissionRatingBy == Just userId) $ do
+                when (is _Just submissionRatingTime) $
-                  when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
                   lift $ update submissionId [ SubmissionRatingTime =. Just now ]
             tellSt $ mempty{ sinkSubmissionTouched = Any True }
 
@@ -584,7 +597,7 @@ sinkSubmission userId mExists isUpdate = do
 
           if
             | isUpdate
-            , not $ getAny sinkSeenRating
+            , isn't (_Wrapped . _Just) sinkSeenRating
               -> update submissionId
               [ SubmissionRatingTime =. Nothing
               , SubmissionRatingPoints =. Nothing

src/Handler/Utils/Table/Cells.hs

@@ -2,6 +2,8 @@ module Handler.Utils.Table.Cells where
 
 import Import
 
+import qualified Control.Monad.Trans.RWS.Lazy
+
 import Data.CaseInsensitive (CI)
 -- import qualified Data.CaseInsensitive as CI
 
@@ -25,6 +27,26 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
 -- Some basic cells are defined in Handler.Utils.Table.Pagination
 -- such as: i18nCell, cellTooltip, anchorCell for links, etc.
 
+----------------
+-- Cell transformation
+
+-- | Add cell attributes
+addCellAttrs :: [(Text, Text)]
+  -> DBCell (Control.Monad.Trans.RWS.Lazy.RWST
+                              (Maybe (Env, FileEnv), UniWorX, [Lang])
+                              Enctype
+                              Ints
+                              (HandlerT UniWorX IO))
+                           x
+  -> DBCell (Control.Monad.Trans.RWS.Lazy.RWST
+                              (Maybe (Env, FileEnv), UniWorX, [Lang])
+                              Enctype
+                              Ints
+                              (HandlerT UniWorX IO))
+                           x
+addCellAttrs newAttrs fcell = fcell { formCellAttrs = newAttrs <> formCellAttrs fcell } -- Isn't there already a lens for that?
+
+
 ----------------
 -- Special cells
 
@@ -71,6 +93,8 @@ ifCell decision cTrue cFalse x
 linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
 linkEmptyCell link wgt = linkEitherCell link (wgt,mempty)
 
+msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a
+msgCell = textCell . toMessage
 
 -- Recall: for line numbers, use dbRow
 

src/Import/NoFoundation.hs

@@ -15,3 +15,4 @@ import Settings               as Import
 import Settings.StaticFiles   as Import
 
 import CryptoID               as Import
+import Audit                  as Import

src/Import/NoModel.hs

@@ -3,7 +3,7 @@ module Import.NoModel
   , MForm
   ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..))
 
 import Model.Types.TH.JSON as Import
 import Model.Types.TH.Wordlist as Import
@@ -50,6 +50,8 @@ import Data.Binary            as Import (Binary)
 import Numeric.Natural        as Import (Natural)
 import Data.Ratio             as Import ((%))
 
+import Net.IP                 as Import (IP)
+
 import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey)
   
 import Ldap.Client.Pool as Import
@@ -102,6 +104,7 @@ import Database.Persist.Class.Instances as Import ()
 import Database.Persist.Types.Instances as Import ()
 import Data.UUID.Instances as Import ()
 import System.FilePath.Instances as Import ()
+import Net.IP.Instances as Import ()
 
 
 import Control.Monad.Trans.RWS (RWST)

src/Jobs/HealthReport.hs

@@ -76,9 +76,9 @@ dispatchHealthCheckHTTPReachable = HealthHTTPReachable <$> do
   for (staticAppRoot <* guard doHTTP) $ \_ -> do
     url <- getUrlRender <*> pure InstanceR
     baseRequest <- HTTP.parseRequest $ unpack url
-    httpManager <- getsYesod appHttpManager
+    httpManager' <- getsYesod appHttpManager
     let httpRequest = baseRequest
-          & HTTP.setRequestManager httpManager
+          & HTTP.setRequestManager httpManager'
     (clusterId, _ :: InstanceId) <- responseBody <$> httpJSON httpRequest
     getsYesod $ (== clusterId) . appClusterID
 
@@ -129,9 +129,9 @@ dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do
       _ | not doHTTP -> return True
       Just (Left url) -> do
         baseRequest <- HTTP.parseRequest $ unpack url
-        httpManager <- getsYesod appHttpManager
+        httpManager' <- getsYesod appHttpManager
         let httpRequest = baseRequest
-              & HTTP.setRequestManager httpManager
+              & HTTP.setRequestManager httpManager'
         (== content) . responseBody <$> httpLBS httpRequest
       _other -> return False
       

src/Model.hs

@@ -64,4 +64,4 @@ instance ToMarkup (Key Term) where
   toMarkup = toMarkup . termToText . unTermKey
 
 instance ToMessage (Key Term) where
-  toMessage = termToText . unTermKey
+  toMessage = termToText . unTermKey

src/Model/Types/Common.hs

@@ -25,6 +25,7 @@ type CourseShorthand = CI Text
 type SheetName       = CI Text
 type MaterialName    = CI Text
 type UserEmail       = CI Email
+type UserIdent       = CI Text
 type TutorialName    = CI Text
 type ExamName        = CI Text
 type ExamPartName    = CI Text
@@ -33,4 +34,4 @@ type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID
 type ClusterId       = UUID
 type TokenId         = UUID
-type TermCandidateIncidence = UUID
+type TermCandidateIncidence = UUID

src/Net/IP/Instances.hs

@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Net.IP.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Net.IP (IP)
+import qualified Net.IP as IP
+
+import Database.Persist.Sql
+
+import qualified Data.Text.Encoding as Text
+
+
+instance PersistField IP where
+  toPersistValue = PersistDbSpecific . encodeUtf8 . IP.encode
+  fromPersistValue (PersistDbSpecific bs) = first tshow (Text.decodeUtf8' bs) >>= maybe (Left "Could not parse IP-address") Right . IP.decode
+  fromPersistValue (PersistByteString bs) = first tshow (Text.decodeUtf8' bs) >>= maybe (Left "Could not parse IP-address") Right . IP.decode
+  fromPersistValue (PersistText t) = maybe (Left "Could not parse IP-address") Right $ IP.decode t
+  fromPersistValue _ = Left "IP-address values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
+instance PersistFieldSql IP where
+  sqlType _ = SqlOther "inet"

src/Utils/Form.hs

@@ -503,41 +503,64 @@ fractionalField = Field{..}
   where
     scientific' :: Iso' a Scientific
     scientific' = iso (fromRational . toRational) (fromRational . toRational)
-    
+
     fieldEnctype = UrlEncoded
     fieldView theId name attrs (fmap $ view scientific' -> val) isReq
       = [whamlet|
           $newline never
-          <input id=#{theId} name=#{name} *{attrs} type=number :isReq:required value=#{either id (pack . formatScientific Fixed Nothing) val}>
+          <input id=#{theId} name=#{name} *{attrs} type=number step=any :isReq:required value=#{either id (pack . formatScientific Fixed Nothing) val}>
         |]
     fieldParse = parseHelper $ \t ->
-      maybe (Left $ MsgInvalidNumber t) (Right . review scientific') (readMay t :: Maybe Scientific)
+      maybe (Left $ MsgInvalidNumber (t<>"HERE")) (Right . review scientific') (readMay t :: Maybe Scientific)
 
 fixedPrecField :: forall m p.
                   ( Monad m
                   , RenderMessage (HandlerSite m) FormMessage
                   , HasResolution p
                   ) => Field m (Fixed p)
-fixedPrecField = Field{..}
+fixedPrecField = fixedPrecMinMaxField Nothing Nothing
+
+fixedPrecMinMaxField :: forall m p.
+                  ( Monad m
+                  , RenderMessage (HandlerSite m) FormMessage
+                  , HasResolution p
+                  ) => Maybe (Fixed p) -> Maybe (Fixed p) -> Field m (Fixed p)
+fixedPrecMinMaxField lower upper = Field{..}
   where
     resolution' :: Integer
     resolution' = resolution $ Proxy @p
 
-    step = showFixed True (fromRational $ 1 % resolution' :: Fixed p)
+    showF = showFixed True
-    
+    step  = showFixed True (fromRational $ 1 % resolution' :: Fixed p)
+
     fieldEnctype = UrlEncoded
     fieldView theId name attrs val isReq
       = [whamlet|
           $newline never
-          <input id=#{theId} name=#{name} *{attrs} type=number step=#{step} :isReq:required value=#{either id (pack . showFixed True) val}>
+          <input id=#{theId} name=#{name} *{attrs} type=number step=#{step} :hasMin:min="#{showF vMin}" :hasMax:max="#{showF vMax}" :isReq:required value=#{either id (pack . showFixed True) val}>
         |]
     fieldParse = parseHelper $ \t -> do
       sci <- maybe (Left $ MsgInvalidNumber t) Right (readMay t :: Maybe Scientific)
       return . fromRational $ round (sci * fromIntegral resolution') % resolution'
+    (hasMin, vMin) = maybe (False, 0) (True,) lower
+    (hasMax, vMax) = maybe (False, 0) (True,) upper
+
 
 rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
 rationalField = fractionalField
 
+-- | Sepcify lower bound via HTML5 min attribute, may not work in older browser, so better use `Handler.Utils.Form.minIntField` (which in turn calls this function)
+intMinField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Field m i
+intMinField lower = intMinMaxField (Just lower) Nothing
+
+-- | Sepcify lower/upper bounds via HTML5 min attribute, may not work in older browser, so better use `Handler.Utils.Form.minIntField` (which in turn calls this function)
+intMinMaxField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => Maybe i -> Maybe i -> Field m i
+intMinMaxField lower upper = intF{ fieldView=newView }
+  where
+    intF@Field{ fieldView=oldView } = intField
+    newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq
+    newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ]
+
 data SecretJSONFieldException = SecretJSONFieldDecryptFailure
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Exception SecretJSONFieldException

src/Utils/Lens.hs

@@ -1,7 +1,12 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Utils.Lens ( module Utils.Lens ) where
 
-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (HasHttpManager(..))
+import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..))
 import Model
+  
 import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc)
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
@@ -138,5 +143,11 @@ makeLenses_ ''UTCTime
 class HasInstanceID s a | s -> a where
   instanceID :: Lens' s a
 
+class HasHttpManager s a | s -> a where
+  httpManager :: Lens' s a
+
+instance HasHttpManager s Manager => Yesod.HasHttpManager s where
+  getHttpManager = view httpManager
+
 class HasJSONWebKeySet s a | s -> a where
   jsonWebKeySet :: Lens' s a

stack.yaml

@@ -17,7 +17,7 @@ extra-deps:
     commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
   - git: https://github.com/pngwjpgh/memcached-binary.git
     commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad
-  
+
   - colonnade-1.2.0
   - yesod-colonnade-1.2.0
 
@@ -50,4 +50,8 @@ extra-deps:
 
   - haskell-src-exts-util-0.2.1.2
 
+  - directory-1.3.4.0
+
+  - process-1.6.5.1
+
 resolver: lts-10.5

stack.yaml.lock

@@ -0,0 +1,201 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    cabal-file:
+      size: 1740
+      sha256: 2cab90bba4d15bf6a17e3cb8e50bc8708c1091de503dd4e91d3954240e89f37b
+    name: zip-stream
+    version: 0.1.0.1
+    git: https://github.com/pngwjpgh/zip-stream.git
+    pantry-tree:
+      size: 657
+      sha256: d1626bbc3fb88a48ce9c5c37199f8cbf426be6410740891d76a8343de4f3c109
+    commit: 9272bbed000928d500febad1cdc98d1da29d399e
+  original:
+    git: https://github.com/pngwjpgh/zip-stream.git
+    commit: 9272bbed000928d500febad1cdc98d1da29d399e
+- completed:
+    cabal-file:
+      size: 4141
+      sha256: 88537113b855381b8d70da2442ae644dc979ad6b32aaaec2ebf55306764c8f1a
+    name: encoding
+    version: 0.8.2
+    git: https://github.com/pngwjpgh/encoding.git
+    pantry-tree:
+      size: 5668
+      sha256: 57160d758802aba6a0d2cc88c53f2f0bb60df7d5e6822938351618b7eca0beab
+    commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
+  original:
+    git: https://github.com/pngwjpgh/encoding.git
+    commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
+- completed:
+    cabal-file:
+      size: 2384
+      sha256: 7b25a0ef819e8a01b485d6d0865baa3445faa826ffb3876c94109dd2469ffbd3
+    name: memcached-binary
+    version: 0.2.0
+    git: https://github.com/pngwjpgh/memcached-binary.git
+    pantry-tree:
+      size: 1170
+      sha256: c466f91129410bae1f53e25aec4026f6984ce2dff0ada4516e2548048aba549a
+    commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad
+  original:
+    git: https://github.com/pngwjpgh/memcached-binary.git
+    commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad
+- completed:
+    hackage: colonnade-1.2.0@sha256:5620e999a68a394abfe157da6302dd6d8ce8a89b527ea9c294519efd7c4edb2c,2092
+    pantry-tree:
+      size: 327
+      sha256: 56ae7b84b5c8001784181e1710a6a1036e5b626e4539a7eee3db0f6ccdf2d861
+  original:
+    hackage: colonnade-1.2.0
+- completed:
+    hackage: yesod-colonnade-1.2.0@sha256:8908b30449ba5ee3de1d1fe38879acd0512094c6d4b0503c1f0011184a0e9310,897
+    pantry-tree:
+      size: 221
+      sha256: e813bb2dba2ce25557e4cf224bc77c505fdc72e3ecee2193a27c4dd64e9f8b2d
+  original:
+    hackage: yesod-colonnade-1.2.0
+- completed:
+    hackage: ldap-client-0.2.0@sha256:a5fce1d809f4a2f7dcbb49e868257895209bb7624d8791cf72765edc90a1f1af,2132
+    pantry-tree:
+      size: 1717
+      sha256: 612ca1bd1a6f1a37a101ea63f22a10d4b58fc71e4a4752ac7c6ddf851f67550d
+  original:
+    hackage: ldap-client-0.2.0
+- completed:
+    hackage: conduit-resumablesink-0.2@sha256:eb7ac70862310a10038fa178594d6e0c0b03cf1a8c3aa6293fc316871c058b24,1375
+    pantry-tree:
+      size: 294
+      sha256: 29e514637bf0c40b8fa72cd091e02da0974d03855eee7ecd24650ef1081c1445
+  original:
+    hackage: conduit-resumablesink-0.2
+- completed:
+    hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325
+    pantry-tree:
+      size: 364
+      sha256: 6650b51ea060397c412b07b256c043546913292973284a7149ddd08f489b3e48
+  original:
+    hackage: uuid-crypto-1.4.0.0
+- completed:
+    hackage: filepath-crypto-0.1.0.0@sha256:d5d33a2c9d044d025bbbfd4e5fab61f77228604b3cb7ea46e9164f8c8bcc9fb4,1593
+    pantry-tree:
+      size: 623
+      sha256: 3663e7b1ba2d80c51967a97fb67047bb3d3b5acdaa2b82f4036c4117b3238a49
+  original:
+    hackage: filepath-crypto-0.1.0.0
+- completed:
+    hackage: cryptoids-0.5.1.0@sha256:986f0f0e966a83505013f225a4b7805f03c656822704d2a516bf68caf2a9ee04,1570
+    pantry-tree:
+      size: 513
+      sha256: 4348c28a66cd53602df6c04961f2b980756273f17a1dcefa8c61b6857f7564be
+  original:
+    hackage: cryptoids-0.5.1.0
+- completed:
+    hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271
+    pantry-tree:
+      size: 268
+      sha256: 0e9b11f6414a0a179cd11dec55261a1f9995663fcf27bfd4a386c48652655404
+  original:
+    hackage: cryptoids-types-1.0.0
+- completed:
+    hackage: cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985
+    pantry-tree:
+      size: 359
+      sha256: 6a5af7c785c230501fa6088ecf963c7de7463ab75b3f646510612f17dff69744
+  original:
+    hackage: cryptoids-class-0.0.0
+- completed:
+    hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529
+    pantry-tree:
+      size: 446
+      sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373
+  original:
+    hackage: system-locale-0.3.0.0
+- completed:
+    hackage: persistent-2.7.3.1@sha256:ffab77bc3481466265ee32d01941731a34c969806fe5de838b13cba9e0fe6d9e,5237
+    pantry-tree:
+      size: 2164
+      sha256: 0ec69231caf6ed44e709fd5e742861f7eac50eb3de4817f4893295aa747ca824
+  original:
+    hackage: persistent-2.7.3.1
+- completed:
+    hackage: saltine-0.1.0.1@sha256:77071b5746709d35821df74e870ca6bf3a14942bf3ff42d22b8adc413f066d05,3007
+    pantry-tree:
+      size: 1882
+      sha256: e4b0eb2e8b17eec2ea62ea73b29971780cedd3574331f1def521bee58503b80a
+  original:
+    hackage: saltine-0.1.0.1
+- completed:
+    hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
+    pantry-tree:
+      size: 442
+      sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea
+  original:
+    hackage: hlint-test-0.1.0.0
+- completed:
+    hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594
+    pantry-tree:
+      size: 316
+      sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c
+  original:
+    hackage: pkcs7-1.0.0.1
+- completed:
+    hackage: quickcheck-classes-0.4.14@sha256:fd07ec67aa5f3dc689b58db1212228428589397d75908a1fca4a0f635cd92187,3494
+    pantry-tree:
+      size: 2755
+      sha256: 4e768fdfb52bb1df8649b767dd5b1aba215164e03879752dda8b218928489597
+  original:
+    hackage: quickcheck-classes-0.4.14
+- completed:
+    hackage: semirings-0.2.1.1@sha256:83bdfd8d3abf2e404056dbc70da02d05d68fdc87fdbaa63d06f815155947e7e2,3376
+    pantry-tree:
+      size: 431
+      sha256: ab5ecf0cdd682be98b8362d6793acdf96932bdd50ab528fb85763fa0c76f2711
+  original:
+    hackage: semirings-0.2.1.1
+- completed:
+    hackage: systemd-1.2.0@sha256:94995d4f1268aa0049d1793b21adb1522b6041e270cea4095c43eb589cc7ce53,1389
+    pantry-tree:
+      size: 386
+      sha256: 16d20860c99050194570c4760337a9d9c156580dbe0ae707f4039f6da1474a93
+  original:
+    hackage: systemd-1.2.0
+- completed:
+    hackage: filepath-1.4.2@sha256:397c08e88361563bd29168b8f85d58782d6e0e5eba2374fe246fd0cf5dfde34c,2205
+    pantry-tree:
+      size: 681
+      sha256: 288e706f3d38bea39a5d248c1a5bdbb489a84fea81652966a203b28b58c6a8ca
+  original:
+    hackage: filepath-1.4.2
+- completed:
+    hackage: haskell-src-exts-util-0.2.1.2@sha256:2e14a871cda4416c0f3fb846f208b0d769e658091487db4b22b77930d200a79d,1029
+    pantry-tree:
+      size: 478
+      sha256: 247967e9b2ef347f0cc3494422c9758929a406c29b7bed0f82d3f8ac39cde8e6
+  original:
+    hackage: haskell-src-exts-util-0.2.1.2
+- completed:
+    hackage: directory-1.3.4.0@sha256:500019f04494324d1df16cf83eefeb3f809b2b20b32a32ccd755ee0439c18bfd,2829
+    pantry-tree:
+      size: 3365
+      sha256: 00c09e0c014d29ebfb921b64c1459e61a0ad6f10e70128d795246a47c06394b0
+  original:
+    hackage: directory-1.3.4.0
+- completed:
+    hackage: process-1.6.5.1@sha256:77a9afeb676357f67fe5cf1ad79aca0745fb6f7fb96b786d510af08f622643f6,2468
+    pantry-tree:
+      size: 1211
+      sha256: 19d944da6aa37944332e0726372288319852e5f72aa57dbc3516dc15e760a502
+  original:
+    hackage: process-1.6.5.1
+snapshots:
+- completed:
+    size: 568655
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/10/5.yaml
+    sha256: d5d2a8f55085643b41a30e9191cbbd4f8f707dd63facdddfbce08d811f808444
+  original: lts-10.5

sync-versions.hs

@@ -1,5 +1,5 @@
 #!/usr/bin/env stack
--- stack runghc --package libyaml
+-- stack runghc --package libyaml --package aeson --package unordered-containers --package text
 
 {-# LANGUAGE OverloadedStrings
            , LambdaCase

templates/adminTest.hamlet

@@ -1,23 +1,49 @@
 <section>
-  <p data-tooltip="Solch ein Tooltip kann mit dem <em>data-tooltip</em> Attribut erzeugt werden. Funktioniert aber nur in Block-Elementen die einen sinnvollen Wrapper haben.">
+
+
+  <p>
     Diese interne Seite dient lediglich zum Testen diverser Funktionalitäten
     und zur Demonstration der verschiedenen Hilfsfunktionen/Module.
 
     Der Handler sollte jeweils aktuelle Beispiele für alle möglichen Funktionalitäten enthalten, so dass man immer weiß, wo man nachschlagen kann.
 
+ <p>
+    <div .tooltip>
+      <div .tooltip__handle>
+      <div .tooltip__content>Hier könnte Ihr Tooltip stehen!
+      Hier ist ein Text mit einem eingebetteten Tooltip.
+
+ <p>
+  <span .tooltip>
+    <span .tooltip__content>Kaufen Sie Tooltip-White für hellere Tooltips!
+    Den Tooltip-Handle sollte man immer setzen, damit es auch auf Mobilgeräten und ohne Javascript funktioniert.
+
 <section>
-  <h2 uw-show-hide>Teilweise funktionierende Abschnitte
+  <h2>Tabelle zu Fuss
-
+   <table .table .table--striped>
-  <ul>
+    <tr .table__row .table__row--head>
-    <li .list-group-item>
+      <th .table__th colspan=2> Kopf A
-      <a href=@{UsersR}>Benutzer Verwaltung
+      <th .table__th rowspan=2> Kopf
-
+    <tr .table__row .table__row--head>
-    <li .list-group-item>
+      <th .table__th> B
-      <a href=@{TermShowR}>Semester Verwaltung
+      <th .table__th> C
-      <a href=@{TermEditR}>Neues Semester anlegen
+    <tr .table__row title="Ein Beispiel für ein Zeilentooltip">
-
+        <td .table__td>1
-    <li .list-group-item>
+        <td .table__td>2
-      <a href=@{CourseNewR}>Kurse anlegen
+        <td .table__td>3
+    <tr .table__row>
+        <td .table__td>
+          <span .tooltip>
+            <span .tooltip__content>Kaufen Sie Tooltip-White für hellere Tooltips! (GEHT NICHT)
+          4
+        <td .table__td>5
+          <span .tooltip>
+            <span .tooltip__content>Kaufen Sie Tooltip-Black für dunklere Tooltips! (GEHT NICHT)
+            <td .table__td>6
+    <tr .table__row>
+        <td .table__td>7
+        <td .table__td>8
+        <td .table__td>9
 
 <section>
   <h2>Funktionen zum Testen

templates/corrections-overview.hamlet

@@ -17,30 +17,31 @@
       <th .table__th>_{MsgGenericMin}
       <th .table__th>_{MsgGenericAvg}
       <th .table__th>_{MsgGenericMax}
-    $#  Always iterate over sheetList for consistent sorting! Newest first, except in this table
+    $#  Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
-    $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- reverse sheetList
+    $forall sheetName <- reverse orderedSheetNames
-      <tr .table__row>
+      $maybe CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax} <- Map.lookup sheetName sheetMap
-        <td .table__td>^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)}
+        <tr .table__row>
-        $if groupsPossible
+          <td .table__td>^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)}
-          <td .table__td>#{ciSubmittors}
+          $if groupsPossible
-        <td .table__td>#{ciSubmissions}
+            <td .table__td>#{ciSubmittors}
-        $maybe ((splus,sfailed),_,_) <- Map.lookup sheetName assignment
+          <td .table__td>#{ciSubmissions}
-          $if 0 < Set.size sfailed
+          $maybe ((splus,sfailed),_,_) <- Map.lookup sheetName assignment
-            <td .table__td>#{ciSubmissions - ciAssigned}
+            $if 0 < Set.size sfailed
-            <td .table__td .alert-danger>(-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)})
+              <td .table__td>#{ciSubmissions - ciAssigned}
-          $elseif 0 < Set.size splus
+              <td .table__td .alert-danger>(-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)})
-            <td .table__td>#{ciSubmissions - ciAssigned}
+            $elseif 0 < Set.size splus
-            <td .table__td .alert-info>(-#{show (Set.size splus)})
+              <td .table__td>#{ciSubmissions - ciAssigned}
-          $else
+              <td .table__td .alert-info>(-#{show (Set.size splus)})
+            $else
+              <td .table__td>#{ciSubmissions - ciAssigned}
+              <td .table__td>
+          $nothing
             <td .table__td>#{ciSubmissions - ciAssigned}
             <td .table__td>
-        $nothing
+          <td .table__td>#{ciSubmissions - ciCorrected}
-          <td .table__td>#{ciSubmissions - ciAssigned}
+          <td .table__td>#{showDiffDays ciMin}
-          <td .table__td>
+          <td .table__td>#{showAvgsDays ciTot ciCorrected}
-        <td .table__td>#{ciSubmissions - ciCorrected}
+          <td .table__td>#{showDiffDays ciMax}
-        <td .table__td>#{showDiffDays ciMin}
-        <td .table__td>#{showAvgsDays ciTot ciCorrected}
-        <td .table__td>#{showDiffDays ciMax}
 
 
 <div>
@@ -52,8 +53,9 @@
       <th .table__th colspan=2>_{MsgGenericAll}
       <th .table__th rowspan=2>_{MsgCorDeficitProportion}
       <th .table__th colspan=3>_{MsgCorrectionTime}
-      $#  Always iterate over sheetList for consistent sorting! Newest first, except in this table
+
-      $forall (shn,_) <- sheetList
+      $#  Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
+      $forall shn <- orderedSheetNames
         <th .table__th colspan=5>#{shn}
         $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
     <tr .table__row .table__row--head>
@@ -62,16 +64,17 @@
       <th .table__th>_{MsgGenericMin}
       <th .table__th>_{MsgGenericAvg}
       <th .table__th>_{MsgGenericMax}
-      $#  Always iterate over sheetList for consistent sorting! Newest first, except in this table
+      $#  Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
-      $forall _shn <- sheetList
+      $forall _shn <- orderedSheetNames
         <th .table__th>_{MsgCorProportion}
         <th .table__th>_{MsgNrSubmissionsTotalShort}
         <th .table__th>_{MsgGenericNumChange}
         <th .table__th>_{MsgNrSubmissionsNotCorrectedShort}
         <th .table__th>_{MsgGenericAvg}
     $forall (CorrectionInfo{ciCorrector, ciSubmissions=ciSubmissionsNr, ciCorrected, ciMin, ciTot, ciMax}) <- corrInfos
-      $with (nameW,loadM) <- getCorrector ciCorrector
+      $with (nameW,loadM, name) <- getCorrector ciCorrector
-        <tr .table__row>
+        $# TODO: User proper Tooltips instead of title attribute here, once Tooltips work with tables
+        <tr .table__row title="#{name}">
           <td .table__td>^{nameW}
           <td .table__td>#{ciSubmissionsNr}
             $with total <- ciSubmissions corrMapSum
@@ -84,32 +87,33 @@
           <td .table__td>#{showDiffDays ciMin}
           <td .table__td>#{showAvgsDays ciTot ciCorrected}
           <td .table__td>#{showDiffDays ciMax}
-          $#  Always iterate over sheetList for consistent sorting! Newest first, except in this table
+          $#  Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
-          $forall (shn, CorrectionInfo{ciSubmissions=sheetSubmissionsNr}) <- sheetList
+          $forall shn <- orderedSheetNames
-            <td .table__td>
+            $maybe CorrectionInfo{ciSubmissions=sheetSubmissionsNr} <- Map.lookup shn sheetMap
-              $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
+              <td .table__td>
-                #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
+                $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
-                $if sheetCorrectorState == CorrectorNormal
+                  #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
-                  $maybe Load{byProportion=total} <- Map.lookup shn sheetLoad
+                  $if sheetCorrectorState == CorrectorNormal
-                    $if total > 0
+                    $maybe Load{byProportion=total} <- Map.lookup shn sheetLoad
-                      \ (#{textPercent' True 0 (byProportion sheetCorrectorLoad) total})
+                      $if total > 0
-            $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
+                        \ (#{textPercent' True 0 (byProportion sheetCorrectorLoad) total})
-              <td .table__td>#{ciSubmissions}
+              $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
-                $if sheetSubmissionsNr > 0
+                <td .table__td>#{ciSubmissions}
-                  \ (#{textPercent' True 0 ciSubmissions sheetSubmissionsNr})
+                  $if sheetSubmissionsNr > 0
-              $maybe nrNew <- getCorrNewAssignment ciCorrector shn
+                    \ (#{textPercent' True 0 ciSubmissions sheetSubmissionsNr})
-                $# <td .table__td>#{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap`
+                $maybe nrNew <- getCorrNewAssignment ciCorrector shn
-                <td .table__td .alert-info>(+#{nrNew})
+                  $# <td .table__td>#{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap`
+                  <td .table__td .alert-info>(+#{nrNew})
+                $nothing
+                  <td .table__td>
+                <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
+                <td .table__td>#{showAvgsDays ciTot ciCorrected}
               $nothing
                 <td .table__td>
-              <td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
+                <td .table__td>
-              <td .table__td>#{showAvgsDays ciTot ciCorrected}
+                <td .table__td>
-            $nothing
+                <td .table__td>
-              <td .table__td>
+    $if not (null orderedSheetNames)
-              <td .table__td>
-              <td .table__td>
-              <td .table__td>
-    $if not (null sheetList)
       <tr .table__row>
         <td .table__th>Σ
         $with ciSubmissionsNr <- ciSubmissions corrMapSum
@@ -120,11 +124,12 @@
         <td .table__th>#{showDiffDays (ciMin corrMapSum)}
         <td .table__th>#{showAvgsDays (ciTot corrMapSum) (ciCorrected corrMapSum)}
         <td .table__th>#{showDiffDays (ciMax corrMapSum)}
-        $#  Always iterate over sheetList for consistent sorting! Newest first, except in this table
+        $#  Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
-        $forall (shn, CorrectionInfo{ciSubmissions}) <- sheetList
+        $forall shn <- orderedSheetNames
-          <td .table__th>#{getLoadSum shn}
+          $maybe CorrectionInfo{ciSubmissions} <- Map.lookup shn sheetMap
-          <td .table__th>#{ciSubmissions}
+            <td .table__th>#{getLoadSum shn}
-          <td .table__td colspan=3>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
+            <td .table__th>#{ciSubmissions}
+            <td .table__td colspan=3>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
   ^{btnWdgt}
  <div>
   <p>_{MsgAssignSubmissionsRandomWarning}

templates/exam-users.hamlet

@@ -0,0 +1,2 @@
+$newline never
+^{examUsersTable}

templates/home/upcomingExams.hamlet

@@ -0,0 +1,7 @@
+$newline never
+<section>
+  <h2>_{MsgHomeUpcomingExams}
+  $if hasExams
+    ^{examTable}
+  $else
+    _{MsgNoUpcomingExams}

templates/widgets/massinput/list/layout.hamlet

@@ -1,8 +1,8 @@
 $newline never
 <table>
   <tbody>
-    <tr .massinput__cell>
+    $forall coord <- review liveCoords lLength
-      $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
         <td>
           ^{cellWdgts ! coord}
         <td>

test.sh

@@ -11,4 +11,4 @@ if [[ -d .stack-work-test ]]; then
     trap move-back EXIT
 fi
 
-exec -- stack build --test --coverage --fast --flag uniworx:dev --flag uniworx:library-only ${@}
+stack build --test --coverage --fast --flag uniworx:dev --flag uniworx:library-only ${@}

test/Model/TypesSpec.hs

@@ -23,6 +23,8 @@ import qualified Data.Set as Set
 
 import Time.Types (WeekDay(..))
 
+import qualified Net.IP as IP
+
 
 instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
   arbitrary = arbitrary `suchThatMap` fromNullable
@@ -184,6 +186,12 @@ instance Arbitrary LecturerType where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary IP where
+  arbitrary = oneof
+    [ IP.ipv4 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    , IP.ipv6 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+    ]
+
 instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key record) where
   arbitrary = toSqlKey <$> arbitrary
   shrink = map toSqlKey . shrink . fromSqlKey
@@ -269,6 +277,8 @@ spec = do
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @LecturerType)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @IP)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $

test/TestImport.hs

@@ -36,6 +36,8 @@ import Numeric.Natural as X
 
 import Control.Lens as X hiding ((<.), elements)
 
+import Net.IP as X (IP)
+
 import Database (truncateDb)
 import Database as X (fillDb)