refactor(avs): rework guessAvsUser

src/Application.hs

@@ -124,7 +124,7 @@ import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
 
 import qualified System.Clock as Clock
 
-import Utils.Avs
+import Utils.Avs (mkAvsQuery)
 
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)

src/Foundation/Type.hs

@@ -43,7 +43,7 @@ import Data.Time.Clock.POSIX (POSIXTime)
 import GHC.Fingerprint (Fingerprint)
 import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
 
-import Utils.Avs (AvsQuery)
+import Utils.Avs (AvsQuery())
 
 
 type SMTPPool = Pool SMTPConnection

src/Handler/Admin/Avs.hs

@@ -28,8 +28,6 @@ import Handler.Utils
 import Handler.Utils.Avs
 -- import Handler.Utils.Qualification
 
-import Utils.Avs
-
 
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Legacy as E
@@ -43,6 +41,13 @@ import qualified Database.Esqueleto.Utils        as E
 single :: (k,a) -> Map k a
 single = uncurry Map.singleton
 
+exceptionWgt :: SomeException -> Widget
+exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|]
+
+tryShow :: MonadCatch m => m Widget -> m Widget
+tryShow act = try act >>= \case
+  Left  err -> return $ exceptionWgt err
+  Right res -> return res
 
 -- Button only needed in AVS TEST; further buttons see below
 data ButtonAvsTest = BtnCheckLicences   --  | BtnSynchLicences
@@ -152,44 +157,38 @@ postAdminAvsR = do
           $nothing
             AVS nicht konfiguriert!
         |]
-  mAvsQuery <- getsYesod $ view _appAvsQuery
+  
-  case mAvsQuery of
-    Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
-    Just AvsQuery{..} -> do
   ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
 
   let procFormPerson fr = do
         addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
