chore(sap): show SAP ids in tooltip; also refactor canonical

messages/uniworx/categories/qualification/en-eu.msg

@@ -14,9 +14,9 @@ TableQualificationCountActive: Active
 TableQualificationCountActiveTooltip: Number of currently valid qualification holders
 TableQualificationCountTotal: Total
 TableQualificationIsAvsLicence: AVS Driving License
-TableQualificationIsAvsLicenceTooltip: Is this Qualification synchronized with AVS? Only applies to qualification holders having an AVS PersonID.
+TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID.
 TableQualificationSapExport: Sent to SAP
-TableQualificationSapExportTooltip: Is this Qualification transmitted to SAP? Only applies to qualification holder having a Fraport Personnelnumber.
+TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number.
 LmsQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
 TableQualificationFirstHeld: First held

messages/uniworx/categories/user/de-de-formal.msg

@@ -13,7 +13,7 @@ AdminUserAuth: Authentifizierung
 AdminUserMatriculation: Matrikelnummer
 AdminUserSex: Geschlecht
 AdminUserTelephone: Telefonnummer
-AdminUserMobile: Mobiltelefonmummer
+AdminUserMobile: Mobiltelefonnummer
 AdminUserFPersonalNumber: Personalnummer (nur Fraport AG)
 AdminUserFDepartment: Abteilung
 AdminUserPostAddress: Postalische Anschrift

routes

@@ -285,7 +285,7 @@
 /qualification/#SchoolId/#QualificationShorthand        QualificationR                GET         -- TODO repurpose
 
 -- SAP export
-/qualifications/sap/direct                              QualificationSAPDirectR   GET   !system-sap 
+/qualifications/sap/direct                              QualificationSAPDirectR   GET   !token
 -- OSIS CSV Export Demo
 /lms                                                    LmsAllR               GET POST  !free -- TODO verify that this is ok
 /lms/#SchoolId                                          LmsSchoolR            GET       !free -- TODO verify that this is ok

src/Handler/LMS.hs

@@ -83,8 +83,9 @@ postLmsAllR = do
     FormMissing -> return ()
     _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
 
+  isAdmin <- hasReadAccessTo AdminR
   lmsTable <- runDB $ do
-    view _2 <$> mkLmsAllTable
+    view _2 <$> mkLmsAllTable isAdmin
   siteLayoutMsg MsgMenuQualifications $ do
     setTitleI MsgMenuQualifications
     $(widgetFile "lms-all")
@@ -100,9 +101,10 @@ resultAllQualificationTotal  :: Lens' AllQualificationTableData Word64
 resultAllQualificationTotal  = _dbrOutput . _3 . _unValue
 
 
-mkLmsAllTable :: DB (Any, Widget)
+mkLmsAllTable :: Bool -> DB (Any, Widget)
-mkLmsAllTable = do
+mkLmsAllTable isAdmin = do
   now <- liftIO getCurrentTime
+  
   let
     resultDBTable = DBTable{..}
       where
@@ -139,7 +141,12 @@ mkLmsAllTable = do
           , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) 
                   $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
           , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)  
-                  $ \(view (resultAllQualification . _qualificationSapId) -> sapid) -> tickmarkCell $ isJust sapid
+                  $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
+                      let icn = IconOK -- change icon here, if desired
+                      in case mbSapId of 
+                        Nothing               -> mempty
+                        Just sapId | isAdmin  -> cellTooltipIcon (Just icn) (text2message sapId) mempty
+                        Just _                -> iconCell icn 
           , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
                   $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
           , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal

src/Handler/Utils/Avs.hs

