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

feat(exams): introduce examOccurrenceName

Browse Source 
BREAKING CHANGE: examOccurrenceName
This commit is contained in:
Gregor Kleen 2019-07-15 15:38:37 +02:00
parent 05e7b52f08
commit 379a7edd12
20 changed files with 156 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
messages/uniworx/de.msg
View File

@ -1108,8 +1108,10 @@ ExamRoomSurname': Nach Nachname
ExamRoomMatriculation': Nach Matrikelnummer ExamRoomMatriculation': Nach Matrikelnummer
ExamRoomRandom': Zufällig pro Teilnehmer ExamRoomRandom': Zufällig pro Teilnehmer
ExamOccurrence: Termin/Raum
ExamOccurrences: Prüfungen ExamOccurrences: Prüfungen
ExamRoomAlreadyExists: Prüfung ist bereits eingetragen ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
ExamRoomName: Interne Bezeichnung
ExamRoom: Raum ExamRoom: Raum
ExamRoomCapacity: Kapazität ExamRoomCapacity: Kapazität
ExamRoomCapacityNegative: Kapazität darf nicht negativ sein ExamRoomCapacityNegative: Kapazität darf nicht negativ sein
@ -1167,10 +1169,11 @@ ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Bewertung abges
ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen
ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
ExamOccurrenceEndMustBeAfterStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss vor seinem Ende liegen ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen
ExamOccurrenceStartMustBeAfterExamStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss nach Beginn der Klausur liegen ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Klausur liegen
ExamOccurrenceEndMustBeBeforeExamEnd eoRoom@Text eoRange@Text: Ende des Termins #{eoRoom} #{eoRange} muss vor Ende der Klausur liegen ExamOccurrenceEndMustBeBeforeExamEnd eoName@ExamOccurrenceName: Ende des Termins #{eoName} muss vor Ende der Klausur liegen
ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor
ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor
VersionHistory: Versionsgeschichte VersionHistory: Versionsgeschichte
KnownBugs: Bekannte Bugs KnownBugs: Bekannte Bugs

2
models/exams
View File

@ -25,11 +25,13 @@ ExamPart
UniqueExamPart exam name UniqueExamPart exam name
ExamOccurrence ExamOccurrence
exam ExamId exam ExamId
name ExamOccurrenceName
room Text room Text
capacity Natural capacity Natural
start UTCTime start UTCTime
end UTCTime Maybe end UTCTime Maybe
description Html Maybe description Html Maybe
UniqueExamOccurrence exam name
ExamRegistration ExamRegistration
exam ExamId exam ExamId
user UserId user UserId

12
src/Data/CaseInsensitive/Instances.hs
View File

@ -29,6 +29,8 @@ import Web.HttpApiData
import Data.Binary (Binary) import Data.Binary (Binary)
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
import qualified Data.Csv as Csv
instance PersistField (CI Text) where instance PersistField (CI Text) where
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@ -86,11 +88,11 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
fromPathPiece = fmap CI.mk . fromPathPiece fromPathPiece = fmap CI.mk . fromPathPiece
toPathPiece = toPathPiece . CI.original toPathPiece = toPathPiece . CI.original
instance ToHttpApiData (CI Text) where instance ToHttpApiData s => ToHttpApiData (CI s) where
toUrlPiece = toUrlPiece . CI.original toUrlPiece = toUrlPiece . CI.original
toEncodedUrlPiece = toEncodedUrlPiece . CI.original toEncodedUrlPiece = toEncodedUrlPiece . CI.original
instance FromHttpApiData (CI Text) where instance (CI.FoldCase s, FromHttpApiData s) => FromHttpApiData (CI s) where
parseUrlPiece = fmap CI.mk . parseUrlPiece parseUrlPiece = fmap CI.mk . parseUrlPiece
instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
@ -101,3 +103,9 @@ instance (CI.FoldCase s, Binary s) => Binary (CI s) where
get = CI.mk <$> Binary.get get = CI.mk <$> Binary.get
put = Binary.put . CI.original put = Binary.put . CI.original
putList = Binary.putList . map CI.original putList = Binary.putList . map CI.original
instance Csv.ToField s => Csv.ToField (CI s) where
toField = Csv.toField . CI.original
instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where
parseField = fmap CI.original . Csv.parseField

15
src/Data/UUID/Instances.hs
View File

