chore(avs): work on avs person query complete

src/Handler/Admin/Avs.hs

@@ -13,15 +13,17 @@ import Handler.Utils
 
 import Utils.Avs
 
+avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
+avsCardNoField = convertField AvsCardNo avsCardNo textField
 
 makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
 makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> 
   flip (renderAForm FormStandard) html $ AvsQueryPerson 
-    <$> aopt textField (fslI MsgAvsCardNo)             (avsPersonQueryCardNo              <$> tmpl)
+    <$> aopt avsCardNoField (fslI MsgAvsCardNo)             (avsPersonQueryCardNo              <$> tmpl)
-    <*> aopt textField (fslI MsgAvsFirstName)          (avsPersonQueryFirstName           <$> tmpl)
+    <*> aopt textField      (fslI MsgAvsFirstName)          (avsPersonQueryFirstName           <$> tmpl)
-    <*> aopt textField (fslI MsgAvsLastName)           (avsPersonQueryLastName            <$> tmpl)
+    <*> aopt textField      (fslI MsgAvsLastName)           (avsPersonQueryLastName            <$> tmpl)
-    <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo  <$> tmpl)
+    <*> aopt textField      (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo  <$> tmpl)
-    <*> aopt textField (fslI MsgAvsVersionNo)          (avsPersonQueryVersionNo           <$> tmpl)
+    <*> aopt textField      (fslI MsgAvsVersionNo)          (avsPersonQueryVersionNo           <$> tmpl)
 
 validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
 validateAvsQueryPerson = do 

src/Handler/Utils/Avs.hs

@@ -4,6 +4,7 @@ module Handler.Utils.Avs
     getLicence, getLicenceDB
   , setLicence, setLicenceAvs, setLicencesAvs
   , checkLicences
+  , lookupAvsUser, lookupAvsUsers
   ) where
 
 import Import
@@ -13,7 +14,10 @@ import Import
 
 import Utils.Avs
 
-import qualified Data.Set as Set
+import qualified Data.Set           as Set
+import qualified Data.Map           as Map
+-- import qualified Data.Text          as Text
+
 
 
 --------------------
@@ -104,29 +108,38 @@ or
 -}
 
 {-
-upsertAvsUser :: AvsPersonId ->
+upsertAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+                AvsPersonId -> m ()
 upsertAvsUser api = do
   mbuid <- getBy $ UniqueUserAvsId api 
-  case mbuid
+  mbapd <- lookupAvsUser api
-    Nothing     -> do   -- unknown user
+  case (mbuid, mbapd) of
-
+    ( _     , Nothing)    -> error "TODO" -- CONTINUE HERE   -- this should no happen
-    (Just uid)  -> do   -- known user 
+    (Nothing, Just apd)   -> do   -- unknown user
+      error "TODO" -- CONTINUE HERE
+    (Just uid, Just apd)  -> do   -- known user 
+      error "TODO" -- CONTINUE HERE
 -}
 
-{-
+
--- lookupAvsUser :: AvsPersonId -> 
+lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
-lookupAvsUser api = do 
+                  AvsPersonId -> m (Maybe AvsDataPerson)
+lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
+
+-- | retrieves complete avs user records for given AvsPersonIds.
+--   Note that this requires several AVS-API queries, since 
+--    - avsQueryPerson does not support querying an AvsPersonId directly
+--    - avsQueryStatus only provides limited information
+--   avsQuery is used to obtain all card numbers, which are then queried separately an merged
+--   May throw Servant.ClientError or AvsExceptions
+lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+                   Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
+lookupAvsUsers apis = do 
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  -- avsQueryPerson does not support querying an AvsPersonId directly, 
+  AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis
-  -- hence we need a preliminary avsQueryStatus to get all AvsCardNo.
+  let forFoldlM = $(permuteFun [3,2,1]) foldlM
-  -- Note that avsQueryStatus only provides limited information
+  forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> 
-  AvsResponseStatus statuses <- throwLeftM $ avsQueryStatus $ AvsQueryStatus $ Set.singleton api
+    forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo} -> do
-  _avsperson <- forM statuses $ \AvsStatusPerson{avsStatusPersonCardStatus} ->
+      AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo}
-    foldlM Map.empty avsStatusPersonCardStatus
+      return $ mergeByPersonId adps acc2
-    TODO TODO TODO 
-    forM avsStatusPersonCardStatus $ \AvsDataPersonCard{avsDataCardNo} ->
-      AvsResponsePerson ps <- throwLeftM $ avsQueryPerson $ AvsQueryPerson def{avsPersonQueryCardNo = avsDataCardNo}
-      return $ mergeByPersonId ps
-
--}
     

