chore(daily): towards #2347 check complete, except i18n

also missing: displaying memcached check results in each line of day view

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"
 }
 

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;
 
 

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)

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)
+    tuts <- getDayTutorials ssh (nd,nd)
-    -- participants <- selectList [TutorialParticipantTutorial <-. tuts] []
+    parts_avs :: [ParticipantCheckData] <- $(unValueNIs 5 [2..5]) <<$>> E.select (do
-    parts_avs :: [ParticipantCheckData]
-      <- 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
+      participantResults = foldMap toPartMap parts_avs
-  memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now particpantResults
+  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
+            udn = pcd ^. _2
-            ok  = maybe False dcIsOk $ Map.lookup pid particpantResults
+            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
+      mkBaddieWgt :: TutorialParticipantId -> ParticipantCheckData -> Widget
-  siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
+      mkBaddieWgt pid pcd =
-    setTitleI (MsgMenuSchoolDay ssh dday)
+        let name = nameWidget (pcd ^. _2) (pcd ^. _3)
-    [whamlet|TODO: this is just a stub.|]
+            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)))}
+    |]

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]

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)