@@ -4,7 +4,7 @@
 
 {-# LANGUAGE TypeApplications #-}
 
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO: remove this line, once the module is completed
 
 module Handler.Utils.Avs
   ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
@@ -146,7 +146,15 @@ checkLicences = do
         `E.innerJoin` E.table @UserAvs
         `E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
       E.where_ $ E.isJust (quali E.^. QualificationAvsLicence)
-          E.&&.  (usrAvs E.^. QualificationAvsLicence `E.notIn` E.valList
+          E.&&.  (usrAvs E.^. QualificationAvsLicence `E.notIn` E.valList idsRollfeld)
+
+        SELECT *
+        FROM sometable  
+          FULL OUTER JOIN 
+            (VALUES {{1,2,3},{4,5,6}}) AS t(x,y,z) 
+          ON sometable.x = t.x    
+        WHERE either IS NULL      -- Use ERaw 
+            
 
       -- WAS WILL ICH HIER WIRKLICH:
       --  Liefere alle avsIds, welche die falsche Qualifikation zugewiesen bekommen haben?
@@ -164,7 +172,7 @@ checkLicences = do
 
 
 upsertAvsUser :: Text -> Handler (Maybe UserId)
-upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid    -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
+upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid    -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
 upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now
   {- maybe this code helps?
   upsRes :: Either CampusUserConversionException (Entity User)

src/Handler/Utils/Table/Pagination.hs

@@ -48,7 +48,7 @@ module Handler.Utils.Table.Pagination
   , linkEitherCell, linkEitherCellM, linkEitherCellM'
   , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
   , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
-  , cellTooltip
+  , cellTooltip, cellTooltipIcon
   , listCell, listCell', listCellOf, listCellOf'
   , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
   , formCell, DBFormResult(..), getDBFormResult
@@ -1691,9 +1691,12 @@ i18nCell msg = cell $ do
   toWidget $ mr msg
 
 cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
-cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
+cellTooltip = cellTooltipIcon Nothing
+
+cellTooltipIcon :: (RenderMessage UniWorX msg, IsDBTable m a) => Maybe Icon -> msg -> DBCell m a -> DBCell m a
+cellTooltipIcon icn msg = cellContents.mapped %~ (<> tipWdgt)
   where
-    tipWdgt = iconTooltip (msg2widget msg) Nothing True
+    tipWdgt = iconTooltip (msg2widget msg) icn True
 
 -- | Always display widget; maybe a link if user is Authorized.
 --   Also see variant `linkEmptyCell`

src/Model/Types/Avs.hs

@@ -45,7 +45,7 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go
 
 -- Like (.:?) but maps Just null to Nothing, ie. Nothing instead of Just ""
 (.:?!) :: (MonoFoldable a, FromJSON a) => Object -> Text -> Parser (Maybe a)
-(.:?!) o k = null2nothing <$> (o .:? k)
+(.:?!) o k = canonical <$> (o .:? k)
 
 
 -- | `SloppyBool` successfully parses different variations of true/false
@@ -256,18 +256,18 @@ instance Ord AvsDataPersonCard where
 makeLenses_ ''AvsDataPersonCard
 {-
 instance Canonical AvsDataPersonCard where
-  canonical proto = proto { avsDataStreet     = null2nothing $ avsDataStreet      proto
+  canonical proto = proto { avsDataStreet     = canonical $ avsDataStreet      proto
-                          , avsDataPostalCode = null2nothing $ avsDataPostalCode  proto
+                          , avsDataPostalCode = canonical $ avsDataPostalCode  proto
-                          , avsDataCity       = null2nothing $ avsDataCity        proto
+                          , avsDataCity       = canonical $ avsDataCity        proto
-                          , avsDataFirm       = null2nothing $ avsDataFirm        proto
+                          , avsDataFirm       = canonical $ avsDataFirm        proto
                           }
 -}
 instance Canonical AvsDataPersonCard where
   canonical proto =
-    proto & _avsDataStreet      %~ null2nothing
+    proto & _avsDataStreet      %~ canonical
-          & _avsDataPostalCode  %~ null2nothing
+          & _avsDataPostalCode  %~ canonical
-          & _avsDataCity        %~ null2nothing
+          & _avsDataCity        %~ canonical
-          & _avsDataFirm        %~ null2nothing
+          & _avsDataFirm        %~ canonical
 
 -- TODO: use canonical in FromJSON/ToJSON instances for consistency
 instance FromJSON AvsDataPersonCard where
@@ -289,10 +289,10 @@ instance ToJSON AvsDataPersonCard where
     catMaybes
     [ ("ValidTo"     .=) <$> avsDataValidTo
     , ("IssueDate"   .=) <$> avsDataIssueDate
-    , ("Street"      .=) <$> (avsDataStreet     & null2nothing)
+    , ("Street"      .=) <$> (avsDataStreet     & canonical)
-    , ("PostalCode"  .=) <$> (avsDataPostalCode & null2nothing)
+    , ("PostalCode"  .=) <$> (avsDataPostalCode & canonical)
-    , ("City"        .=) <$> (avsDataCity       & null2nothing)
+    , ("City"        .=) <$> (avsDataCity       & canonical)
-    , ("Firm"        .=) <$> (avsDataFirm       & null2nothing)
+    , ("Firm"        .=) <$> (avsDataFirm       & canonical)
     ]
     <>
     [ "Valid"       .= show avsDataValid
@@ -332,7 +332,7 @@ data AvsDataPerson = AvsDataPerson
 makeLenses_ ''AvsDataPerson
 
 instance Canonical AvsDataPerson where
-  canonical = over _avsPersonInternalPersonalNo null2nothing
+  canonical = over _avsPersonInternalPersonalNo canonical
             . over _avsPersonPersonCards        canonical
 
 
@@ -347,7 +347,7 @@ instance FromJSON AvsDataPerson where
 
 instance ToJSON AvsDataPerson where
   toJSON AvsDataPerson{..} = object $
-    catMaybes [ ("InternalPersonalNo"  .=) <$> (avsPersonInternalPersonalNo & null2nothing) ]
+    catMaybes [ ("InternalPersonalNo"  .=) <$> (avsPersonInternalPersonalNo & canonical) ]
     <>
     [ "FirstName"           .= avsPersonFirstName
     , "LastName"            .= avsPersonLastName

src/Utils.hs

@@ -816,10 +816,10 @@ toNothing = const Nothing
 toNothingS :: String -> Maybe b
 toNothingS = const Nothing
 
--- a more general formulation probably possible
+-- replaced by a more general formulation, see canonical
-null2nothing :: MonoFoldable a => Maybe a -> Maybe a
+-- null2nothing :: MonoFoldable a => Maybe a -> Maybe a
-null2nothing (Just x) | null x = Nothing
+-- null2nothing (Just x) | null x = Nothing
-null2nothing other = other
+-- null2nothing other = other
 
 -- | Swap 'Nothing' for 'Just' and vice versa
 -- This belongs into Module 'Utils' but we have a weird cyclic
@@ -1872,5 +1872,15 @@ makePrisms ''ExitCase
 class Canonical a where 
   canonical :: a -> a
 
+instance MonoFoldable mono => Canonical (Maybe mono) where
+  canonical (Just t) | null t = Nothing
+  canonical other = other
+
+-- instance (Canonical mono, MonoFoldable mono) => Canonical (Maybe mono) where
+--   canonical (Just t) | null t = Nothing
+--   canonical (Just t) = Just $ canonical t
+--   canonical other = other
+
+-- this instance is more of a convenient abuse of the class (expand to Foldable)
 instance (Ord a, Canonical a) => Canonical (Set a) where
   canonical = Set.map canonical

test/Utils/TypesSpec.hs

@@ -55,7 +55,7 @@ instance Arbitrary AvsLicenceResponse where
   shrink = genericShrink
 
 instance Arbitrary AvsResponsePerson where
-  arbitrary = genericArbitrary
+  arbitrary = resize 5 genericArbitrary
   shrink = genericShrink
 
 instance Arbitrary AvsResponseStatus where