src/Jobs/Handler/LMS.hs

@@ -207,20 +207,20 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
       -- result :: [(Entity LmsUser, Entity LmsUserlist)]
       results <- E.select $ do
         (luser E.:& lulist) <- E.from $
-            E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
+            E.table @LmsUser `E.fullOuterJoin` E.table @LmsUserlist
-            `E.on` (\(luser E.:& lulist) ->  luser E.^. LmsUserIdent         E.=?. lulist E.?. LmsUserlistIdent
+            `E.on` (\(luser E.:& lulist) ->  luser E.?. LmsUserIdent         E.==. lulist E.?. LmsUserlistIdent
-                                       E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
+                                       E.&&. luser E.?. LmsUserQualification E.==. lulist E.?. LmsUserlistQualification)
-        E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
+        E.where_ $ luser E.?. LmsUserQualification E.?=. E.val qid
-                  E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
+                  E.&&. E.isNothing (E.joinV (luser E.?. LmsUserEnded)) -- do not process closed learners
         return (luser, lulist)
       forM_ results $ \case        
-        (Entity luid luser, Nothing)
+        (Just (Entity luid luser), Nothing)
           | isJust    $ lmsUserReceived luser          -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
           , isNothing $ lmsUserEnded    luser ->
               update luid [LmsUserEnded =. Just now]
           | otherwise -> return ()                     -- users likely not yet started
 
-        (Entity luid luser, Just (Entity lulid lulist)) -> do
+        (Just (Entity luid luser), Just (Entity lulid lulist)) -> do
           when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
             queueDBJob JobSendNotification
               { jRecipient    = lmsUserUser luser
@@ -237,4 +237,6 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
             update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]          
             updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))]
           delete lulid 
+        (_,_) -> return () -- TODO CONTINUE HERE
+          -- PROBLEM: Orphans funktioniert so nicht wegen E.where_ Filter! Separate Query!
       $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]

src/Model/Types/Avs.hs

@@ -16,7 +16,6 @@ import Utils.Lens.TH
 import Text.Read (Read(..))
 import qualified Data.Text          as Text
 import qualified Data.Set           as Set
-import qualified Data.Map           as Map
 
 -- import qualified Data.HashMap.Lazy  as HM
 
@@ -259,12 +258,6 @@ data AvsDataPerson = AvsDataPerson
 
 makeLenses_ ''AvsDataPerson
 
-{-
-instance Canonical AvsDataPerson where
-  canonical proto = 
-    proto & _avsPersonInternalPersonalNo %~ null2nothing
-          & _avsPersonPersonCards        %~ Set.map canonical
--}
 instance Canonical AvsDataPerson where
   canonical = over _avsPersonInternalPersonalNo null2nothing
             . over _avsPersonPersonCards        canonical
@@ -371,7 +364,7 @@ deriveJSON defaultOptions
 -- Queries --
 -------------
 data AvsQueryPerson = AvsQueryPerson
