fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into course-teaser

Browse Source
This commit is contained in:
Sarah Vaupel 2019-07-10 10:33:46 +02:00
commit 34db033c95
38 changed files with 6299 additions and 2524 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
CHANGELOG.md
View File

@ -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)

7
build.sh
View File

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

7
frontend/src/utils/tooltips/tooltips.scss
View File

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

6
messages/uniworx/de.msg
View File

@ -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

12
models/audit Normal file
View File

@ -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

1
models/exams
View File

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

7751
package-lock.json generated
View File

File diff suppressed because it is too large Load Diff

5
package.json
View File

@ -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"
}
}

5
package.yaml
View File

@ -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:

84
src/Audit.hs Normal file
View File

@ -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 []

40
src/Audit/Types.hs Normal file
View File

@ -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

29
src/Foundation.hs
View File

@ -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

26
src/Handler/Corrections.hs
View File

@ -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]
let sheets = entities2map sheetList
sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
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!
sheetList :: [(SheetName, CorrectionInfo)]
sheetList = Map.toDescList sheetMap -- newest Sheet first, except for CorrectionSheetTable
-- Always iterate over orderedSheetNames for consistent sorting!
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)
-- | Just (User{..} ) <- Map.lookup uid lecturerNames
= (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName)
-- | 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

74
src/Handler/Exam.hs
View File

@ -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

125
src/Handler/Home.hs
View File

@ -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")

4
src/Handler/Term.hs
View File

@ -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."

34
src/Handler/Utils/Form.hs
View File

@ -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 (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField
pointsFieldMax limit = pointsFieldMinMax (Just 0) limit
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

47
src/Handler/Utils/Submission.hs
View File

@ -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 $
[ submissionRatingPoints /= ratingPoints
, submissionRatingComment /= ratingComment
]
now <- liftIO getCurrentTime
let
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
when (submissionRatingBy == Just userId) $ do
when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
Submission{submissionRatingTime} <- lift $ getJust submissionId
when (is _Just submissionRatingTime) $
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

24
src/Handler/Utils/Table/Cells.hs
View File

@ -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

1
src/Import/NoFoundation.hs
View File

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

5
src/Import/NoModel.hs
View File

@ -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)

8
src/Jobs/HealthReport.hs
View File

@ -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

2
src/Model.hs
View File

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

3
src/Model/Types/Common.hs
View File

@ -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

23
src/Net/IP/Instances.hs Normal file
View File

@ -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"

37
src/Utils/Form.hs
View File

@ -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

13
src/Utils/Lens.hs
View File

@ -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

6
stack.yaml
View File

@ -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

201
stack.yaml.lock Normal file
View File

@ -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

2
sync-versions.hs
View File

@ -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

52
templates/adminTest.hamlet
View File

@ -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
<ul>
<li .list-group-item>
<a href=@{UsersR}>Benutzer Verwaltung
<li .list-group-item>
<a href=@{TermShowR}>Semester Verwaltung
<a href=@{TermEditR}>Neues Semester anlegen
<li .list-group-item>
<a href=@{CourseNewR}>Kurse anlegen
<h2>Tabelle zu Fuss
<table .table .table--striped>
<tr .table__row .table__row--head>
<th .table__th colspan=2> Kopf A
<th .table__th rowspan=2> Kopf
<tr .table__row .table__row--head>
<th .table__th> B
<th .table__th> C
<tr .table__row title="Ein Beispiel für ein Zeilentooltip">
<td .table__td>1
<td .table__td>2
<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

119
templates/corrections-overview.hamlet
View File