-            res <- avsQueryPerson fr
+        tryShow $ do
-            case res of
+          AvsResponsePerson pns <- avsQuery fr
-              Left  err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+          return [whamlet|
-              Right (AvsResponsePerson pns) -> return $ Just [whamlet|
               <ul>
                 $forall p <- pns
                   <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
             |]
-      mbPerson <- formResultMaybe presult procFormPerson
+  mbPerson <- formResultMaybe presult (Just <<$>> procFormPerson)
 
   ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
   let procFormStatus fr = do
         addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
-            res <- avsQueryStatus fr
+        tryShow $ do 
-            case res of
+          AvsResponseStatus pns <- avsQuery fr
-              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+          return [whamlet|
-              Right (AvsResponseStatus pns) -> return $ Just [whamlet|
               <ul>
                 $forall p <- pns
                   <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
             |]
-      mbStatus <- formResultMaybe sresult procFormStatus
+  mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
 
   ((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
   let procFormContact fr = do
         addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
-            res <- avsQueryContact fr
+        tryShow $ do
-            case res of
+          AvsResponseContact pns <- avsQuery fr
-              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+          return [whamlet|
-              Right (AvsResponseContact pns) -> return $ Just [whamlet|
               <ul>
                 $forall AvsDataContact{..} <- pns
                   <li>
@@ -198,7 +197,7 @@ postAdminAvsR = do
                       <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
                       <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
             |]
-      mbContact <- formResultMaybe cresult procFormContact
+  mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
 
 
   ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
@@ -212,19 +211,15 @@ postAdminAvsR = do
             return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
           (Right Nothing) ->
             return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
-              (Left e) -> do
+          (Left e) -> return $ Just $ exceptionWgt e
-                let msg = tshow (e :: SomeException)
-                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
   mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
 
   ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
     flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
                                                 <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
                                                 <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
-      let procFormGetLic fr = do
+  let procFormGetLic fr = tryShow $ do
-            res <- avsQueryGetAllLicences
+        AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
-            case res of
-              (Right (AvsResponseGetLicences lics)) -> do
         let flics = Set.toList $ Set.filter lfltr lics
             lfltr = case fr of -- not pretty, but it'll do
                 (Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
@@ -236,17 +231,13 @@ postAdminAvsR = do
                 (Nothing   , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
                 (Nothing   , Nothing,    Nothing ) -> const True
         addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
-                return $ Just [whamlet|
+        return [whamlet|
               <h2>Success:</h2>
               <ul>
                 $forall AvsPersonLicence{..} <- flics
                   <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
             |]
-
+  mbGetLic <- formResultMaybe getLicRes (Just <<$>> procFormGetLic)
-              (Left err) -> do
-                let msg = tshow err
-                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
-      mbGetLic <- formResultMaybe getLicRes procFormGetLic
 
   ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
     flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
@@ -269,7 +260,7 @@ postAdminAvsR = do
     Nothing -> return Nothing
     (Just BtnCheckLicences) -> do
       res <- try $ do
-            allLicences <- throwLeftM avsQueryGetAllLicences
+        allLicences <- avsQuery AvsQueryGetAllLicences
         computeDifferingLicences allLicences
       case res of
         (Right diffs) -> do
@@ -689,13 +680,12 @@ getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
 getAdminAvsUserR uuid = do
   uid <- decrypt uuid
   Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
-  mAvsQuery <- getsYesod $ view _appAvsQuery
+  mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
-  resWgt <- case mAvsQuery of
-    Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
-    Just AvsQuery{..} -> do
-      mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
   mbDataPerson <- lookupAvsUser userAvsPersonId
-      return [whamlet|
+  let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
+  siteLayout heading $ do
+    setTitle $ toHtml $ show userAvsNoPerson
+    [whamlet|
       <p>
         Vorläufige Admin Ansicht AVS Daten.
         Ansicht zeigt aktuelle Daten.
@@ -707,7 +697,7 @@ getAdminAvsUserR uuid = do
           <dd .deflist__dd>
             $case mbContact
               $of Left err
-                  Fehler: #{tshow err}
+                ^{exceptionWgt err}
               $of Right contactInfo
                 #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
           <dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
@@ -727,10 +717,6 @@ getAdminAvsUserR uuid = do
       <p>
         ^{foldMap jsonWidget mbDataPerson}
     |]
-  let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
-  siteLayout heading $ do
-    setTitle $ toHtml $ show userAvsNoPerson
-    resWgt
 
 instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
   hasEntity = _dbrOutput . _2

src/Handler/Utils/Avs.hs

@@ -12,7 +12,7 @@
 
 module Handler.Utils.Avs
   ( guessAvsUser
-  , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
+  , upsertAvsUserById, upsertAvsUserByCard
   -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , AvsLicenceDifferences(..)
   , setLicence, setLicenceAvs, setLicencesAvs
@@ -24,6 +24,7 @@ module Handler.Utils.Avs
   , updateReceivers
   , AvsPersonIdMapPersonCard
   -- CR3 
+  , SomeAvsQuery(..)
   , queryAvsCardNo, queryAvsCardNos
   ) where
 
@@ -76,15 +77,22 @@ instance Exception AvsException
 
 {-
   Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
--}
 
+  handleAvsExceptions = (`catches` handlers)
+    where 
+      handlers = 
+        [ Handler (\(e::AvsException  -> handleAvsException e))
+        , Handler (\(e::ClientError   -> handleClientError  e))
+        ]
+-}
 
 ------------------
 -- AVS Handlers --
 ------------------
 
+{-
 -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; fail-safe, may or may not update existing users, may insert new users
---   If an existing User with internal number is found, an AVS query is executed
+--   If an existing User with internal number is found, an AVS update query is executed
 guessAvsUser :: Text -> Handler (Maybe UserId)
 guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr -> 
     let avsid = AvsPersonId avsidNr
@@ -124,7 +132,8 @@ guessAvsUser someid = do
           let someIdent = stripCI someid
           in    MaybeT (getKeyBy $ UniqueEmail          someIdent)
             <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
-
+-}
+{-
 -- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Address
 upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
 upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid    -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
@@ -139,7 +148,7 @@ upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
             <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
         MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid)
       ifMaybeM apid Nothing upsertAvsUserById
-            
+-}            
 
 -- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
 --   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
@@ -329,6 +338,14 @@ updateReceivers uid = do
 ------------------
 -- CR3 Functions
 
+--
+-- DONE Update UserCompany too
+-- DONE #124 Add an old default supervisor to an Admin TODO-List          
+-- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
+-- TODO #36 "company postal preference", but for updates only yet
+--
+-- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do
+
 
 -- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
 class SomeAvsQuery q where 
@@ -463,16 +480,16 @@ updateRecord dbv inp (CheckAvsUpdate up l) =
   in  dbv & lensRec .~ newval
 
 
--- | Update given AvsPersonId by querying AVS for each; update only, no insertion!
+-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism
 updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
 updateAvsUserByIds apids = do
-    AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids
+    AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched!
     let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order)
     res <- foldMapM procResp requestedAnswers
     let missing = Set.toList $ Set.difference apids $ Set.map fst res
     unless (null missing) $ do
       now <- liftIO getCurrentTime
-      updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- TODO: last successfull synch
+      updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- all others were already marked as updated
     return res
   where 
     procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do
@@ -505,12 +522,6 @@ updateAvsUserByIds apids = do
                     , UserAvsLastPersonInfo =. Just newAvsPersonInfo
                     , UserAvsLastFirmInfo   =. Just newAvsFirmInfo
                     ]                                         
-      --
-      -- TODO: Update UserCompany too
-      -- DONE #124 Add an old default supervisor to an Admin TODO-List          
-      -- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
-      -- TODO #36 "company postal preference"
-      --
       lift $ do -- maybeT no longer needed from here onwards
         -- update company association & supervision
         Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
@@ -519,10 +530,10 @@ updateAvsUserByIds apids = do
         let oldCompanyId = entityKey <$> oldCompanyEnt
             oldCompanyMb = entityVal <$> oldCompanyEnt
             pst_up  = if  
-                      | isJust oldCompanyId && (oldCompanyId == primaryCompanyId)
-                        -> mkUpdate       usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
                       | isNothing oldCompanyMb 
                         -> mkUpdateDirect usr newCompany              $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+                      | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
+                        -> mkUpdate       usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
                       | otherwise
                         -> Nothing
             superReasonComDef = tshow SupervisorReasonCompanyDefault
@@ -645,6 +656,44 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
       ]
 
 
+
+
+-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; 
+--   fail-safe, may or may not update existing users, may insert new users
+--   If an existing User with internal number is found, an AVS update query is executed
+guessAvsUser :: Text -> Handler (Maybe UserId)
+guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
+  | prefix=="AVSID:" = 
+      let avsid = AvsPersonId nr in 
+      runDB (getBy $ UniqueUserAvsId avsid)          >>= \case
+        (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
+        Nothing -> maybeCatchAll $ upsertAvsUserById avsid  
+  | prefix=="AVSNO:" = 
+      runDB (selectList [UserAvsNoPerson ==. nr] []) <&> \case 
+        [     Entity{entityVal=UserAvs{userAvsUser=uid}}] ->          Just uid
+        _ -> Nothing -- not existing or not unique 
+guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =  
+    maybeCatchAll $ upsertAvsUserByCard someavsid >>= \case
+      Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
+        runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) <&> \case
+            [Entity{entityKey=uid}]                       ->          Just uid
+            _ -> Nothing -- not existing or not unique
+      other -> return other
+guessAvsUser someid = do 
+    try (runDB $ ldapLookupAndUpsert someid) >>= \case
+      Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible
+        maybeCatchAll (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
+          Nothing                                         ->          Just uid
+          other   -> other
+      Right Entity{entityKey=uid}                         -> return $ Just uid
+      other -> do -- attempt to recover by trying other ids
+        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
+        runDB . runMaybeT $ 
+          let someIdent = stripCI someid
+          in    MaybeT (getKeyBy $ UniqueEmail          someIdent)
+            <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
+         -- <|> MaybeT (getKeyBy $ UniqueLdapPrimaryKey someIdent)
+
 -- Licences
 setLicence :: (PersistUniqueRead backend, MonadThrow m,
                      MonadHandler m, HandlerSite m ~ UniWorX,

src/Handler/Utils/Table/Columns.hs

@@ -819,15 +819,19 @@ fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
       cs -> do
         let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
         toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
-        maybeTimeoutHandler toutsecs (queryAvsCardNos crds) >>= \case 
+        maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case 
           Nothing               -> addMessageI Error MsgAvsCommunicationTimeout 
                                 >> return (const E.false)
-          (Just (null -> True)) -> return (const E.false)
+          (Just (Left err))     -> addMessage  Error (someExc2Html err)
-          (Just apids) -> return $ 
+                                >> return (const E.false)
+          (Just (Right (null -> True))) -> return (const E.false)
+          (Just (Right apids)) -> return $ 
             \(queryUser -> user) ->
               E.exists $ E.from $ \usrAvs ->
                 E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
                     E.&&.  usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids
+    someExc2Html :: SomeException -> Html
+    someExc2Html (SomeException e) = text2Html $ tshow e
 
 fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
 fltrAVSCardNosUI mPrev = 

src/Jobs/Handler/SynchroniseAvs.hs

@@ -85,8 +85,9 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
       Just Entity{entityKey=asid, entityVal=AvsSync{..}} -> do
         delete asid        
         getBy (UniqueUserAvsUser avsSyncUser) >>= \case
-          Just uae@Entity{entityVal=UserAvs{userAvsLastSynch} }
+          Just uae@Entity{entityVal=UserAvs{userAvsLastSynch=_} }
-            | maybe True (utctDay userAvsLastSynch <) avsSyncPause -> return $ Just uae
+            -- | maybe True (utctDay userAvsLastSynch <) avsSyncPause   -- TODO: we ignore pauses for now
+            -> return $ Just uae
           _other -> return Nothing -- we just updated this one within the given limit or the entity does not exist
         
   ifMaybeM syncJob () $ \Entity{entityKey=avsKey, entityVal=UserAvs{userAvsPersonId=apid}} -> do
@@ -96,7 +97,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
               now <- liftIO getCurrentTime              
               runDB (update avsKey [UserAvsLastSynchError =. Just (tshow exc), UserAvsLastSynch =. now])
               case exc of
-                AvsInterfaceUnavailable -> return ()  -- ignore and retry later
+                AvsInterfaceUnavailable -> return ()  -- ignore and retry later -- TODO won't be retried, since individual job had been deleted
                 AvsUserUnknownByAvs _   -> return ()  -- ignore for users no longer listed in AVS
                 otherExc                -> throwM otherExc
             )            

src/Utils/Avs.hs

@@ -37,7 +37,7 @@ avsMaxSetLicenceAtOnce :: Int
 avsMaxSetLicenceAtOnce = 80   -- maximum input set size for avsQuerySetLicences as enforced by AVS
 
 avsMaxQueryAtOnce :: Int
-avsMaxQueryAtOnce = 500       -- maximum input set size for avsQueryStatus as enforced by AVS
+avsMaxQueryAtOnce = 500       -- maximum input set size for avsQueryStatus and avsQueryContact as enforced by AVS
 
 avsMaxQueryDelay :: Int
 avsMaxQueryDelay = 300000    -- microsecond to wait before sending another AVS query