-        { avsPersonQueryCardNo             :: Maybe Text
+        { avsPersonQueryCardNo             :: Maybe AvsCardNo
         , avsPersonQueryFirstName          :: Maybe Text
         , avsPersonQueryLastName           :: Maybe Text
         , avsPersonQueryInternalPersonalNo :: Maybe Text
@@ -400,118 +393,3 @@ deriveJSON defaultOptions ''AvsQueryGetLicences
 newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions ''AvsQuerySetLicences
-
-
------------------------
--- Utility Functions --
------------------------
-
--- | retrieve AvsDataPersonCard with longest validity for a given licence,
---   first argument is a lower bound for avsDataValidTo, usually current day
---   Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
-getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
-getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
-  where
-    licence = licence2char licence'
-    validLicenceCards = Set.filter cardMatch cards
-    cardMatch AvsDataPersonCard{..} =
-      avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-
-guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
-guessLicenceAddress cards
-  | Just c <- Set.lookupMax cards
-  , AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
-  , Just street <- avsDataStreet
-  , Just pcode  <- avsDataPostalCode
-  , Just city   <- avsDataCity
-    = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]])
-  | otherwise = Nothing
-
-hasAddress :: AvsDataPersonCard -> Bool
-hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
-
-pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
-pickLicenceAddress a b
-    | Just r <- pickBetter' hasAddress                                      = r   -- prefer card with complete address
-    | Just r <- pickBetter' avsDataValid                                    = r   -- prefer valid cards
-    | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r   -- prefer 'R' cards
-    | Just r <- pickBetter' (Set.member licenceVorfeld  . avsDataCardAreas) = r   -- prefer 'F' cards
-    | avsDataCardColor a > avsDataCardColor b                               = a   -- prefer Yellow over Green, etc.
-    | avsDataCardColor a < avsDataCardColor b                               = b
-    | avsDataIssueDate a > avsDataIssueDate b                               = a   -- prefer later issue date
-    | avsDataIssueDate a < avsDataIssueDate b                               = b
-    | avsDataValidTo   a > avsDataValidTo   b                               = a   -- prefer later validto date
-    | avsDataValidTo   a < avsDataValidTo   b                               = b
-    | Just r <- pickBetter' (isJust . avsDataFirm)                          = r   -- prefer having a firm
-    | a <= b    = b -- respect natural Ord instance
-    | otherwise = a
-  where
-    pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
-    pickBetter' = pickBetter a b
-    licenceRollfeld = licence2char AvsLicenceRollfeld
-    licenceVorfeld  = licence2char AvsLicenceVorfeld
-
-{- Note:
-For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so
-bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
-  compare a b =  compareBy avsDataValid
-              <> compareBy avsDataValidTo
-              <> compareBy avsDataIssueDate
-              ...
-    where
-      compareBy f = compare `on` f a b
--}
-
-mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-mergeAvsDataPerson = Map.unionWithKey merger 
-  where 
-    merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
-    merger api pa pb = 
-      let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
-          pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
-      in AvsDataPerson 
-        { avsPersonFirstName          = pickBy' Text.length avsPersonFirstName
-        , avsPersonLastName           = pickBy' Text.length avsPersonLastName
-        , avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
-        , avsPersonPersonNo           = pickBy' id avsPersonPersonNo
-        , avsPersonPersonID           = api -- keys must be identical due to call with insertWithKey
-        , avsPersonPersonCards        = (Set.union `on` avsPersonPersonCards) pa pb
-        }
-
-    pickBy :: Ord b => (a -> b) -> a -> a -> a 
-    pickBy f x y  | f x >= f y = x 
-                  | otherwise  = y
-
-catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
-catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
-
-mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson
-mergeByPersonId = Set.foldr aux Map.empty
-  where 
-    aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-    aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
-
-{- Not general enough:
-mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson
-mergeByPersonId = Set.foldr aux Map.empty
-  where
-    aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-    aux adp@AvsDataPerson{avsPersonPersonID} = Map.insertWithKey merger avsPersonPersonID adp 
-    
-    merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
-    merger api pa pb = 
-      let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
-          pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
-      in AvsDataPerson 
-        { avsPersonFirstName          = pickBy' Text.length avsPersonFirstName
-        , avsPersonLastName           = pickBy' Text.length avsPersonLastName
-        , avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
-        , avsPersonPersonNo           = pickBy' id avsPersonPersonNo
-        , avsPersonPersonID           = api -- keys must be identical due to call with insertWithKey
-        , avsPersonPersonCards        = (Set.union `on` avsPersonPersonCards) pa pb
-        }
-
-    pickBy :: Ord b => (a -> b) -> a -> a -> a 
-    pickBy f x y  | f x >= f y = x 
-                  | otherwise  = y
--}