@ -3,12 +3,13 @@
module Data.UUID.Instances module Data.UUID.Instances
() where () where
import ClassyPrelude import ClassyPrelude.Yesod
import Data.UUID (UUID) import Data.UUID (UUID)
import qualified Data.UUID as UUID import qualified Data.UUID as UUID
import Database.Persist.Sql import Database.Persist.Sql
import Web.PathPieces
import Text.Blaze (ToMarkup(..))
instance PathPiece UUID where instance PathPiece UUID where
@ -25,3 +26,13 @@ instance PersistField UUID where
instance PersistFieldSql UUID where instance PersistFieldSql UUID where
sqlType _ = SqlOther "uuid" sqlType _ = SqlOther "uuid"
instance ToMarkup UUID where
toMarkup uuid = [shamlet|
$newline never
<span .uuid>
#{UUID.toText uuid}
|]
instance ToWidget site UUID where
toWidget = toWidget . toMarkup

2
src/Handler/Corrections.hs
View File

@ -168,7 +168,7 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary)) colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))

4
src/Handler/Course.hs
View File

@ -422,7 +422,7 @@ getCShowR tid ssh csh = do
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
return r return r
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) (toWidget examName) [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
@ -1053,7 +1053,7 @@ colUserComment tid ssh csh =
sortable (Just "note") (i18nCell MsgCourseUserNote) sortable (Just "note") (i18nCell MsgCourseUserNote)
$ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } -> $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
maybeEmpty mbNoteKey $ const $ maybeEmpty mbNoteKey $ const $
anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True) anchorCellM (courseLink <$> encrypt uid) (hasComment True)
where where
courseLink = CourseR tid ssh csh . CUserR courseLink = CourseR tid ssh csh . CUserR

37
src/Handler/Exam.hs
View File

