feat(exams): introduce examOccurrenceName
BREAKING CHANGE: examOccurrenceName
This commit is contained in:
Gregor Kleen
parent
05e7b52f08
commit
379a7edd12
@ -1108,8 +1108,10 @@ ExamRoomSurname': Nach Nachname
|
||||
ExamRoomMatriculation': Nach Matrikelnummer
|
||||
ExamRoomRandom': Zufällig pro Teilnehmer
|
||||
|
||||
ExamOccurrence: Termin/Raum
|
||||
ExamOccurrences: Prüfungen
|
||||
ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
|
||||
ExamRoomName: Interne Bezeichnung
|
||||
ExamRoom: Raum
|
||||
ExamRoomCapacity: Kapazität
|
||||
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
|
||||
ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
|
||||
|
||||
ExamOccurrenceEndMustBeAfterStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss vor seinem Ende liegen
|
||||
ExamOccurrenceStartMustBeAfterExamStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss nach Beginn der Klausur liegen
|
||||
ExamOccurrenceEndMustBeBeforeExamEnd eoRoom@Text eoRange@Text: Ende des Termins #{eoRoom} #{eoRange} muss vor Ende der Klausur liegen
|
||||
ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen
|
||||
ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn 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
|
||||
ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor
|
||||
|
||||
VersionHistory: Versionsgeschichte
|
||||
KnownBugs: Bekannte Bugs
|
||||
|
||||
@ -25,11 +25,13 @@ ExamPart
|
||||
UniqueExamPart exam name
|
||||
ExamOccurrence
|
||||
exam ExamId
|
||||
name ExamOccurrenceName
|
||||
room Text
|
||||
capacity Natural
|
||||
start UTCTime
|
||||
end UTCTime Maybe
|
||||
description Html Maybe
|
||||
UniqueExamOccurrence exam name
|
||||
ExamRegistration
|
||||
exam ExamId
|
||||
user UserId
|
||||
|
||||
@ -29,6 +29,8 @@ import Web.HttpApiData
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
|
||||
instance PersistField (CI Text) where
|
||||
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
|
||||
toPathPiece = toPathPiece . CI.original
|
||||
|
||||
instance ToHttpApiData (CI Text) where
|
||||
instance ToHttpApiData s => ToHttpApiData (CI s) where
|
||||
toUrlPiece = toUrlPiece . 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
|
||||
|
||||
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
|
||||
put = Binary.put . 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
|
||||
|
||||
@ -3,12 +3,13 @@
|
||||
module Data.UUID.Instances
|
||||
() where
|
||||
|
||||
import ClassyPrelude
|
||||
import ClassyPrelude.Yesod
|
||||
import Data.UUID (UUID)
|
||||
import qualified Data.UUID as UUID
|
||||
|
||||
import Database.Persist.Sql
|
||||
import Web.PathPieces
|
||||
|
||||
import Text.Blaze (ToMarkup(..))
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
@ -25,3 +26,13 @@ instance PersistField UUID where
|
||||
|
||||
instance PersistFieldSql UUID where
|
||||
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
|
||||
|
||||
@ -168,7 +168,7 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
|
||||
|
||||
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
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")]
|
||||
|
||||
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
|
||||
|
||||
@ -422,7 +422,7 @@ getCShowR tid ssh csh = do
|
||||
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
|
||||
return r
|
||||
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-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
|
||||
@ -1053,7 +1053,7 @@ colUserComment tid ssh csh =
|
||||
sortable (Just "note") (i18nCell MsgCourseUserNote)
|
||||
$ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
|
||||
maybeEmpty mbNoteKey $ const $
|
||||
anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True)
|
||||
anchorCellM (courseLink <$> encrypt uid) (hasComment True)
|
||||
where
|
||||
courseLink = CourseR tid ssh csh . CUserR
|
||||
|
||||
|
||||
@ -52,7 +52,7 @@ getCExamListR tid ssh csh = do
|
||||
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
|
||||
return x
|
||||
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
|
||||
, 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
|
||||
@ -167,6 +167,7 @@ data ExamForm = ExamForm
|
||||
|
||||
data ExamOccurrenceForm = ExamOccurrenceForm
|
||||
{ eofId :: Maybe CryptoUUIDExamOccurrence
|
||||
, eofName :: ExamOccurrenceName
|
||||
, eofRoom :: Text
|
||||
, eofCapacity :: Natural
|
||||
, eofStart :: UTCTime
|
||||
@ -279,7 +280,8 @@ examOccurrenceForm prev = wFormToAForm $ do
|
||||
where
|
||||
examOccurrenceForm' nudge mPrev csrf = do
|
||||
(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)
|
||||
(eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
|
||||
(eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
|
||||
@ -287,6 +289,7 @@ examOccurrenceForm prev = wFormToAForm $ do
|
||||
|
||||
return ( ExamOccurrenceForm
|
||||
<$> eofIdRes
|
||||
<*> eofNameRes
|
||||
<*> eofRoomRes
|
||||
<*> eofCapacityRes
|
||||
<*> eofStartRes
|
||||
@ -375,6 +378,7 @@ examFormTemplate (Entity eId Exam{..}) = do
|
||||
(Just -> eofId, ExamOccurrence{..}) <- occurrences'
|
||||
return ExamOccurrenceForm
|
||||
{ eofId
|
||||
, eofName = examOccurrenceName
|
||||
, eofRoom = examOccurrenceRoom
|
||||
, eofCapacity = examOccurrenceCapacity
|
||||
, eofStart = examOccurrenceStart
|
||||
@ -459,11 +463,9 @@ validateExam = do
|
||||
guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd
|
||||
|
||||
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
|
||||
eofRange' <- formatTimeRange SelFormatDateTime eofStart eofEnd
|
||||
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofRoom eofRange') $ NTop eofEnd >= NTop (Just eofStart)
|
||||
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofRoom eofRange') $ NTop (Just eofStart) >= NTop efStart
|
||||
guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofRoom eofRange') $ NTop eofEnd <= NTop efEnd
|
||||
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
|
||||
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
|
||||
guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd
|
||||
|
||||
forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
|
||||
eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
|
||||
@ -475,6 +477,8 @@ validateExam = do
|
||||
, (/=) `on` fmap renderHtml . eofDescription
|
||||
]
|
||||
|
||||
guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
|
||||
|
||||
|
||||
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCExamNewR = postCExamNewR
|
||||
@ -521,6 +525,7 @@ postCExamNewR tid ssh csh = do
|
||||
[ ExamOccurrence{..}
|
||||
| ExamOccurrenceForm{..} <- Set.toList efOccurrences
|
||||
, let examOccurrenceExam = examid
|
||||
examOccurrenceName = eofName
|
||||
examOccurrenceRoom = eofRoom
|
||||
examOccurrenceCapacity = eofCapacity
|
||||
examOccurrenceStart = eofStart
|
||||
@ -594,6 +599,7 @@ postEEditR tid ssh csh examn = do
|
||||
ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
|
||||
ExamOccurrence
|
||||
{ examOccurrenceExam = eId
|
||||
, examOccurrenceName = eofName
|
||||
, examOccurrenceRoom = eofRoom
|
||||
, examOccurrenceCapacity = eofCapacity
|
||||
, examOccurrenceStart = eofStart
|
||||
@ -607,6 +613,7 @@ postEEditR tid ssh csh examn = do
|
||||
guard $ examOccurrenceExam oldOcc == eId
|
||||
lift $ replace eofId' ExamOccurrence
|
||||
{ examOccurrenceExam = eId
|
||||
, examOccurrenceName = eofName
|
||||
, examOccurrenceRoom = eofRoom
|
||||
, examOccurrenceCapacity = eofCapacity
|
||||
, examOccurrenceStart = eofStart
|
||||
@ -672,7 +679,7 @@ getEShowR tid ssh csh examn = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
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
|
||||
|
||||
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
|
||||
@ -712,7 +719,9 @@ getEShowR tid ssh csh examn = do
|
||||
registered <- for mUid $ existsBy . UniqueExamRegistration eId
|
||||
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
|
||||
registerWidget
|
||||
@ -772,6 +781,9 @@ queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
|
||||
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
|
||||
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 = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
|
||||
|
||||
@ -800,7 +812,7 @@ data ExamUserTableCsv = ExamUserTableCsv
|
||||
, csvUserField :: Maybe Text
|
||||
, csvUserDegree :: Maybe Text
|
||||
, csvUserSemester :: Maybe Int
|
||||
, csvUserRoom :: Maybe Text
|
||||
, csvUserOccurrence :: Maybe (CI Text)
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
@ -843,7 +855,7 @@ postEUsersR tid ssh csh examn = do
|
||||
, colField resultStudyField
|
||||
, colDegreeShort resultStudyDegree
|
||||
, 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
|
||||
[ sortUserNameLink queryUser
|
||||
@ -853,6 +865,7 @@ postEUsersR tid ssh csh examn = do
|
||||
, sortField queryStudyField
|
||||
, sortDegreeShort queryStudyDegree
|
||||
, sortFeaturesSemester queryStudyFeatures
|
||||
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameEmail queryUser
|
||||
@ -880,7 +893,7 @@ postEUsersR tid ssh csh examn = do
|
||||
<*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
|
||||
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
|
||||
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceRoom)
|
||||
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
examUsersDBTableValidator = def
|
||||
|
||||
@ -47,7 +47,7 @@ homeOpenCourses = do
|
||||
let tid = courseTerm course
|
||||
ssh = courseSchool 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} } ->
|
||||
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,_,_,_,_) } ->
|
||||
textCell $ toMessage ssh
|
||||
, 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, _, _) } ->
|
||||
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, _) } ->
|
||||
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) } ->
|
||||
@ -142,7 +142,7 @@ homeUpcomingSheets uid = do
|
||||
whenM (hasWriteAccessTo submitRoute) $
|
||||
modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute
|
||||
(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"]
|
||||
sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
|
||||
@ -228,7 +228,7 @@ homeUpcomingExams uid = do
|
||||
, 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)
|
||||
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-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
|
||||
|
||||
@ -206,7 +206,7 @@ getSheetListR tid ssh csh = do
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ -- dbRow ,
|
||||
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)
|
||||
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
|
||||
@ -165,7 +165,7 @@ postMessageListR = do
|
||||
dbtColonnade = mconcat
|
||||
[ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
|
||||
, 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 "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
|
||||
, sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
|
||||
|
||||
@ -61,7 +61,7 @@ getCTutorialListR tid ssh csh = do
|
||||
<li>
|
||||
^{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 "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom
|
||||
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime
|
||||
|
||||
@ -91,7 +91,7 @@ ifCell decision cTrue cFalse x
|
||||
| otherwise = cFalse x
|
||||
|
||||
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 = textCell . toMessage
|
||||
@ -123,7 +123,7 @@ isNewCell = cell . toWidget . isNew
|
||||
commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
|
||||
commentCell Nothing = mempty
|
||||
commentCell (Just link) = anchorCell link icon
|
||||
where icon = toWidget $ hasComment True
|
||||
where icon = hasComment True
|
||||
|
||||
-- | whether something is visible or hidden
|
||||
isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
|
||||
@ -134,11 +134,11 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
|
||||
|
||||
-- | for simple file downloads
|
||||
fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
|
||||
fileCell route = anchorCell route $ toWidget fileDownload
|
||||
fileCell route = anchorCell route fileDownload
|
||||
|
||||
-- | for zip-archive downloads
|
||||
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
|
||||
modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
|
||||
|
||||
@ -971,43 +971,47 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
|
||||
|
||||
-- | Always display widget; maybe a link if user is Authorized.
|
||||
-- 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
|
||||
|
||||
{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-}
|
||||
anchorCell' :: IsDBTable m a
|
||||
=> (r -> Route UniWorX)
|
||||
-> (r -> Widget)
|
||||
anchorCell' :: ( IsDBTable m a
|
||||
, ToWidget UniWorX wgt
|
||||
, HasRoute UniWorX url
|
||||
)
|
||||
=> (r -> url)
|
||||
-> (r -> wgt)
|
||||
-> (r -> DBCell m a)
|
||||
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' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
|
||||
anchorCellM' xM x2route x2widget = cell $ do
|
||||
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
|
||||
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 = linkEitherCellM' xM x2route (x2widget, x2widget)
|
||||
|
||||
-- | 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
|
||||
|
||||
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' :: 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
|
||||
x <- xM
|
||||
let route = x2route x
|
||||
widget = x2widgetAuth x
|
||||
widgetUnauth = x2widgetUnauth x
|
||||
authResult <- liftHandlerT $ isAuthorized route False
|
||||
widget, widgetUnauth :: WidgetT UniWorX IO ()
|
||||
widget = toWidget $ x2widgetAuth x
|
||||
widgetUnauth = toWidget $ x2widgetUnauth x
|
||||
authResult <- liftHandlerT $ isAuthorized (urlRoute route) False
|
||||
linkUrl <- toTextUrl route
|
||||
case authResult of
|
||||
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
|
||||
_otherwise -> widgetUnauth -- show alternative widget
|
||||
|
||||
@ -28,6 +28,8 @@ import Control.Monad.Trans.Reader (mapReaderT)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
import Utils (exceptT)
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
-- 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)
|
||||
-- - 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
|
||||
|]
|
||||
|
||||
migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m ()
|
||||
migrateAll :: ( MonadLogger m
|
||||
, MonadBaseControl IO m
|
||||
, MonadIO m
|
||||
)
|
||||
=> ReaderT SqlBackend m ()
|
||||
migrateAll = do
|
||||
$logDebugS "Migration" "Initial migration"
|
||||
mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration
|
||||
@ -77,14 +83,19 @@ migrateAll = do
|
||||
$logDebugS "Migration" "Persistent automatic migration"
|
||||
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
|
||||
initial <- either id (map snd) <$> parseMigration initialMigration
|
||||
when (not $ null initial) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " initial
|
||||
throwError True
|
||||
|
||||
customs <- getMissingMigrations @_ @m
|
||||
customs <- mapReaderT lift $ getMissingMigrations @_ @m
|
||||
when (not $ Map.null customs) $ do
|
||||
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
||||
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 (>>)
|
||||
[ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
|
||||
, whenM (columnExists "user" "theme") $ do -- New theme format
|
||||
@ -292,6 +304,20 @@ customMigrations = Map.fromListWith (>>)
|
||||
, whenM (tableExists "exam") $ -- Exams were an unused stub before
|
||||
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;
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -16,19 +16,20 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
type Count = Sum Integer
|
||||
type Points = Centi
|
||||
|
||||
type Email = Text
|
||||
type Email = Text
|
||||
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
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
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
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
|
||||
type ExamOccurrenceName = CI Text
|
||||
|
||||
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
|
||||
type InstanceId = UUID
|
||||
|
||||
@ -637,3 +637,8 @@ section {
|
||||
font-weight: var(--weight, 600);
|
||||
background-color: rgba(var(--red), var(--green), 0, var(--opacity));
|
||||
}
|
||||
|
||||
|
||||
.uuid {
|
||||
font-family: monospace;
|
||||
}
|
||||
|
||||
@ -93,6 +93,10 @@ $if not (null occurrences)
|
||||
<table .table .table--striped .table--hover>
|
||||
<thead>
|
||||
<tr .table__row .table__row--head>
|
||||
$if occurrenceNamesShown
|
||||
<th .table__th>
|
||||
_{MsgExamRoomName}
|
||||
^{isVisible False}
|
||||
<th .table__th>_{MsgExamRoom}
|
||||
$if not examTimes
|
||||
<th .table__th>_{MsgExamRoomTime}
|
||||
@ -103,8 +107,10 @@ $if not (null occurrences)
|
||||
$if not occurrenceAssignmentsVisible
|
||||
\ ^{isVisible False}
|
||||
<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>
|
||||
$if occurrenceNamesShown
|
||||
<td .table__td #exam-occurrence__#{examOccurrenceName}>#{examOccurrenceName}
|
||||
<td .table__td>#{examOccurrenceRoom}
|
||||
$if not examTimes
|
||||
<td .table__td>
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
$newline never
|
||||
<a href=@{route}>
|
||||
^{widget}
|
||||
<a href=#{linkUrl}>
|
||||
^{widget}
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
$newline never
|
||||
<td>#{csrf}^{fvInput eofIdView}^{fvInput eofRoomView}
|
||||
<td>#{csrf}^{fvInput eofIdView}^{fvInput eofNameView}
|
||||
<td>^{fvInput eofRoomView}
|
||||
<td>^{fvInput eofCapacityView}
|
||||
<td>^{fvInput eofStartView}
|
||||
<td>^{fvInput eofEndView}
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
$newline never
|
||||
<table>
|
||||
<thead>
|
||||
<th>_{MsgExamRoomName}
|
||||
<th>_{MsgExamRoom}
|
||||
<th>_{MsgExamRoomCapacity}
|
||||
<th>_{MsgExamRoomStart}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user