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

chore(daily): adjust css, improve suggestions

Browse Source
This commit is contained in:
Steffen Jost 2024-11-26 18:03:43 +01:00 committed by Sarah Vaupel
parent 564488d5fa
commit 1f7e9b6a2f
8 changed files with 334 additions and 234 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
frontend/src/utils/inputs/inputs.sass
View File

@ -163,7 +163,6 @@ input[type*='time'],
// TEXTAREAS
textarea
width: 100%
height: 170px
max-width: 600px
line-height: 1.5
color: #363636
@ -176,6 +175,8 @@ textarea
border-radius: 2px
box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05)
vertical-align: top
&:not(.uwx-short)
height: 172px
// SHARED STATE RELATED STYLES
@ -211,10 +212,11 @@ option
border-radius: 2px
outline: 0
color: #363636
min-width: 250px
width: auto
background-color: #f3f3f3
box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05)
&:not(.uwx-narrow)
min-width: 250px
@media (max-width: 425px)
select, option

6
src/Handler/Admin/Avs.hs
View File

@ -734,11 +734,9 @@ mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
E.orderBy [E.desc countRows']
E.limit 7
pure (qblock E.^. QualificationUserBlockReason)
mkOption :: E.Value Text -> Option Text
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not__)
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
suggestionsBlock = mkOptionListText <$> runDBRead (getBlockReasons E.not__)
suggestionsUnblock = mkOptionListText <$> runDBRead (getBlockReasons id)
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
acts = mconcat

6
src/Handler/Health/Interface.hs
View File

@ -308,17 +308,15 @@ wildcardCell c (Just x) = c x
mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget)
mkInterfaceWarnTable = do
let
mkOption :: E.Value Text -> Option Text
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
getSuggestion pj = E.select $ E.distinct $ do
il <- E.from $ E.table @InterfaceLog
let res = il E.^. pj
E.orderBy [E.asc res]
pure res
suggestionInterface :: HandlerFor UniWorX (OptionList Text)
suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface)
suggestionInterface = mkOptionList . fmap mkOptionText <$> runDB (getSuggestion InterfaceLogInterface)
suggestionSubtype :: HandlerFor UniWorX (OptionList Text)
suggestionSubtype = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype)
suggestionSubtype = mkOptionList . fmap mkOptionText <$> runDB (getSuggestion InterfaceLogSubtype)
dbtIdent = "interface-warnings" :: Text
dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr
dbtSQLQuery = return

6
src/Handler/Qualification.hs
View File

@ -538,11 +538,9 @@ postQualificationR sid qsh = do
Ex.orderBy [Ex.desc countRows']
Ex.limit 9
pure (qblock Ex.^. QualificationUserBlockReason)
mkOption :: Ex.Value Text -> Option Text
mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_)
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
suggestionsBlock = mkOptionListText <$> runDB (getBlockReasons Ex.not_)
suggestionsUnblock = mkOptionListText <$> runDB (getBlockReasons id)
dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat $

501
src/Handler/School/DayTasks.hs
View File

