|
|
|
|
@ -4,8 +4,7 @@
|
|
|
|
|
-- 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-top-binds #-}
|
|
|
|
|
|
|
|
|
|
module Handler.School.DayTasks
|
|
|
|
|
( getSchoolDayR, postSchoolDayR
|
|
|
|
|
@ -16,7 +15,8 @@ import Import
|
|
|
|
|
|
|
|
|
|
import Handler.Utils
|
|
|
|
|
import Handler.Utils.Company
|
|
|
|
|
import Handler.Utils.Occurrences
|
|
|
|
|
-- import Handler.Utils.Occurrences
|
|
|
|
|
import Handler.Utils.Avs
|
|
|
|
|
|
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
@ -29,8 +29,8 @@ 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.PostgreSQL.JSON ((@>.))
|
|
|
|
|
-- import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
|
|
|
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -528,7 +528,7 @@ mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case
|
|
|
|
|
-- in result
|
|
|
|
|
, maybeEmpty dcrs $ \DayCheckResults{..} ->
|
|
|
|
|
sortable (Just "check-fail") (timeCell dcrTimestamp) $ \(view $ resultParticipant . _entityKey -> tpid) ->
|
|
|
|
|
maybeCell (Map.lookup tpid dcrResults) $ wgtCell . dcr2widget' Nothing
|
|
|
|
|
maybeCell (Map.lookup tpid dcrResults) $ wgtCell . dcr2widgetIcn Nothing
|
|
|
|
|
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
|
|
|
|
|
, colUserMatriclenr isAdmin
|
|
|
|
|
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
|
|
|
|
|
@ -682,6 +682,7 @@ postSchoolDayR ssh nd = do
|
|
|
|
|
setTitleI (MsgMenuSchoolDay ssh dday)
|
|
|
|
|
$(i18nWidgetFile "day-view")
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | A wrapper for several check results on tutorial participants
|
|
|
|
|
data DayCheckResult = DayCheckResult
|
|
|
|
|
{ dcEyeFitsPermit :: Maybe Bool
|
|
|
|
|
@ -689,7 +690,7 @@ data DayCheckResult = DayCheckResult
|
|
|
|
|
, dcApronAccess :: Bool
|
|
|
|
|
, dcBookingFirmOk :: Bool
|
|
|
|
|
}
|
|
|
|
|
deriving (Show, Generic, Binary)
|
|
|
|
|
deriving (Eq, Show, Generic, Binary)
|
|
|
|
|
|
|
|
|
|
data DayCheckResults = DayCheckResults
|
|
|
|
|
{ dcrTimestamp :: UTCTime
|
|
|
|
|
@ -697,13 +698,72 @@ data DayCheckResults = DayCheckResults
|
|
|
|
|
}
|
|
|
|
|
deriving (Show, Generic, Binary)
|
|
|
|
|
|
|
|
|
|
type ParticipantCheckData = (Entity TutorialParticipant, UserDisplayName, UserSurname, Maybe AvsPersonId, Maybe CompanyName)
|
|
|
|
|
-- | True iff there is no problem at all
|
|
|
|
|
dcrIsOk :: DayCheckResult -> Bool
|
|
|
|
|
dcrIsOk (DayCheckResult (Just True) True True True) = True
|
|
|
|
|
dcrIsOk _ = False
|
|
|
|
|
|
|
|
|
|
-- | defines categories on DayCheckResult, implying an ordering, with most severe being least
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
instance Ord DayCheckResult where
|
|
|
|
|
compare = compare `on` dcrSeverity
|
|
|
|
|
|
|
|
|
|
type DayCheckGroups = ( Set TutorialParticipantId -- 1 severity
|
|
|
|
|
, Set TutorialParticipantId -- 2
|
|
|
|
|
, Set TutorialParticipantId -- 3
|
|
|
|
|
, Set TutorialParticipantId -- 4
|
|
|
|
|
, Set TutorialParticipantId -- 5
|
|
|
|
|
)
|
|
|
|
|
|
|
|
|
|
dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> DayCheckGroups
|
|
|
|
|
dcrSeverityGroups = Map.foldMapWithKey groupBySeverity
|
|
|
|
|
where
|
|
|
|
|
groupBySeverity :: TutorialParticipantId -> DayCheckResult -> DayCheckGroups
|
|
|
|
|
groupBySeverity tpid dcr =
|
|
|
|
|
let sempty = mempty :: DayCheckGroups
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
-- | Show most important problem as text
|
|
|
|
|
dcr2widgetTxt :: Maybe CompanyName -> DayCheckResult -> Widget
|
|
|
|
|
dcr2widgetTxt _ DayCheckResult{dcAvsKnown=False} = i18n MsgAvsPersonSearchEmpty
|
|
|
|
|
dcr2widgetTxt _ DayCheckResult{dcApronAccess=False} = i18n MsgAvsNoApronCard
|
|
|
|
|
dcr2widgetTxt mcn DayCheckResult{dcBookingFirmOk=False} = i18n $ MsgAvsNoCompanyCard mcn
|
|
|
|
|
dcr2widgetTxt _ DayCheckResult{dcEyeFitsPermit=Nothing} = i18n MsgCheckEyePermitMissing
|
|
|
|
|
dcr2widgetTxt _ DayCheckResult{dcEyeFitsPermit=Just False}= i18n MsgCheckEyePermitIncompatible
|
|
|
|
|
dcr2widgetTxt _ _ = i18n MsgNoProblem
|
|
|
|
|
|
|
|
|
|
-- | Show all problems as icon with tooltip
|
|
|
|
|
dcr2widgetIcn :: Maybe CompanyName -> DayCheckResult -> Widget
|
|
|
|
|
dcr2widgetIcn mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk]
|
|
|
|
|
where
|
|
|
|
|
mkTooltip ico msg = iconTooltip msg (Just ico) True
|
|
|
|
|
|
|
|
|
|
avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (i18n MsgAvsPersonSearchEmpty)
|
|
|
|
|
apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (i18n MsgAvsNoApronCard)
|
|
|
|
|
bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning (i18n $ MsgAvsNoCompanyCard mcn)
|
|
|
|
|
permitChk | isNothing dcEyeFitsPermit = mkTooltip IconFileMissing (i18n MsgCheckEyePermitMissing)
|
|
|
|
|
| dcEyeFitsPermit == Just False = mkTooltip IconGlasses (i18n MsgCheckEyePermitIncompatible)
|
|
|
|
|
| otherwise = mempty
|
|
|
|
|
|
|
|
|
|
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) =
|
|
|
|
|
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
|
|
|
|
|
@ -721,57 +781,6 @@ dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, udn, u
|
|
|
|
|
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 IconFileMissing (text2widget "Sehtest oder Führerschein fehlen noch")
|
|
|
|
|
| dcEyeFitsPermit == Just False = mkTooltip IconGlasses (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
|
|
|
|
|
@ -813,25 +822,25 @@ getSchoolDayCheckR ssh nd = do
|
|
|
|
|
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 :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData) -- UserDisplayName as Key ensures proper sort order
|
|
|
|
|
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}|]
|
|
|
|
|
problemText = maybe (text2widget "???") (dcr2widgetTxt bookFirm) (Map.lookup pid participantResults)
|
|
|
|
|
problemIcons = maybe mempty (dcr2widgetIcn bookFirm) (Map.lookup pid participantResults)
|
|
|
|
|
in [whamlet|^{name}: ^{problemIcons} ^{problemText}|]
|
|
|
|
|
|
|
|
|
|
siteLayoutMsg MsgMenuSchoolDayCheck $ do
|
|
|
|
|
setTitleI MsgMenuSchoolDayCheck -- TODO: i18n
|
|
|
|
|
setTitleI MsgMenuSchoolDayCheck
|
|
|
|
|
[whamlet|
|
|
|
|
|
<h2>
|
|
|
|
|
_{MsgMenuSchoolDay ssh dday}
|
|
|
|
|
<p>
|
|
|
|
|
$if Map.null badTutPartMap
|
|
|
|
|
Es wurden keine Probleme gefunden.
|
|
|
|
|
_{MsgNoProblem}.
|
|
|
|
|
$else
|
|
|
|
|
<dl .deflist.profile-dl>
|
|
|
|
|
$forall (tid,badis) <- Map.toList badTutPartMap
|
|
|
|
|
@ -839,9 +848,9 @@ getSchoolDayCheckR ssh nd = do
|
|
|
|
|
#{maybe "???" fst (Map.lookup tid tuts)}
|
|
|
|
|
<dd .deflist__dd>
|
|
|
|
|
<ul>
|
|
|
|
|
$forall ((udn,pid),pcd) <- Map.toList badis
|
|
|
|
|
$forall ((_udn,pid),pcd) <- Map.toList badis
|
|
|
|
|
<li>
|
|
|
|
|
^{mkBaddieWgt pid pcd}
|
|
|
|
|
<p>
|
|
|
|
|
^{linkButton mempty (text2widget "Schliessen") [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))}
|
|
|
|
|
^{linkButton mempty (i18n MsgBtnCloseReload) [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))}
|
|
|
|
|
|]
|
