844 lines
50 KiB
Haskell
844 lines
50 KiB
Haskell
|
|
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only
|
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only
|
|
{-# OPTIONS_GHC -fno-warn-unused-matches #-} -- TODO during development only
|
|
|
|
module Handler.School.DayTasks
|
|
( getSchoolDayR, postSchoolDayR
|
|
, getSchoolDayCheckR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Company
|
|
import Handler.Utils.Occurrences
|
|
import Handler.Utils.Avs
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Aeson as Aeson
|
|
import qualified Data.Text as Text
|
|
|
|
-- import Database.Persist.Sql (updateWhereCount)
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.PostgreSQL.JSON ((@>.))
|
|
import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
-- | Maximal number of suggestions for note fields in Day Task view
|
|
maxSuggestions :: Int64
|
|
maxSuggestions = 7
|
|
|
|
-- data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing
|
|
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
-- instance Universe DailyTableAction
|
|
-- instance Finite DailyTableAction
|
|
-- nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
|
|
-- embedRenderMessage ''UniWorX ''DailyTableAction id
|
|
|
|
-- data DailyTableActionData = DailyActDummyData
|
|
-- deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
-- | partial JSON object to be used for filtering with "@>"
|
|
-- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions
|
|
occurrenceDayValue :: Day -> Value
|
|
occurrenceDayValue d = Aeson.object
|
|
[ "exceptions" Aeson..=
|
|
[ Aeson.object
|
|
[ "exception" Aeson..= ("occur"::Text)
|
|
, "day" Aeson..= d
|
|
] ] ]
|
|
|
|
{- More efficient DB-only version, but ignores regular schedules
|
|
getDayTutorials :: SchoolId -> Day -> DB [TutorialId]
|
|
getDayTutorials ssh d = E.unValue <<$>> E.select (do
|
|
(trm :& crs :& tut) <- E.from $ E.table @Term
|
|
`E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
|
|
`E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
|
|
E.where_ $ E.between (E.val d) (trm E.^. TermStart, trm E.^. TermEnd)
|
|
E.&&. crs E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d))
|
|
return $ tut E.^. TutorialId
|
|
)
|
|
-}
|
|
|
|
-- | Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable
|
|
data DailyCacheKeys
|
|
= CacheKeyTutorialOccurrences SchoolId (Day,Day)
|
|
| CacheKeySuggsParticipantNote SchoolId TutorialId
|
|
| CacheKeySuggsAttendanceNote SchoolId TutorialId
|
|
| CacheKeyTutorialCheckResults SchoolId Day
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriving anyclass (Hashable, Binary, NFData)
|
|
|
|
-- getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
|
|
-- getDayTutorials ssh dlimit@(dstart, dend )
|
|
-- | dstart > dend = return mempty
|
|
-- | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do -- same key is ok, distinguished by return type
|
|
-- candidates <- E.select $ do
|
|
-- (trm :& crs :& tut) <- E.from $ E.table @Term
|
|
-- `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
|
|
-- `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
|
|
-- E.where_ $ crs E.^. CourseSchool E.==. E.val ssh
|
|
-- E.&&. trm E.^. TermStart E.<=. E.val dend
|
|
-- E.&&. trm E.^. TermEnd E.>=. E.val dstart
|
|
-- return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart))
|
|
-- -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
|
|
-- return $ mapMaybe checkCandidate candidates
|
|
-- where
|
|
-- period = Set.fromAscList [dstart..dend]
|
|
|
|
-- checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case
|
|
-- checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _)
|
|
-- | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ
|
|
-- = Just tutId
|
|
-- | otherwise
|
|
-- = Nothing
|
|
|
|
-- | like the previous version above, but also returns the lessons occurring within the given time frame
|
|
-- Due to caching, we only use the more informative version, unless experiments with the full DB show otherwise
|
|
getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId (TutorialName, [LessonTime]))
|
|
getDayTutorials ssh dlimit@(dstart, dend )
|
|
| dstart > dend = return mempty
|
|
| otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do
|
|
candidates <- E.select $ do
|
|
(trm :& crs :& tut) <- E.from $ E.table @Term
|
|
`E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
|
|
`E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse)
|
|
E.where_ $ crs E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. trm E.^. TermStart E.<=. E.val dend
|
|
E.&&. trm E.^. TermEnd E.>=. E.val dstart
|
|
return (trm, tut)
|
|
-- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
|
|
return $ foldMap checkCandidate candidates
|
|
where
|
|
checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId (TutorialName, [LessonTime])
|
|
checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ, tutorialName=tName}})
|
|
| let lessons = Set.filter lessonFltr $ occurringLessons trm occ
|
|
, notNull lessons
|
|
= Map.singleton tutId (tName , Set.toAscList lessons) -- due to Set not having a Functor instance, we need mostly need lists anyway
|
|
| otherwise
|
|
= mempty
|
|
|
|
lessonFltr :: LessonTime -> Bool
|
|
lessonFltr LessonTime{..} = dstart <= localDay lessonStart
|
|
&& dend >= localDay lessonEnd
|
|
|
|
|
|
type DailyTableExpr =
|
|
( E.SqlExpr (Entity Course)
|
|
`E.InnerJoin` E.SqlExpr (Entity Tutorial)
|
|
`E.InnerJoin` E.SqlExpr (Entity TutorialParticipant)
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserDay))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity TutorialParticipantDay))
|
|
)
|
|
|
|
type DailyTableOutput = E.SqlQuery
|
|
( E.SqlExpr (Entity Course)
|
|
, E.SqlExpr (Entity Tutorial)
|
|
, E.SqlExpr (Entity TutorialParticipant)
|
|
, E.SqlExpr (Entity User)
|
|
, E.SqlExpr (Maybe (Entity UserAvs))
|
|
, E.SqlExpr (Maybe (Entity UserDay))
|
|
, E.SqlExpr (Maybe (Entity TutorialParticipantDay))
|
|
, E.SqlExpr (E.Value (Maybe CompanyId))
|
|
, E.SqlExpr (E.Value (Maybe [QualificationId]))
|
|
)
|
|
|
|
type DailyTableData = DBRow
|
|
( Entity Course
|
|
, Entity Tutorial
|
|
, Entity TutorialParticipant
|
|
, Entity User
|
|
, Maybe (Entity UserAvs)
|
|
, Maybe (Entity UserDay)
|
|
, Maybe (Entity TutorialParticipantDay)
|
|
, E.Value (Maybe CompanyId)
|
|
, E.Value (Maybe [QualificationId])
|
|
)
|
|
|
|
data DailyFormData = DailyFormData
|
|
{ dailyFormDrivingPermit :: Maybe UserDrivingPermit
|
|
, dailyFormEyeExam :: Maybe UserEyeExam
|
|
, dailyFormParticipantNote :: Maybe Text
|
|
, dailyFormAttendance :: Bool
|
|
, dailyFormAttendanceNote :: Maybe Text
|
|
, dailyFormParkingToken :: Bool
|
|
} deriving (Eq, Show)
|
|
|
|
makeLenses_ ''DailyFormData
|
|
|
|
-- force declarations before this point to avoid staging restrictions
|
|
$(return [])
|
|
|
|
|
|
queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
|
|
queryCourse = $(sqlMIXproj' ''DailyTableExpr 1)
|
|
|
|
queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
|
|
queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2)
|
|
|
|
queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant)
|
|
queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3)
|
|
-- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) -- reify seems problematic for now
|
|
|
|
queryUser :: DailyTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(sqlMIXproj' ''DailyTableExpr 4)
|
|
|
|
queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs))
|
|
queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5)
|
|
|
|
queryUserDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserDay))
|
|
queryUserDay = $(sqlMIXproj' ''DailyTableExpr 6)
|
|
|
|
queryParticipantDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity TutorialParticipantDay))
|
|
queryParticipantDay = $(sqlMIXproj' ''DailyTableExpr 7)
|
|
|
|
resultCourse :: Lens' DailyTableData (Entity Course)
|
|
resultCourse = _dbrOutput . _1
|
|
|
|
resultTutorial :: Lens' DailyTableData (Entity Tutorial)
|
|
resultTutorial = _dbrOutput . _2
|
|
|
|
resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant)
|
|
resultParticipant = _dbrOutput . _3
|
|
|
|
resultUser :: Lens' DailyTableData (Entity User)
|
|
resultUser = _dbrOutput . _4
|
|
|
|
resultUserAvs :: Traversal' DailyTableData UserAvs
|
|
resultUserAvs = _dbrOutput . _5 . _Just . _entityVal
|
|
|
|
resultUserDay :: Traversal' DailyTableData UserDay
|
|
resultUserDay = _dbrOutput . _6 . _Just . _entityVal
|
|
|
|
resultParticipantDay :: Traversal' DailyTableData TutorialParticipantDay
|
|
resultParticipantDay = _dbrOutput . _7 . _Just . _entityVal
|
|
|
|
resultCompanyId :: Traversal' DailyTableData CompanyId
|
|
resultCompanyId = _dbrOutput . _8 . _unValue . _Just
|
|
|
|
resultCourseQualis :: Traversal' DailyTableData [QualificationId]
|
|
resultCourseQualis = _dbrOutput . _9 . _unValue . _Just
|
|
|
|
|
|
instance HasEntity DailyTableData User where
|
|
hasEntity = resultUser
|
|
|
|
instance HasUser DailyTableData where
|
|
hasUser = resultUser . _entityVal
|
|
|
|
-- see colRatedField' for an example of formCell usage
|
|
|
|
drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit
|
|
drivingPermitField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite
|
|
|
|
eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam
|
|
eyeExamField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite
|
|
|
|
mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
|
mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell
|
|
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 lg -> x) mkUnique ->
|
|
over (_1.mapped) (ls .~) . over _2 fvWidget <$> mreq f (fsUniq mkUnique k) (Just x)
|
|
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
|
|
|
|
colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
|
colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit
|
|
|
|
colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
|
colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell
|
|
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" & 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: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" & addClass' "uwx-narrow") (Just x)
|
|
)
|
|
|
|
-- colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
|
-- colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
|
|
-- (views (resultParticipant . _entityKey) return)
|
|
-- (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique ->
|
|
-- over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
|
|
-- mopt textareaField (fsUniq mkUnique "note-tutorial") (Just $ Textarea <$> note)
|
|
-- )
|
|
|
|
colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
|
colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","min-width:12em")]) <$>
|
|
formCell id
|
|
(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 sid cid tid)) (fsUniq mkUnique "note-tutorial") (Just note)
|
|
)
|
|
|
|
suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
|
|
suggsParticipantNote sid cid tid = do
|
|
ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsParticipantNote sid tid) $ do
|
|
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
|
|
|
|
suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
|
|
suggsAttendanceNote sid cid tid = do
|
|
ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do
|
|
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 (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay, tut E.^. TutorialLastChanged)
|
|
E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc $ tut E.^. TutorialLastChanged, 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 (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay, tut E.^. TutorialLastChanged)
|
|
E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, 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
|
|
pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs -- NOTE: datalist does not work on textarea inputs
|
|
pure $ mkOptionListFromCacheable ol
|
|
|
|
|
|
colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
|
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","min-width:12em")]) <$>
|
|
formCell id
|
|
(views (resultParticipant . _entityKey) return)
|
|
(\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) . over _2 fvWidget <$> -- For Textarea use: fmap (Text.strip . unTextarea)
|
|
mopt (textField & cfStrip & addDatalist (suggsAttendanceNote sid cid tid)) (fsUniq mkUnique "note-attendance") note
|
|
---- Version für Textare
|
|
-- mopt (textareaField) -- & addDatalist (suggsAttendanceNote sid cid tid)) -- NOTE: 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 :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
|
|
colParkingField = colParkingField' _dailyFormParkingToken
|
|
|
|
-- colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
|
-- colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id
|
|
-- (views (resultParticipant . _entityKey) return)
|
|
-- (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
|
|
-- over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
|
|
-- )
|
|
|
|
colParkingField' :: ASetter' a Bool -> Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
|
colParkingField' l dday = sortable (Just "parking") (i18nCell $ MsgTableUserParkingToken dday) $ (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 ->
|
|
over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
|
|
)
|
|
|
|
mkDailyTable :: Bool -> SchoolId -> Day -> Maybe DayCheckResults -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Maybe Widget)
|
|
mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case
|
|
tutLessons
|
|
| Map.null tutLessons -> return (FormMissing, Nothing)
|
|
| 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 MsgTableCourse) $ \(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 . snd) $ 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 $ snd <$> 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-firm") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
|
|
, sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row ->
|
|
let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
|
|
primComp = row ^? resultCompanyId
|
|
bookLink = cellMaybe companyIdCell bookComp
|
|
result
|
|
| primComp /= bookComp
|
|
, Just (unCompanyKey -> csh) <- primComp
|
|
= cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
|
|
(Just IconCompanyWarning) True)
|
|
<> spacerCell
|
|
<> bookLink
|
|
| otherwise = bookLink
|
|
in result
|
|
-- , sortable (Just "booking-firm") (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 -- maybe just use iconCompanyWarning instead of modal?
|
|
-- [whamlet|
|
|
-- <h2>
|
|
-- ^{userWidget row}
|
|
-- <p>
|
|
-- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
|
|
-- |]
|
|
-- ))
|
|
-- | otherwise = bookLink
|
|
-- in result
|
|
, maybeEmpty dcrs $ \DayCheckResults{..} ->
|
|
sortable (Just "check-fail") (timeCell dcrTimestamp) $ \(view $ resultParticipant . _entityKey -> tpid) ->
|
|
maybeCell (Map.lookup tpid dcrResults) $ wgtCell . dcr2widget' Nothing
|
|
, 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 dday
|
|
-- 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-firm" , 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))
|
|
-- , ("check-fail" , SortColumn $ queryParticipant >>> (\pid -> pid E.^. TutorialParticipantId `E.in_` E.vals (maybeEmpty dcrs $ dcrResults >>> Map.keys)))
|
|
, let dcrsLevels = maybeEmpty dcrs $ dcrSeverityGroups . dcrResults in
|
|
("check-fail" , SortColumn $ queryParticipant >>> (\((E.^. TutorialParticipantId) -> pid) -> E.case_
|
|
[ E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _1)) E.then_ (E.val 1)
|
|
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _2)) E.then_ (E.val 2)
|
|
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _3)) E.then_ (E.val 3)
|
|
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _4)) E.then_ (E.val 4)
|
|
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _5)) E.then_ (E.val 5)
|
|
](E.else_ E.val (99 :: Int64))
|
|
))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ fltrUserNameEmail queryUser
|
|
, fltrUserMatriclenr queryUser
|
|
, ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName))
|
|
, ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
|
|
, ("booking-firm" , FilterColumn . E.mkContainsFilterWith Just $ queryParticipant >>> (E.^. TutorialParticipantCompany))
|
|
, ("user-company" , FilterColumn . E.mkContainsFilterWith Just $ 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 "booking-firm" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableBookingCompanyShort)
|
|
, prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompanyShort)
|
|
, 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{..}
|
|
over _2 Just <$> dbTable psValidator DBTable{..}
|
|
|
|
|
|
getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html
|
|
getSchoolDayR = postSchoolDayR
|
|
postSchoolDayR ssh nd = do
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
dday <- formatTime SelFormatDate nd
|
|
let unFormResult = getDBFormResult $ \row -> let tpt = row ^. resultParticipant . _entityVal
|
|
in DailyFormData
|
|
{ dailyFormDrivingPermit = tpt ^. _tutorialParticipantDrivingPermit
|
|
, dailyFormEyeExam = tpt ^. _tutorialParticipantEyeExam
|
|
, dailyFormParticipantNote = tpt ^. _tutorialParticipantNote
|
|
, dailyFormAttendance = row ^? resultParticipantDay ._tutorialParticipantDayAttendance & fromMaybe False
|
|
, dailyFormAttendanceNote = row ^? resultParticipantDay ._tutorialParticipantDayNote . _Just
|
|
, dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False
|
|
}
|
|
dcrs <- memcachedByGet (CacheKeyTutorialCheckResults ssh nd)
|
|
(fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd dcrs
|
|
-- logInfoS "****DailyTable****" $ tshow tableRes
|
|
formResult tableRes $ \resMap -> do
|
|
tuts <- runDB $ forM (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do
|
|
-- logDebugS "TableForm" (tshow dfd)
|
|
TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated
|
|
when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit
|
|
|| tutorialParticipantEyeExam /= dailyFormEyeExam
|
|
|| tutorialParticipantNote /= dailyFormParticipantNote) $
|
|
update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit
|
|
, TutorialParticipantEyeExam =. dailyFormEyeExam
|
|
, TutorialParticipantNote =. dailyFormParticipantNote
|
|
]
|
|
let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd
|
|
if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote)
|
|
then deleteBy tpdUq
|
|
else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote)
|
|
[ TutorialParticipantDayAttendance =. dailyFormAttendance
|
|
, TutorialParticipantDayNote =. dailyFormAttendanceNote
|
|
]
|
|
let udUq = UniqueUserDay tutorialParticipantUser nd
|
|
updateUserDay = if dailyFormParkingToken
|
|
then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued
|
|
else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False
|
|
updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken]
|
|
return tutorialParticipantTutorial
|
|
forM_ tuts $ \tid -> do
|
|
memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text)
|
|
memcachedByInvalidate (CacheKeySuggsAttendanceNote ssh tid) $ Proxy @(OptionListCacheable Text)
|
|
-- audit log? Currently decided against.
|
|
addMessageI Success $ MsgTutorialParticipantsDayEdits dday
|
|
redirect $ SchoolR ssh $ SchoolDayR nd
|
|
|
|
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
|
|
let consistencyBtn = btnModal MsgMenuSchoolDayCheck [BCIsButton, BCDefault] (Left $ SomeRoute $ SchoolR ssh $ SchoolDayCheckR nd)
|
|
setTitleI (MsgMenuSchoolDay ssh dday)
|
|
$(i18nWidgetFile "day-view")
|
|
|
|
-- | A wrapper for several check results on tutorial participants
|
|
data DayCheckResult = DayCheckResult
|
|
{ dcEyeFitsPermit :: Maybe Bool
|
|
, dcAvsKnown :: Bool
|
|
, dcApronAccess :: Bool
|
|
, dcBookingFirmOk :: Bool
|
|
}
|
|
deriving (Show, Generic, Binary)
|
|
|
|
data DayCheckResults = DayCheckResults
|
|
{ dcrTimestamp :: UTCTime
|
|
, dcrResults :: Map TutorialParticipantId DayCheckResult
|
|
}
|
|
deriving (Show, Generic, Binary)
|
|
|
|
type ParticipantCheckData = (Entity TutorialParticipant, UserDisplayName, UserSurname, Maybe AvsPersonId, Maybe CompanyName)
|
|
|
|
|
|
dayCheckParticipant :: Map AvsPersonId AvsDataPerson
|
|
-> ParticipantCheckData
|
|
-> DayCheckResult
|
|
dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, udn, usn, mapi, mcmp) =
|
|
let dcEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit
|
|
(dcAvsKnown, (dcApronAccess, dcBookingFirmOk))
|
|
| Just AvsDataPerson{avsPersonPersonCards = apcs} <- lookupMaybe avsStats mapi
|
|
= (True , mapBoth getAny $ foldMap (hasApronAccess &&& fitsBooking mcmp) apcs)
|
|
| otherwise
|
|
= (False, (False, False))
|
|
in DayCheckResult{..}
|
|
where
|
|
hasApronAccess :: AvsDataPersonCard -> Any
|
|
hasApronAccess AvsDataPersonCard{avsDataValid=True, avsDataCardColor=AvsCardColorGelb} = Any True
|
|
hasApronAccess AvsDataPersonCard{avsDataValid=True, avsDataCardColor=AvsCardColorRot} = Any True
|
|
hasApronAccess _ = Any False
|
|
|
|
fitsBooking :: Maybe CompanyName -> AvsDataPersonCard -> Any
|
|
fitsBooking (Just cn) AvsDataPersonCard{avsDataValid=True,avsDataFirm=Just df} = Any $ cn == stripCI df
|
|
fitsBooking _ _ = Any False
|
|
|
|
dcrIsOk :: DayCheckResult -> Bool
|
|
dcrIsOk (DayCheckResult (Just True) True True True) = True
|
|
dcrIsOk _ = False
|
|
|
|
-- TODO: i18n and use icons to show all results at once
|
|
-- TODO: using memcache, display icons in column in daily view, if cache is filled
|
|
dcr2widget :: Maybe CompanyName -> DayCheckResult -> Widget
|
|
dcr2widget _ DayCheckResult{dcAvsKnown=False} = text2widget "AVS Abfrage fehlgeschlagen"
|
|
dcr2widget _ DayCheckResult{dcApronAccess=False} = text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden"
|
|
dcr2widget mcn DayCheckResult{dcBookingFirmOk=False} = [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|]
|
|
dcr2widget _ DayCheckResult{dcEyeFitsPermit=Nothing} = text2widget "Sehtest oder Führerschein fehlen noch"
|
|
dcr2widget _ DayCheckResult{dcEyeFitsPermit=Just False}= text2widget "Sehtest und Führerschein passen nicht zusammen"
|
|
dcr2widget _ _ = text2widget "Kein Problem vorhanden"
|
|
|
|
|
|
dcrSeverity :: DayCheckResult -> Int
|
|
dcrSeverity DayCheckResult{dcAvsKnown=False} = 1
|
|
dcrSeverity DayCheckResult{dcApronAccess=False} = 2
|
|
dcrSeverity DayCheckResult{dcBookingFirmOk=False} = 3
|
|
dcrSeverity DayCheckResult{dcEyeFitsPermit=Nothing} = 4
|
|
dcrSeverity DayCheckResult{dcEyeFitsPermit=Just False} = 5
|
|
dcrSeverity _ = 99
|
|
|
|
dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId)
|
|
dcrSeverityGroups dcrs = Map.foldMapWithKey groupBySeverity mempty
|
|
where
|
|
groupBySeverity :: TutorialParticipantId -> DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId)
|
|
groupBySeverity tpid dcr =
|
|
let sempty = mempty :: (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId)
|
|
in case dcrSeverity dcr of
|
|
1 -> set _1 (Set.singleton tpid) sempty
|
|
2 -> set _2 (Set.singleton tpid) sempty
|
|
3 -> set _3 (Set.singleton tpid) sempty
|
|
4 -> set _4 (Set.singleton tpid) sempty
|
|
5 -> set _5 (Set.singleton tpid) sempty
|
|
_ -> sempty
|
|
|
|
-- Alternative version using icons to display everything at once
|
|
dcr2widget' :: Maybe CompanyName -> DayCheckResult -> Widget
|
|
dcr2widget' mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk]
|
|
where
|
|
mkTooltip ico msg = iconTooltip msg (Just ico) True
|
|
|
|
avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (text2widget "AVS Abfrage fehlgeschlagen")
|
|
apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden")
|
|
bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|]
|
|
permitChk | isNothing dcEyeFitsPermit = mkTooltip IconGlasses (text2widget "Sehtest oder Führerschein fehlen noch")
|
|
| dcEyeFitsPermit == Just False = mkTooltip IconFileMissing (text2widget "Sehtest und Führerschein passen nicht zusammen")
|
|
| otherwise = mempty
|
|
|
|
|
|
-- | Prüft die Teilnehmer der Tagesansicht: AVS online aktualisieren, gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
|
|
getSchoolDayCheckR :: SchoolId -> Day -> Handler Html
|
|
getSchoolDayCheckR ssh nd = do
|
|
-- isAdmin <- hasReadAccessTo AdminR
|
|
now <- liftIO getCurrentTime
|
|
let nowaday = utctDay now
|
|
dday <- formatTime SelFormatDate nd
|
|
|
|
(tuts, parts_avs) <- runDB $ do
|
|
tuts <- getDayTutorials ssh (nd,nd)
|
|
parts_avs :: [ParticipantCheckData] <- $(unValueNIs 5 [2..5]) <<$>> E.select (do
|
|
(tpa :& usr :& avs :& cmp) <- E.from $ E.table @TutorialParticipant
|
|
`E.innerJoin` E.table @User
|
|
`E.on` (\(tpa :& usr) -> tpa E.^. TutorialParticipantUser E.==. usr E.^. UserId)
|
|
`E.leftJoin` E.table @UserAvs
|
|
`E.on` (\(tpa :& _ :& avs) -> tpa E.^. TutorialParticipantUser E.=?. avs E.?. UserAvsUser)
|
|
`E.leftJoin` E.table @Company
|
|
`E.on` (\(tpa :& _ :& _ :& cmp) -> tpa E.^. TutorialParticipantCompany E.==. cmp E.?. CompanyId)
|
|
E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals (Map.keys tuts)
|
|
-- E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial, E.asc $ usr E.^. UserDisplayName] -- order no longer needed
|
|
return (tpa, usr E.^. UserDisplayName, usr E.^. UserSurname, avs E.?. UserAvsPersonId, cmp E.?. CompanyName)
|
|
)
|
|
-- additionally queue proper AVS synchs for all users, unless there were already done today
|
|
void $ queueAvsUpdateByUID (foldMap (^. _1 . _entityVal . _tutorialParticipantUser . to Set.singleton) parts_avs) (Just nowaday)
|
|
return (tuts, parts_avs)
|
|
let getApi :: ParticipantCheckData -> Set AvsPersonId
|
|
getApi = foldMap Set.singleton . view _4
|
|
avsStats :: Map AvsPersonId AvsDataPerson <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap getApi parts_avs -- query AVS, but does not affect DB (no update)
|
|
-- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
|
|
let toPartMap :: ParticipantCheckData -> Map TutorialParticipantId DayCheckResult
|
|
toPartMap pcd = Map.singleton (pcd ^. _1 . _entityKey) $ dayCheckParticipant avsStats pcd
|
|
participantResults = foldMap toPartMap parts_avs
|
|
memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now participantResults
|
|
|
|
-- the following is only for displaying results neatly
|
|
let sortBadParticipant acc pcd =
|
|
let tid = pcd ^. _1 . _entityVal . _tutorialParticipantTutorial
|
|
pid = pcd ^. _1 . _entityKey
|
|
udn = pcd ^. _2
|
|
ok = maybe False dcrIsOk $ Map.lookup pid participantResults
|
|
in if ok then acc else Map.insertWith (<>) tid (Map.singleton (udn,pid) pcd) acc
|
|
badTutPartMap :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData)
|
|
badTutPartMap = foldl' sortBadParticipant mempty parts_avs
|
|
|
|
mkBaddieWgt :: TutorialParticipantId -> ParticipantCheckData -> Widget
|
|
mkBaddieWgt pid pcd =
|
|
let name = nameWidget (pcd ^. _2) (pcd ^. _3)
|
|
bookFirm = pcd ^. _5
|
|
problems = maybe (text2widget "???") (dcr2widget bookFirm) (Map.lookup pid participantResults)
|
|
problems' = maybe mempty (dcr2widget' bookFirm) (Map.lookup pid participantResults) -- TODO: decide which version to use
|
|
in [whamlet|^{name}: ^{problems'} ^{problems}|]
|
|
|
|
siteLayoutMsg MsgMenuSchoolDayCheck $ do
|
|
setTitleI MsgMenuSchoolDayCheck -- TODO: i18n
|
|
[whamlet|
|
|
<h2>
|
|
_{MsgMenuSchoolDay ssh dday}
|
|
<p>
|
|
$if Map.null badTutPartMap
|
|
Es wurden keine Probleme gefunden.
|
|
$else
|
|
<dl .deflist.profile-dl>
|
|
$forall (tid,badis) <- Map.toList badTutPartMap
|
|
<dt .deflist__dt>
|
|
#{maybe "???" fst (Map.lookup tid tuts)}
|
|
<dd .deflist__dd>
|
|
<ul>
|
|
$forall ((udn,pid),pcd) <- Map.toList badis
|
|
<li>
|
|
^{mkBaddieWgt pid pcd}
|
|
<p>
|
|
^{linkButton mempty (text2widget "Schliessen") [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))}
|
|
|] |