@ -264,17 +264,17 @@ colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDri
id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
(views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
(\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique ->
over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x)
over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit" & addClass' "uwx-narrow") (Just x)
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam
colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:2%")]) <$> formCell id
colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id
(views (resultParticipant . _entityKey) return)
(\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique ->
over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x)
over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam" & addClass' "uwx-narrow") (Just x)
)
-- colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
@ -290,75 +290,139 @@ colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialN
(views (resultParticipant . _entityKey) return)
(\row mkUnique ->
let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote
sid = row ^. resultCourse . _entityVal . _courseSchool
cid = row ^. resultCourse . _entityKey
tid = row ^. resultTutorial . _entityKey
in over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$>
mopt (textField & cfStrip & addDatalist (suggsParticipantNote cid tid)) (fsUniq mkUnique "note-tutorial") (Just note)
mopt (textField & cfStrip & addDatalist (suggsParticipantNote sid cid tid)) (fsUniq mkUnique "note-tutorial") (Just note)
)
-- deriving instance (Generic a) => Generic (OptionList a)
-- deriving instance (Binary a, Generic a) => Binary (OptionList a)
-- deriving instance Generic (OptionList Text)
-- deriving instance Binary (OptionList Text)
deriving instance Generic (Option Text)
deriving instance Binary (Option Text)
suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
suggsParticipantNote sid cid tid = do
ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough?
suggs <- runDB $ E.select $ do
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
(tpn, prio) <- E.from $
( do
tpa <- E.from $ E.table @TutorialParticipant
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid
E.groupBy $ tpa E.^. TutorialParticipantNote
E.orderBy [E.desc countRows']
E.limit maxSuggestions
pure (tpa E.^. TutorialParticipantNote, E.val (1 :: Int64))
) `E.unionAll_`
( do
(tpa :& tut) <- E.from $ E.table @TutorialParticipant
`E.innerJoin` E.table @Tutorial
`E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial)
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid
E.&&. tut E.^. TutorialCourse E.==. E.val cid
E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote)
E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
E.limit maxSuggestions
pure (tpa E.^. TutorialParticipantNote, E.val 2)
) `E.unionAll_`
( do
tpa :& tut :& crs <- E.from $ E.table @TutorialParticipant
`E.innerJoin` E.table @Tutorial
`E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial)
`E.innerJoin` E.table @Course
`E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId)
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid
E.&&. tut E.^. TutorialCourse E.!=. E.val cid
E.&&. crs E.^. CourseSchool E.==. E.val sid
E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote)
E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
E.limit maxSuggestions
pure (tpa E.^. TutorialParticipantNote, E.val 3)
)
E.groupBy (tpn, prio)
E.orderBy [E.asc prio, E.asc tpn]
E.limit maxSuggestions
pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type
-- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs
pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs
-- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol
pure $ mkOptionListFromCacheable ol
suggsParticipantNote :: CourseId -> TutorialId -> Handler (OptionList Text)
suggsParticipantNote cid tid = $(memcachedByHere) (Just . Right $ 12 * diffSecond) (cid,tid) $ runDB $ do -- TODO: better memcached key
let qry :: E.SqlQuery (E.SqlExpr (E.Value Text)) = do
(prio, tpn) <- E.from $
( do
tpa <- E.from $ E.table @TutorialParticipant
E.distinct $ pure ()
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid
E.limit maxSuggestions
pure (E.val (1 :: Int64), tpa E.^. TutorialParticipantNote)
) `E.unionAll_`
( do
(tpa :& tut) <- E.from $ E.table @TutorialParticipant
`E.innerJoin` E.table @Tutorial
`E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial)
E.distinct $ pure ()
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
E.&&. tut E.^. TutorialCourse E.==. E.val cid
E.orderBy [E.desc $ tut E.^. TutorialLastChanged]
E.limit maxSuggestions
pure (E.val 2, tpa E.^. TutorialParticipantNote)
) `E.unionAll_`
( do
tpa <- E.from $ E.table @TutorialParticipant
E.distinct $ pure ()
E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote)
E.limit maxSuggestions
pure (E.val 3, tpa E.^. TutorialParticipantNote)
)
E.orderBy [E.asc prio, E.asc tpn]
E.limit maxSuggestions
pure $ E.coalesceDefault [tpn] $ E.val ""
mkOptionsE qry (pure . E.unValue) (pure . text2message . E.unValue) (pure . toPathPiece . E.unValue)
suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Textarea)
suggsAttendanceNote sid cid tid = do
ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough?
suggs <- runDB $ E.select $ do
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
(tpn, prio) <- E.from $
( do
tpa <- E.from $ E.table @TutorialParticipantDay
E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
E.&&. tpa E.^. TutorialParticipantDayTutorial E.==. E.val tid
E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay)
E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows']
E.limit maxSuggestions
pure (tpa E.^. TutorialParticipantDayNote, E.val (1 :: Int64))
-- ) `E.unionAll_`
-- ( do
-- (tpa :& tut) <- E.from $ E.table @TutorialParticipantDay
-- `E.innerJoin` E.table @Tutorial
-- `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial)
-- E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
-- E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid
-- E.&&. tut E.^. TutorialCourse E.==. E.val cid
-- E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote)
-- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows']
-- E.limit maxSuggestions
-- pure (tpa E.^. TutorialParticipantDayNote, E.val 2)
-- ) `E.unionAll_`
-- ( do
-- tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay
-- `E.innerJoin` E.table @Tutorial
-- `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial)
-- `E.innerJoin` E.table @Course
-- `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId)
-- E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote)
-- E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid
-- E.&&. tut E.^. TutorialCourse E.!=. E.val cid
-- E.&&. crs E.^. CourseSchool E.==. E.val sid
-- E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote)
-- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows']
-- E.limit maxSuggestions
-- pure (tpa E.^. TutorialParticipantDayNote, E.val 3)
)
E.groupBy (tpn, prio)
E.orderBy [E.asc prio, E.asc tpn]
E.limit maxSuggestions
pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type
-- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs
pure $ mkOptionListCacheable $ fmap Textarea . mkOptionText <$> nubOrd suggs -- TODO: datalist does not work on textarea inputs!
-- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol
pure $ mkOptionListFromCacheable ol
suggsAttentionNote :: Handler (OptionList Textarea)
suggsAttentionNote = error "TODO"
colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id
colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id
(views (resultParticipant . _entityKey) return)
(\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique ->
over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance
)
colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$> formCell id
colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ -- (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$>
formCell id
(views (resultParticipant . _entityKey) return)
(\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique ->
over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
mopt textareaField (fsUniq mkUnique "note-attendance"
-- & addAutosubmit -- submits while typing
& addAttr "cols" "7"
& addAttr "rows" "2" -- does not work if height is set via css (search "170px")
) (Textarea <<$>> note)
(\row mkUnique ->
let note = row ^? resultParticipantDay . _tutorialParticipantDayNote
sid = row ^. resultCourse . _entityVal . _courseSchool
cid = row ^. resultCourse . _entityKey
tid = row ^. resultTutorial . _entityKey
in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
mopt (textareaField & addDatalist (suggsAttendanceNote sid cid tid)) -- TODO: datalist does not work on textarea inputs!
(fsUniq mkUnique "note-attendance" & addClass' "uwx-short"
-- & addAttr "rows" "2" -- does not work without class uwx-short
-- & addAttr "cols" "12" -- let it stretch
-- & addAutosubmit -- submits while typing
) (Textarea <<$>> note)
)
colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
@ -372,7 +436,7 @@ colParkingField = colParkingField' _dailyFormParkingToken
-- )
colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell
colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell
id -- TODO: this should not be id! Refactor to simplify the thrid argument below
(views (resultParticipant . _entityKey) return)
(\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
@ -380,166 +444,168 @@ colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToke
)
mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget)
mkDailyTable isAdmin ssh nd = do
tutLessons <- getDayTutorials' ssh (nd,nd)
dday <- formatTime SelFormatDate nd
let
tutIds = Map.keys tutLessons
dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial
E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser
E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay
EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser
E.&&. E.val nd E.=?. udy E.?. UserDayDay
EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser
EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser
EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial
EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
let cqQual = cq E.^. CourseQualificationQualification
cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
dbtProj = dbtProjId
dbtColonnade = formColonnade $ mconcat
[ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
, sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row ->
let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh}
= row ^. resultCourse . _entityVal
tutName = row ^. resultTutorial . _entityVal . _tutorialName
in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
, sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
-- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
-- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
, sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
-- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
-- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
, sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
primComp = row ^? resultCompanyId
bookLink = cellMaybe companyIdCell bookComp
result
| primComp /= bookComp
, Just (unCompanyKey -> csh) <- primComp
= bookLink
<> spacerCell
<> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
(Just IconCompanyWarning) True)
| otherwise = bookLink
in result
-- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
-- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
-- primComp = row ^? resultCompanyId
-- bookLink = cellMaybe companyIdCell bookComp
-- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True
-- result
-- | primComp /= bookComp
-- , Just (unCompanyKey -> csh) <- primComp
-- = bookLink
-- <> spacerCell
-- <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead!
-- [whamlet|
-- <h2>
-- ^{userWidget row}
-- <p>
-- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
-- |]
-- ))
-- | otherwise = bookLink
-- in result
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
, colUserMatriclenr isAdmin
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
, colParticipantPermitField
, colParticipantEyeExamField
, colParticipantNoteField
, colAttendanceField dday
, colAttendanceNoteField dday
, colParkingField
-- FOR DEBUGGING ONLY
-- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
-- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell
-- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell
-- , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell
-- , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell
-- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
]
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, sortUserMatriclenr queryUser
, ("course" , SortColumn $ queryCourse >>> (E.^. CourseName))
, ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName))
, ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime)
, ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
, ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo))
, ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
, ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
, ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote))
, ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
, ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
, ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken))
]
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
, fltrUserMatriclenr queryUser
, ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName))
, ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
, ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime)
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse)
, prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial)
, prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany)
, fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
dbtIdent :: Text
dbtIdent = "daily"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd }
-- dbtParams = DBParamsForm
-- { dbParamsFormMethod = POST
-- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
-- , dbParamsFormAttrs = []
-- , dbParamsFormSubmit = FormSubmit
-- , dbParamsFormAdditional = \frag -> do
-- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
-- acts = mconcat
-- [ singletonMap DailyActDummy $ pure DailyActDummyData
-- ]
-- (actionRes, action) <- multiActionM acts "" Nothing mempty
-- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
-- -- , dbParamsFormAdditional
-- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
-- -- acts = mconcat
-- -- [ singletonMap DailyActDummy $ pure DailyActDummyData
-- -- ]
-- -- in renderAForm FormStandard
-- -- $ (, mempty) . First . Just
-- -- <$> multiActionA acts (fslI MsgTableAction) Nothing
-- , dbParamsFormEvaluate = liftHandler . runFormPost
-- , dbParamsFormResult = _1
-- , dbParamsFormIdent = def
-- }
-- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData)
-- -> FormResult ( DailyTableActionData, Set TutorialId)
-- postprocess inp = do
-- (First (Just act), jobMap) <- inp
-- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
-- return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
-- over _1 postprocess <$> dbTable psValidator DBTable{..}
dbTable psValidator DBTable{..}
mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case
tutLessons
| Map.null tutLessons -> return (FormMissing, [whamlet|No tutorials on this day|])
| otherwise -> do
dday <- formatTime SelFormatDate nd
let
tutIds = Map.keys tutLessons
dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do
EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial
E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser
E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay
EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser
E.&&. E.val nd E.=?. udy E.?. UserDayDay
EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser
EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser
EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial
EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
let cqQual = cq E.^. CourseQualificationQualification
cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
dbtProj = dbtProjId
dbtColonnade = formColonnade $ mconcat
[ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
, sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row ->
let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh}
= row ^. resultCourse . _entityVal
tutName = row ^. resultTutorial . _entityVal . _tutorialName
in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
, sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
-- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
-- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now
, sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
-- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
-- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
, sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
primComp = row ^? resultCompanyId
bookLink = cellMaybe companyIdCell bookComp
result
| primComp /= bookComp
, Just (unCompanyKey -> csh) <- primComp
= bookLink
<> spacerCell
<> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
(Just IconCompanyWarning) True)
| otherwise = bookLink
in result
-- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
-- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
-- primComp = row ^? resultCompanyId
-- bookLink = cellMaybe companyIdCell bookComp
-- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True
-- result
-- | primComp /= bookComp
-- , Just (unCompanyKey -> csh) <- primComp
-- = bookLink
-- <> spacerCell
-- <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead!
-- [whamlet|
-- <h2>
-- ^{userWidget row}
-- <p>
-- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
-- |]
-- ))
-- | otherwise = bookLink
-- in result
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
, colUserMatriclenr isAdmin
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
, colParticipantPermitField
, colParticipantEyeExamField
, colParticipantNoteField
, colAttendanceField dday
, colAttendanceNoteField dday
, colParkingField
-- FOR DEBUGGING ONLY
-- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell
-- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell
-- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell
-- , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell
-- , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell
-- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
]
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, sortUserMatriclenr queryUser
, ("course" , SortColumn $ queryCourse >>> (E.^. CourseName))
, ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName))
, ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime)
, ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany))
, ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo))
, ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit))
, ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam))
, ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote))
, ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
, ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
, ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken))
]
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
, fltrUserMatriclenr queryUser
, ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName))
, ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
, ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime)
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse)
, prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial)
, prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany)
, fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
dbtIdent :: Text
dbtIdent = "daily"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd }
-- dbtParams = DBParamsForm
-- { dbParamsFormMethod = POST
-- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
-- , dbParamsFormAttrs = []
-- , dbParamsFormSubmit = FormSubmit
-- , dbParamsFormAdditional = \frag -> do
-- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
-- acts = mconcat
-- [ singletonMap DailyActDummy $ pure DailyActDummyData
-- ]
-- (actionRes, action) <- multiActionM acts "" Nothing mempty
-- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
-- -- , dbParamsFormAdditional
-- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
-- -- acts = mconcat
-- -- [ singletonMap DailyActDummy $ pure DailyActDummyData
-- -- ]
-- -- in renderAForm FormStandard
-- -- $ (, mempty) . First . Just
-- -- <$> multiActionA acts (fslI MsgTableAction) Nothing
-- , dbParamsFormEvaluate = liftHandler . runFormPost
-- , dbParamsFormResult = _1
-- , dbParamsFormIdent = def
-- }
-- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData)
-- -> FormResult ( DailyTableActionData, Set TutorialId)
-- postprocess inp = do
-- (First (Just act), jobMap) <- inp
-- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
-- return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
-- over _1 postprocess <$> dbTable psValidator DBTable{..}
dbTable psValidator DBTable{..}
getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html
@ -557,6 +623,7 @@ postSchoolDayR ssh nd = do
, dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False
}
(fmap unFormResult -> tableRes,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
$logInfoS "****DailyTable****" $ tshow tableRes
formResult tableRes $ \resMap -> do
runDB $ do
forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do

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

@ -1593,6 +1593,28 @@ optionsPersistCryptoId filts ords toDisplay = do
ents <- runDB $ selectList filts ords
optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)
mkOptionText :: E.Value Text -> Option Text
mkOptionText (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
mkOptionListText :: [E.Value Text] -> OptionList Text
mkOptionListText = mkOptionList . fmap mkOptionText
data OptionListCacheable a = OptionListCacheable [Option a] (Map Text a)
deriving instance (Show a) => Show (OptionListCacheable a)
deriving instance Generic (OptionListCacheable Text)
deriving instance Binary (OptionListCacheable Text)
deriving instance Generic (OptionListCacheable Textarea)
deriving instance Binary (OptionListCacheable Textarea)
mkOptionListCacheable :: [Option a] -> OptionListCacheable a
mkOptionListCacheable ol = OptionListCacheable ol $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) ol
mkOptionListFromCacheable :: OptionListCacheable a -> OptionList a
mkOptionListFromCacheable (OptionListCacheable ol om) = OptionList
{ olOptions = ol
, olReadExternal = flip Map.lookup om
}
mkOptionsE :: forall a r b msg.
( RenderMessage UniWorX msg
, E.SqlSelect a r

4
src/Utils/Form.hs
View File

@ -185,6 +185,10 @@ addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) :
addClass :: PathPiece c => c -> FieldSettings site -> FieldSettings site
addClass = over _fsAttrs . Yesod.addClass . toPathPiece
-- for convenience
addClass' :: Text -> FieldSettings site -> FieldSettings site
addClass' = addClass
addClasses :: (MonoFoldable mono, PathPiece (Element mono)) => mono -> FieldSettings site -> FieldSettings site
addClasses = appEndo . foldMap (Endo . addClass)

17
src/Yesod/Form/Types/Instances.hs
View File

@ -7,10 +7,21 @@
module Yesod.Form.Types.Instances
() where
import Yesod.Form.Types
import Data.Default
import ClassyPrelude.Yesod
-- import Yesod.Form.Types
-- import Data.Default
import Data.Binary
instance Default (FieldSettings site) where
def = ""
deriving instance (Show a) => Show (Option a)
-- to memcache Option Text and Option Textarea
deriving instance Generic (Option Text)
deriving instance Binary (Option Text)
deriving newtype instance Binary Textarea
deriving instance Generic (Option Textarea)
deriving instance Binary (Option Textarea)