@ -52,7 +52,7 @@ getCExamListR tid ssh csh = do
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
return x return x
dbtColonnade = dbColonnade . mconcat $ catMaybes dbtColonnade = dbColonnade . mconcat $ catMaybes
[ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) $ toWidget examName [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
, Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
@ -167,6 +167,7 @@ data ExamForm = ExamForm
data ExamOccurrenceForm = ExamOccurrenceForm data ExamOccurrenceForm = ExamOccurrenceForm
{ eofId :: Maybe CryptoUUIDExamOccurrence { eofId :: Maybe CryptoUUIDExamOccurrence
, eofName :: ExamOccurrenceName
, eofRoom :: Text , eofRoom :: Text
, eofCapacity :: Natural , eofCapacity :: Natural
, eofStart :: UTCTime , eofStart :: UTCTime
@ -279,7 +280,8 @@ examOccurrenceForm prev = wFormToAForm $ do
where where
examOccurrenceForm' nudge mPrev csrf = do examOccurrenceForm' nudge mPrev csrf = do
(eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
(eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev) (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev)
(eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev)
(eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
(eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
(eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
@ -287,6 +289,7 @@ examOccurrenceForm prev = wFormToAForm $ do
return ( ExamOccurrenceForm return ( ExamOccurrenceForm
<$> eofIdRes <$> eofIdRes
<*> eofNameRes
<*> eofRoomRes <*> eofRoomRes
<*> eofCapacityRes <*> eofCapacityRes
<*> eofStartRes <*> eofStartRes
@ -375,6 +378,7 @@ examFormTemplate (Entity eId Exam{..}) = do
(Just -> eofId, ExamOccurrence{..}) <- occurrences' (Just -> eofId, ExamOccurrence{..}) <- occurrences'
return ExamOccurrenceForm return ExamOccurrenceForm
{ eofId { eofId
, eofName = examOccurrenceName
, eofRoom = examOccurrenceRoom , eofRoom = examOccurrenceRoom
, eofCapacity = examOccurrenceCapacity , eofCapacity = examOccurrenceCapacity
, eofStart = examOccurrenceStart , eofStart = examOccurrenceStart
@ -459,11 +463,9 @@ validateExam = do
guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
eofRange' <- formatTimeRange SelFormatDateTime eofStart eofEnd guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofRoom eofRange') $ NTop eofEnd >= NTop (Just eofStart) guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofRoom eofRange') $ NTop (Just eofStart) >= NTop efStart
guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofRoom eofRange') $ NTop eofEnd <= NTop efEnd
forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
@ -475,6 +477,8 @@ validateExam = do
, (/=) `on` fmap renderHtml . eofDescription , (/=) `on` fmap renderHtml . eofDescription
] ]
guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamNewR = postCExamNewR getCExamNewR = postCExamNewR
@ -521,6 +525,7 @@ postCExamNewR tid ssh csh = do
[ ExamOccurrence{..} [ ExamOccurrence{..}
| ExamOccurrenceForm{..} <- Set.toList efOccurrences | ExamOccurrenceForm{..} <- Set.toList efOccurrences
, let examOccurrenceExam = examid , let examOccurrenceExam = examid
examOccurrenceName = eofName
examOccurrenceRoom = eofRoom examOccurrenceRoom = eofRoom
examOccurrenceCapacity = eofCapacity examOccurrenceCapacity = eofCapacity
examOccurrenceStart = eofStart examOccurrenceStart = eofStart
@ -594,6 +599,7 @@ postEEditR tid ssh csh examn = do
ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_ ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
ExamOccurrence ExamOccurrence
{ examOccurrenceExam = eId { examOccurrenceExam = eId
, examOccurrenceName = eofName
, examOccurrenceRoom = eofRoom , examOccurrenceRoom = eofRoom
, examOccurrenceCapacity = eofCapacity , examOccurrenceCapacity = eofCapacity
, examOccurrenceStart = eofStart , examOccurrenceStart = eofStart
@ -607,6 +613,7 @@ postEEditR tid ssh csh examn = do
guard $ examOccurrenceExam oldOcc == eId guard $ examOccurrenceExam oldOcc == eId
lift $ replace eofId' ExamOccurrence lift $ replace eofId' ExamOccurrence
{ examOccurrenceExam = eId { examOccurrenceExam = eId
, examOccurrenceName = eofName
, examOccurrenceRoom = eofRoom , examOccurrenceRoom = eofRoom
, examOccurrenceCapacity = eofCapacity , examOccurrenceCapacity = eofCapacity
, examOccurrenceStart = eofStart , examOccurrenceStart = eofStart
@ -672,7 +679,7 @@ getEShowR tid ssh csh examn = do
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
mUid <- maybeAuthId mUid <- maybeAuthId
(Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) <- runDB $ do (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
@ -712,7 +719,9 @@ getEShowR tid ssh csh examn = do
registered <- for mUid $ existsBy . UniqueExamRegistration eId registered <- for mUid $ existsBy . UniqueExamRegistration eId
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
registerWidget registerWidget
@ -772,6 +781,9 @@ queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
queryExamOccurrence = $(sqlLOJproj 3 2)
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
@ -800,7 +812,7 @@ data ExamUserTableCsv = ExamUserTableCsv
, csvUserField :: Maybe Text , csvUserField :: Maybe Text
, csvUserDegree :: Maybe Text , csvUserDegree :: Maybe Text
, csvUserSemester :: Maybe Int , csvUserSemester :: Maybe Int
, csvUserRoom :: Maybe Text , csvUserOccurrence :: Maybe (CI Text)
} }
deriving (Generic) deriving (Generic)
@ -843,7 +855,7 @@ postEUsersR tid ssh csh examn = do
, colField resultStudyField , colField resultStudyField
, colDegreeShort resultStudyDegree , colDegreeShort resultStudyDegree
, colFeaturesSemester resultStudyFeatures , colFeaturesSemester resultStudyFeatures
, sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence) , sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ sortUserNameLink queryUser [ sortUserNameLink queryUser
@ -853,6 +865,7 @@ postEUsersR tid ssh csh examn = do
, sortField queryStudyField , sortField queryStudyField
, sortDegreeShort queryStudyDegree , sortDegreeShort queryStudyDegree
, sortFeaturesSemester queryStudyFeatures , sortFeaturesSemester queryStudyFeatures
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
] ]
dbtFilter = Map.fromList dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser [ fltrUserNameEmail queryUser
@ -880,7 +893,7 @@ postEUsersR tid ssh csh examn = do
<*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceRoom) <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
examUsersDBTableValidator = def examUsersDBTableValidator = def

10
src/Handler/Home.hs
View File

@ -47,7 +47,7 @@ homeOpenCourses = do
let tid = courseTerm course let tid = courseTerm course
ssh = courseSchool course ssh = courseSchool course
csh = courseShorthand course csh = courseShorthand course
anchorCell (CourseR tid ssh csh CShowR) (toWidget csh) anchorCell (CourseR tid ssh csh CShowR) csh
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
] ]
@ -130,9 +130,9 @@ homeUpcomingSheets uid = do
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
textCell $ toMessage ssh textCell $ toMessage ssh
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } -> , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
anchorCell (CourseR tid ssh csh CShowR) (toWidget csh) anchorCell (CourseR tid ssh csh CShowR) csh
, sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } -> , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget shn) anchorCell (CSheetR tid ssh csh shn SShowR) shn
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } -> , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
@ -142,7 +142,7 @@ homeUpcomingSheets uid = do
whenM (hasWriteAccessTo submitRoute) $ whenM (hasWriteAccessTo submitRoute) $
modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR) (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
(toWidget $ hasTickmark True) (hasTickmark True)
] ]
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
@ -228,7 +228,7 @@ homeUpcomingExams uid = do
, sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
let Entity _ Exam{..} = view lensExam dbrOutput let Entity _ Exam{..} = view lensExam dbrOutput
Entity _ Course{..} = view lensCourse dbrOutput Entity _ Course{..} = view lensCourse dbrOutput
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) (toWidget examName) indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , 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 "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{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart

2
src/Handler/Sheet.hs
View File

@ -206,7 +206,7 @@ getSheetListR tid ssh csh = do
sheetCol = widgetColonnade . mconcat $ sheetCol = widgetColonnade . mconcat $
[ -- dbRow , [ -- dbRow ,
sortable (Just "name") (i18nCell MsgSheet) sortable (Just "name") (i18nCell MsgSheet)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName
, sortable (Just "last-edit") (i18nCell MsgLastEdit) , sortable (Just "last-edit") (i18nCell MsgLastEdit)
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime $ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince) , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)

2
src/Handler/SystemMessage.hs
View File

@ -165,7 +165,7 @@ postMessageListR = do
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId [ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
, dbRow , dbRow
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext) , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
, sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
, sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly

2
src/Handler/Tutorial.hs
View File

@ -61,7 +61,7 @@ getCTutorialListR tid ssh csh = do
<li> <li>
^{nameEmailWidget' tutor} ^{nameEmailWidget' tutor}
|] |]
, sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n
, sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime

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

