chore(daily): towards #2347 check complete, except i18n
also missing: displaying memcached check results in each line of day view
This commit is contained in:
parent
d4d915bd60
commit
ad1d235bea
@ -29,6 +29,7 @@
|
||||
"file-upload": "file-arrow-up",
|
||||
"file-zip": "file-zipper",
|
||||
"file-csv": "file-csv",
|
||||
"file-missing": "file-circle-minus",
|
||||
"sft-question": "circle-question",
|
||||
"sft-hint": "life-ring",
|
||||
"sft-solution": "circle-exclamation",
|
||||
@ -97,6 +98,9 @@
|
||||
"placeholder": "notdef",
|
||||
"reroute": "diamond-turn-right",
|
||||
"top": "award",
|
||||
"wildcard": "asterisk"
|
||||
"wildcard": "asterisk",
|
||||
"user-unknown": "user-slash",
|
||||
"user-badge": "id-badge",
|
||||
"glasses": "glasses"
|
||||
}
|
||||
|
||||
|
||||
@ -35,6 +35,7 @@ $icons: new,
|
||||
file-upload,
|
||||
file-zip,
|
||||
file-csv,
|
||||
file-circle-minus,
|
||||
sft-question,
|
||||
sft-hint,
|
||||
sft-solution,
|
||||
@ -99,6 +100,8 @@ $icons: new,
|
||||
edit,
|
||||
user-edit,
|
||||
placeholder,
|
||||
glasses,
|
||||
id-badge,
|
||||
loading;
|
||||
|
||||
|
||||
|
||||
@ -32,6 +32,8 @@ import qualified Database.Esqueleto.Experimental as E (selectOne, unValue)
|
||||
import qualified Database.Esqueleto.PostgreSQL as E (now_)
|
||||
import qualified Database.Esqueleto.Utils as E (psqlVersion_)
|
||||
|
||||
{-# ANN module ("HLint: ignore Functor law" :: String) #-}
|
||||
|
||||
-- BEGIN - Buttons needed only here
|
||||
data ButtonCreate = CreateMath | CreateInf | CrashApp -- Dummy for Example
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
|
||||
|
||||
@ -676,23 +676,19 @@ data DayCheckResult = DayCheckResult
|
||||
}
|
||||
deriving (Show, Generic, Binary)
|
||||
|
||||
dcIsOk :: DayCheckResult -> Bool
|
||||
dcIsOk (DayCheckResult (Just True) True True True) = True
|
||||
dcIsOk _ = False
|
||||
|
||||
data DayCheckResults = DayCheckResults
|
||||
{ dcrTimestamp :: UTCTime
|
||||
, dcrResults :: Map TutorialParticipantId DayCheckResult
|
||||
}
|
||||
deriving (Show, Generic, Binary)
|
||||
|
||||
type ParticipantCheckData = (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName))
|
||||
type ParticipantCheckData = (Entity TutorialParticipant, UserDisplayName, UserSurname, Maybe AvsPersonId, Maybe CompanyName)
|
||||
|
||||
|
||||
dayCheckParticipant :: Map AvsPersonId AvsDataPerson
|
||||
-> ParticipantCheckData
|
||||
-> DayCheckResult
|
||||
dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, (E.Value udn, E.Value usn), E.Value mapi, E.Value 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
|
||||
@ -710,15 +706,45 @@ dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, (E.Val
|
||||
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"
|
||||
|
||||
-- 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 <- Map.keys <$> getDayTutorials ssh (nd,nd)
|
||||
-- participants <- selectList [TutorialParticipantTutorial <-. tuts] []
|
||||
parts_avs :: [ParticipantCheckData]
|
||||
<- E.select $ 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)
|
||||
@ -726,31 +752,58 @@ getSchoolDayCheckR ssh nd = do
|
||||
`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 tuts
|
||||
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)
|
||||
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 . E.unValue . view _3
|
||||
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
|
||||
particpantResults = foldMap toPartMap parts_avs
|
||||
memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now particpantResults
|
||||
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 . _1 . _unValue
|
||||
ok = maybe False dcIsOk $ Map.lookup pid particpantResults
|
||||
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
|
||||
|
||||
dday <- formatTime SelFormatDate nd
|
||||
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
|
||||
setTitleI (MsgMenuSchoolDay ssh dday)
|
||||
[whamlet|TODO: this is just a stub.|]
|
||||
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)))}
|
||||
|]
|
||||
@ -180,7 +180,7 @@ instance Button UniWorX ButtonSubmitDelete where
|
||||
nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
|
||||
|
||||
|
||||
-- | Looks like a button, but is just a link (e.g. for create course, etc.)
|
||||
-- | Looks like a button, but is just a link (e.g. for create course, etc.), aka btnLink or linkBtn
|
||||
linkButton :: Widget -- ^ Widget to display if unauthorized
|
||||
-> Widget -- ^ Button label
|
||||
-> [ButtonClass UniWorX]
|
||||
|
||||
@ -71,6 +71,7 @@ data Icon
|
||||
| IconFileUpload
|
||||
| IconFileZip
|
||||
| IconFileCSV
|
||||
| IconFileMissing -- a required document is not on file
|
||||
| IconSFTQuestion -- for SheetFileType only
|
||||
| IconSFTHint -- for SheetFileType only
|
||||
| IconSFTSolution -- for SheetFileType only
|
||||
@ -135,6 +136,9 @@ data Icon
|
||||
| IconReroute -- for notification rerouting
|
||||
| IconTop -- indicating highest number/quantity/priority for something
|
||||
| IconWildcard
|
||||
| IconUserUnknown -- no info for user found, e.g. AVS lookup failed
|
||||
| IconUserBadge -- something about user-avs, e.g. badge in-/valid
|
||||
| IconGlasses -- user must wear glasses while driving
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||
deriving anyclass (Universe, Finite, NFData)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user