@ -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
$forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- reverse sheetList
<tr .table__row>
<td .table__td>^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)}
$if groupsPossible
<td .table__td>#{ciSubmittors}
<td .table__td>#{ciSubmissions}
$maybe ((splus,sfailed),_,_) <- Map.lookup sheetName assignment
$if 0 < Set.size sfailed
<td .table__td>#{ciSubmissions - ciAssigned}
<td .table__td .alert-danger>(-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)})
$elseif 0 < Set.size splus
<td .table__td>#{ciSubmissions - ciAssigned}
<td .table__td .alert-info>(-#{show (Set.size splus)})
$else
$# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
$forall sheetName <- reverse orderedSheetNames
$maybe CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax} <- Map.lookup sheetName sheetMap
<tr .table__row>
<td .table__td>^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)}
$if groupsPossible
<td .table__td>#{ciSubmittors}
<td .table__td>#{ciSubmissions}
$maybe ((splus,sfailed),_,_) <- Map.lookup sheetName assignment
$if 0 < Set.size sfailed
<td .table__td>#{ciSubmissions - ciAssigned}
<td .table__td .alert-danger>(-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)})
$elseif 0 < Set.size splus
<td .table__td>#{ciSubmissions - ciAssigned}
<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 - ciAssigned}
<td .table__td>
<td .table__td>#{ciSubmissions - ciCorrected}
<td .table__td>#{showDiffDays ciMin}
<td .table__td>#{showAvgsDays ciTot ciCorrected}
<td .table__td>#{showDiffDays ciMax}
<td .table__td>#{ciSubmissions - ciCorrected}
<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
$forall _shn <- sheetList
$# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
$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
<tr .table__row>
$with (nameW,loadM, name) <- getCorrector ciCorrector
$# 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
$forall (shn, CorrectionInfo{ciSubmissions=sheetSubmissionsNr}) <- sheetList
<td .table__td>
$maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
$if sheetCorrectorState == CorrectorNormal
$maybe Load{byProportion=total} <- Map.lookup shn sheetLoad
$if total > 0
\ (#{textPercent' True 0 (byProportion sheetCorrectorLoad) total})
$maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
<td .table__td>#{ciSubmissions}
$if sheetSubmissionsNr > 0
\ (#{textPercent' True 0 ciSubmissions sheetSubmissionsNr})
$maybe nrNew <- getCorrNewAssignment ciCorrector shn
$# <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})
$# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
$forall shn <- orderedSheetNames
$maybe CorrectionInfo{ciSubmissions=sheetSubmissionsNr} <- Map.lookup shn sheetMap
<td .table__td>
$maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
$if sheetCorrectorState == CorrectorNormal
$maybe Load{byProportion=total} <- Map.lookup shn sheetLoad
$if total > 0
\ (#{textPercent' True 0 (byProportion sheetCorrectorLoad) total})
$maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
<td .table__td>#{ciSubmissions}
$if sheetSubmissionsNr > 0
\ (#{textPercent' True 0 ciSubmissions sheetSubmissionsNr})
$maybe nrNew <- getCorrNewAssignment ciCorrector shn
$# <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>#{showAvgsDays ciTot ciCorrected}
$nothing
<td .table__td>
<td .table__td>
<td .table__td>
<td .table__td>
$if not (null sheetList)
<td .table__td>
<td .table__td>
<td .table__td>
$if not (null orderedSheetNames)
<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
$forall (shn, CorrectionInfo{ciSubmissions}) <- sheetList
<td .table__th>#{getLoadSum shn}
<td .table__th>#{ciSubmissions}
<td .table__td colspan=3>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
$# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
$forall shn <- orderedSheetNames
$maybe CorrectionInfo{ciSubmissions} <- Map.lookup shn sheetMap
<td .table__th>#{getLoadSum shn}
<td .table__th>#{ciSubmissions}
<td .table__td colspan=3>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
^{btnWdgt}
<div>
<p>_{MsgAssignSubmissionsRandomWarning}

2
templates/exam-users.hamlet Normal file
View File

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

7
templates/home/upcomingExams.hamlet Normal file
View File

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

4
templates/widgets/massinput/list/layout.hamlet
View File

@ -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>

2
test.sh
View File

@ -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 ${@}

10
test/Model/TypesSpec.hs
View File

@ -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 $

2
test/TestImport.hs
View File

@ -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)