@ -91,7 +91,7 @@ ifCell decision cTrue cFalse x
| otherwise = cFalse x | otherwise = cFalse x
linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
linkEmptyCell link wgt = linkEitherCell link (wgt,mempty) linkEmptyCell = anchorCell
msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a
msgCell = textCell . toMessage msgCell = textCell . toMessage
@ -123,7 +123,7 @@ isNewCell = cell . toWidget . isNew
commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
commentCell Nothing = mempty commentCell Nothing = mempty
commentCell (Just link) = anchorCell link icon commentCell (Just link) = anchorCell link icon
where icon = toWidget $ hasComment True where icon = hasComment True
-- | whether something is visible or hidden -- | whether something is visible or hidden
isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
@ -134,11 +134,11 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
-- | for simple file downloads -- | for simple file downloads
fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
fileCell route = anchorCell route $ toWidget fileDownload fileCell route = anchorCell route fileDownload
-- | for zip-archive downloads -- | for zip-archive downloads
zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a
zipCell route = anchorCell route $ toWidget zipDownload zipCell route = anchorCell route zipDownload
-- | Display an icon that opens a modal upon clicking -- | Display an icon that opens a modal upon clicking
modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a

46
src/Handler/Utils/Table/Pagination.hs
View File

@ -971,43 +971,47 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
-- | Always display widget; maybe a link if user is Authorized. -- | Always display widget; maybe a link if user is Authorized.
-- Also see variant `linkEmptyCell` -- Also see variant `linkEmptyCell`
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a
anchorCell = anchorCellM . return anchorCell = anchorCellM . return
{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-} anchorCell' :: ( IsDBTable m a
anchorCell' :: IsDBTable m a , ToWidget UniWorX wgt
=> (r -> Route UniWorX) , HasRoute UniWorX url
-> (r -> Widget) )
=> (r -> url)
-> (r -> wgt)
-> (r -> DBCell m a) -> (r -> DBCell m a)
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val) anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget) anchorCellM routeM widget = anchorCellM' routeM id (const widget)
anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = cell $ do anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
x <- xM
let route = x2route x
widget = x2widget x
authResult <- liftHandlerT $ isAuthorized route False
case authResult of
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
_otherwise -> widget -- don't show prohibited link
-- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user -- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user
linkEitherCell :: IsDBTable m a => Route UniWorX -> (Widget, Widget) -> DBCell m a linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => url -> (wgt, wgt') -> DBCell m a
linkEitherCell = linkEitherCellM . return linkEitherCell = linkEitherCellM . return
linkEitherCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> (Widget, Widget) -> DBCell m a linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> (wgt, wgt') -> DBCell m a
linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth) linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth)
linkEitherCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget, x -> Widget) -> DBCell m a linkEitherCellM' :: forall m url wgt wgt' a x.
( HasRoute UniWorX url
, ToWidget UniWorX wgt
, ToWidget UniWorX wgt'
, IsDBTable m a
, HandlerSite m ~ UniWorX
)
=> WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
x <- xM x <- xM
let route = x2route x let route = x2route x
widget = x2widgetAuth x widget, widgetUnauth :: WidgetT UniWorX IO ()
widgetUnauth = x2widgetUnauth x widget = toWidget $ x2widgetAuth x
authResult <- liftHandlerT $ isAuthorized route False widgetUnauth = toWidget $ x2widgetUnauth x
authResult <- liftHandlerT $ isAuthorized (urlRoute route) False
linkUrl <- toTextUrl route
case authResult of case authResult of
Authorized -> $(widgetFile "table/cell/link") -- show allowed link Authorized -> $(widgetFile "table/cell/link") -- show allowed link
_otherwise -> widgetUnauth -- show alternative widget _otherwise -> widgetUnauth -- show alternative widget