src/Utils/Avs.hs

@@ -3,7 +3,9 @@ module Utils.Avs where
 import Import.NoModel
 import Utils.Lens
 
-import qualified Data.Set as Set
+import qualified Data.Set           as Set
+import qualified Data.Map           as Map
+import qualified Data.Text          as Text
 
 import Servant
 import Servant.Client
@@ -66,3 +68,93 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
     catch404toEmpty other = other
 
     
+-----------------------
+-- Utility Functions --
+-----------------------
+
+-- | retrieve AvsDataPersonCard with longest validity for a given licence,
+--   first argument is a lower bound for avsDataValidTo, usually current day
+--   Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
+getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
+getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
+  where
+    licence = licence2char licence'
+    validLicenceCards = Set.filter cardMatch cards
+    cardMatch AvsDataPersonCard{..} =
+      avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
+
+guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
+guessLicenceAddress cards
+  | Just c <- Set.lookupMax cards
+  , AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
+  , Just street <- avsDataStreet
+  , Just pcode  <- avsDataPostalCode
+  , Just city   <- avsDataCity
+    = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]])
+  | otherwise = Nothing
+
+hasAddress :: AvsDataPersonCard -> Bool
+hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
+
+pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
+pickLicenceAddress a b
+    | Just r <- pickBetter' hasAddress                                      = r   -- prefer card with complete address
+    | Just r <- pickBetter' avsDataValid                                    = r   -- prefer valid cards
+    | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r   -- prefer 'R' cards
+    | Just r <- pickBetter' (Set.member licenceVorfeld  . avsDataCardAreas) = r   -- prefer 'F' cards
+    | avsDataCardColor a > avsDataCardColor b                               = a   -- prefer Yellow over Green, etc.
+    | avsDataCardColor a < avsDataCardColor b                               = b
+    | avsDataIssueDate a > avsDataIssueDate b                               = a   -- prefer later issue date
+    | avsDataIssueDate a < avsDataIssueDate b                               = b
+    | avsDataValidTo   a > avsDataValidTo   b                               = a   -- prefer later validto date
+    | avsDataValidTo   a < avsDataValidTo   b                               = b
+    | Just r <- pickBetter' (isJust . avsDataFirm)                          = r   -- prefer having a firm
+    | a <= b    = b -- respect natural Ord instance
+    | otherwise = a
+  where
+    pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
+    pickBetter' = pickBetter a b
+    licenceRollfeld = licence2char AvsLicenceRollfeld
+    licenceVorfeld  = licence2char AvsLicenceVorfeld
+
+{- Note:
+For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
+bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
+  compare a b =  compareBy avsDataValid
+              <> compareBy avsDataValidTo
+              <> compareBy avsDataIssueDate
+              ...
+    where
+      compareBy f = compare `on` f a b
+-}
+
+mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
+mergeByPersonId = flip $ Set.foldr aux
+  where 
+    aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
+    aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
+
+catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
+catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
+
+mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
+mergeAvsDataPerson = Map.unionWithKey merger 
+  where 
+    merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
+    merger api pa pb = 
+      let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
+          pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
+      in AvsDataPerson 
+        { avsPersonFirstName          = pickBy' Text.length avsPersonFirstName
+        , avsPersonLastName           = pickBy' Text.length avsPersonLastName
+        , avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
+        , avsPersonPersonNo           = pickBy' id avsPersonPersonNo
+        , avsPersonPersonID           = api -- keys must be identical due to call with insertWithKey
+        , avsPersonPersonCards        = (Set.union `on` avsPersonPersonCards) pa pb
+        }
+
+    pickBy :: Ord b => (a -> b) -> a -> a -> a 
+    pickBy f x y  | f x >= f y = x 
+                  | otherwise  = y
+
+