diff --git a/assets/icons-src/fontawesome.json b/assets/icons-src/fontawesome.json index 8323cda98..8a21484c1 100644 --- a/assets/icons-src/fontawesome.json +++ b/assets/icons-src/fontawesome.json @@ -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" } diff --git a/frontend/src/icons.scss b/frontend/src/icons.scss index 690aaa6cb..61c10ea40 100644 --- a/frontend/src/icons.scss +++ b/frontend/src/icons.scss @@ -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; diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index cbd23f3ae..d5a29b055 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -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) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index dc8244a8d..85ffe29be 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -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.|] \ No newline at end of file + 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| +

+ _{MsgMenuSchoolDay ssh dday} +

+ $if Map.null badTutPartMap + Es wurden keine Probleme gefunden. + $else +

+ $forall (tid,badis) <- Map.toList badTutPartMap +
+ #{maybe "???" fst (Map.lookup tid tuts)} +
+
    + $forall ((udn,pid),pcd) <- Map.toList badis +
  • + ^{mkBaddieWgt pid pcd} +

    + ^{linkButton mempty (text2widget "Schliessen") [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))} + |] \ No newline at end of file diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4d8dae25f..084874b02 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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] diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index e5cb7b7ef..8ca8485ce 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -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)