34
src/Model/Migration.hs
View File

@ -28,6 +28,8 @@ import Control.Monad.Trans.Reader (mapReaderT)
import Control.Monad.Except (MonadError(..)) import Control.Monad.Except (MonadError(..))
import Utils (exceptT) import Utils (exceptT)
import Numeric.Natural
-- Database versions must follow https://pvp.haskell.org: -- Database versions must follow https://pvp.haskell.org:
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
@ -57,7 +59,11 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
deriving Show Eq Ord deriving Show Eq Ord
|] |]
migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () migrateAll :: ( MonadLogger m
, MonadBaseControl IO m
, MonadIO m
)
=> ReaderT SqlBackend m ()
migrateAll = do migrateAll = do
$logDebugS "Migration" "Initial migration" $logDebugS "Migration" "Initial migration"
mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration
@ -77,14 +83,19 @@ migrateAll = do
$logDebugS "Migration" "Persistent automatic migration" $logDebugS "Migration" "Persistent automatic migration"
mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll'
requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool requiresMigration :: forall m.
( MonadLogger m
, MonadBaseControl IO m
, MonadIO m
)
=> ReaderT SqlBackend m Bool
requiresMigration = mapReaderT (exceptT return return) $ do requiresMigration = mapReaderT (exceptT return return) $ do
initial <- either id (map snd) <$> parseMigration initialMigration initial <- either id (map snd) <$> parseMigration initialMigration
when (not $ null initial) $ do when (not $ null initial) $ do
$logInfoS "Migration" $ intercalate "; " initial $logInfoS "Migration" $ intercalate "; " initial
throwError True throwError True
customs <- getMissingMigrations @_ @m customs <- mapReaderT lift $ getMissingMigrations @_ @m
when (not $ Map.null customs) $ do when (not $ Map.null customs) $ do
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
throwError True throwError True
@ -123,7 +134,8 @@ getMissingMigrations = do
-} -}
customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) customMigrations :: ( MonadIO m
) => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
customMigrations = Map.fromListWith (>>) customMigrations = Map.fromListWith (>>)
[ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|] [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
, whenM (columnExists "user" "theme") $ do -- New theme format , whenM (columnExists "user" "theme") $ do -- New theme format
@ -292,6 +304,20 @@ customMigrations = Map.fromListWith (>>)
, whenM (tableExists "exam") $ -- Exams were an unused stub before , whenM (tableExists "exam") $ -- Exams were an unused stub before
tableDropEmpty "exam" tableDropEmpty "exam"
) )
, ( AppliedMigrationKey [migrationVersion|13.0.0|] [version|14.0.0|]
, whenM ((&&) <$> tableExists "exam_occurrence" <*> (not <$> columnExists "exam_occurrence" "name")) $ do
examOccurrences <- [sqlQQ| SELECT "id" FROM "exam_occurrence" ORDER BY "exam"; |]
[executeQQ|
ALTER TABLE "exam_occurrence" ADD COLUMN "name" citext DEFAULT null;
|]
forM_ (zip [0..] examOccurrences) $ \(n :: Natural, Single eoId :: Single ExamOccurrenceId) -> do
let name = [st|occ-#{tshow n}|]
[executeQQ| UPDATE "exam_occurrence" SET "name" = #{name} WHERE "id" = #{eoId} |]
[executeQQ|
ALTER TABLE "exam_occurrence" ALTER COLUMN "name" DROP DEFAULT;
ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL;
|]
)
] ]

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

@ -16,19 +16,20 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
type Count = Sum Integer type Count = Sum Integer
type Points = Centi type Points = Centi
type Email = Text type Email = Text
type SchoolName = CI Text type SchoolName = CI Text
type SchoolShorthand = CI Text type SchoolShorthand = CI Text
type CourseName = CI Text type CourseName = CI Text
type CourseShorthand = CI Text type CourseShorthand = CI Text
type SheetName = CI Text type SheetName = CI Text
type MaterialName = CI Text type MaterialName = CI Text
type UserEmail = CI Email type UserEmail = CI Email
type UserIdent = CI Text type UserIdent = CI Text
type TutorialName = CI Text type TutorialName = CI Text
type ExamName = CI Text type ExamName = CI Text
type ExamPartName = CI Text type ExamPartName = CI Text
type ExamOccurrenceName = CI Text
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
type InstanceId = UUID type InstanceId = UUID

5
templates/default-layout.lucius
View File

@ -637,3 +637,8 @@ section {
font-weight: var(--weight, 600); font-weight: var(--weight, 600);
background-color: rgba(var(--red), var(--green), 0, var(--opacity)); background-color: rgba(var(--red), var(--green), 0, var(--opacity));
} }
.uuid {
font-family: monospace;
}

8
templates/exam-show.hamlet
View File

@ -93,6 +93,10 @@ $if not (null occurrences)
<table .table .table--striped .table--hover> <table .table .table--striped .table--hover>
<thead> <thead>
<tr .table__row .table__row--head> <tr .table__row .table__row--head>
$if occurrenceNamesShown
<th .table__th>
_{MsgExamRoomName}
^{isVisible False}
<th .table__th>_{MsgExamRoom} <th .table__th>_{MsgExamRoom}
$if not examTimes $if not examTimes
<th .table__th>_{MsgExamRoomTime} <th .table__th>_{MsgExamRoomTime}
@ -103,8 +107,10 @@ $if not (null occurrences)
$if not occurrenceAssignmentsVisible $if not occurrenceAssignmentsVisible
\ ^{isVisible False} \ ^{isVisible False}
<tbody> <tbody>
$forall (Entity _occId ExamOccurrence{examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences $forall (Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences
<tr .table__row :occurrenceAssignmentsShown && not registered:.occurrence--not-registered> <tr .table__row :occurrenceAssignmentsShown && not registered:.occurrence--not-registered>
$if occurrenceNamesShown
<td .table__td #exam-occurrence__#{examOccurrenceName}>#{examOccurrenceName}
<td .table__td>#{examOccurrenceRoom} <td .table__td>#{examOccurrenceRoom}
$if not examTimes $if not examTimes
<td .table__td> <td .table__td>

2
templates/table/cell/link.hamlet
View File

@ -1,3 +1,3 @@
$newline never $newline never
<a href=@{route}> <a href=#{linkUrl}>
^{widget} ^{widget}

3
templates/widgets/massinput/examRooms/form.hamlet
View File

@ -1,5 +1,6 @@
$newline never $newline never
<td>#{csrf}^{fvInput eofIdView}^{fvInput eofRoomView} <td>#{csrf}^{fvInput eofIdView}^{fvInput eofNameView}
<td>^{fvInput eofRoomView}
<td>^{fvInput eofCapacityView} <td>^{fvInput eofCapacityView}
<td>^{fvInput eofStartView} <td>^{fvInput eofStartView}
<td>^{fvInput eofEndView} <td>^{fvInput eofEndView}

1
templates/widgets/massinput/examRooms/layout.hamlet
View File

@ -1,6 +1,7 @@
$newline never $newline never
<table> <table>
<thead> <thead>
<th>_{MsgExamRoomName}
<th>_{MsgExamRoom} <th>_{MsgExamRoom}
<th>_{MsgExamRoomCapacity} <th>_{MsgExamRoomCapacity}
<th>_{MsgExamRoomStart} <th>_{MsgExamRoomStart}