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,169 +157,155 @@ postAdminAvsR = do
           $nothing
             AVS nicht konfiguriert!
         |]
-  mAvsQuery <- getsYesod $ view _appAvsQuery
+  
-  case mAvsQuery of
+  ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
-    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
+  let procFormPerson fr = do
-            addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
+        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>
-                  <ul>
+                $forall p <- pns
-                    $forall p <- pns
+                  <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
-                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
+            |]
-                |]
+  mbPerson <- formResultMaybe presult (Just <<$>> procFormPerson)
-      mbPerson <- formResultMaybe presult procFormPerson
 
-      ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
+  ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
-      let procFormStatus fr = do
+  let procFormStatus fr = do
-            addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
+        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>
-                  <ul>
+                $forall p <- pns
-                    $forall p <- pns
+                  <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
-                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
+            |]
-                |]
+  mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
-      mbStatus <- formResultMaybe sresult procFormStatus
 
-      ((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
+  ((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
-      let procFormContact fr = do
+  let procFormContact fr = do
-            addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
+        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>
-                  <ul>
+                $forall AvsDataContact{..} <- pns
-                    $forall AvsDataContact{..} <- pns
+                  <li>
-                      <li>
-                        <ul>
-                          <li>AvsId: #{tshow avsContactPersonID}
-                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
-                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
-                |]
-      mbContact <- formResultMaybe cresult procFormContact
-
-
-      ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
-        flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
-      let procFormCrUsr fr = do
-            -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
-            res <- try $ guessAvsUser fr
-            case res of
-              (Right (Just uid)) -> do
-                uuid :: CryptoUUIDUser <- encrypt uid
-                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
-                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
-            res <- 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))
-                      (Just idmin, Nothing,    Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
-                      (Nothing   , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
-                      (Nothing   , Nothing,    Just lic) -> \AvsPersonLicence{..} ->  avsLicenceRampLicence == lic
-                      (Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
-                      (Just idmin, Nothing,    Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
-                      (Nothing   , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
-                      (Nothing   , Nothing,    Nothing ) -> const True
-                addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
-                return $ Just [whamlet|
-                    <h2>Success:</h2>
                     <ul>
-                      $forall AvsPersonLicence{..} <- flics
+                      <li>AvsId: #{tshow avsContactPersonID}
-                        <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
-                  |]
+                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
-
+            |]
-              (Left err) -> do
+  mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
-                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
-                                                   <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
-      let procFormSetLic (aid, lic) = do
-            res <- try $ setLicenceAvs (AvsPersonId aid) lic
-            case res of
-              (Right True) ->
-                return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
-              (Right False) ->
-                return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
-              (Left e) -> do
-                let msg = tshow (e :: SomeException)
-                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
-      mbSetLic <- formResultMaybe setLicRes procFormSetLic
 
 
-      (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
+  ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
-      mbQryLic <- case qryLicRes of
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
-        Nothing -> return Nothing
+  let procFormCrUsr fr = do
-        (Just BtnCheckLicences) -> do
+        -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
-          res <- try $ do
+        res <- try $ guessAvsUser fr
-            allLicences <- throwLeftM avsQueryGetAllLicences
+        case res of
-            computeDifferingLicences allLicences
+          (Right (Just uid)) -> do
-          case res of
+            uuid :: CryptoUUIDUser <- encrypt uid
-            (Right diffs) -> do
+            return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
-              let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
+          (Right Nothing) ->
-                  r_grant = showLics AvsLicenceRollfeld
+            return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
-                  f_set   = showLics AvsLicenceVorfeld
+          (Left e) -> return $ Just $ exceptionWgt e
-                  revoke  = showLics AvsNoLicence
+  mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
-              return $ Just [whamlet|
-                  <h2>Licence check differences:
-                  <h3>Grant R:
-                  <p>
-                    #{r_grant}
-                  <h3>Set to F:
-                  <p>
-                    #{f_set}
-                  <h3>Revoke licence:
-                  <p>
-                    #{revoke}
-                |]
-            (Left e) -> do
-              let msg = tshow (e :: SomeException)
-              return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
-        -- (Just BtnSynchLicences) -> do
-        --   res <- try synchAvsLicences
-        --   case res of
-        --     (Right True) ->
-        --       return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
-        --     (Right False) ->
-        --       return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
-        --     (Left e) -> do
-        --       let msg = tshow (e :: SomeException)
-        --       return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
 
-      actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
+  ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
-      siteLayoutMsg MsgMenuAvs $ do
+    flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
-        setTitleI MsgMenuAvs
+                                                <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
-        let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
+                                                <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
-            personForm  = wrapFormHere pwidget  penctype
+  let procFormGetLic fr = tryShow $ do
-            statusForm  = wrapFormHere swidget  senctype
+        AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
-            contactForm = wrapFormHere cwidget  cenctype
+        let flics = Set.toList $ Set.filter lfltr lics
-            crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
+            lfltr = case fr of -- not pretty, but it'll do
-            getLicForm  = wrapFormHere getLicWgt getLicEnctype
+                (Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
-            setLicForm  = wrapFormHere setLicWgt setLicEnctype
+                (Just idmin, Nothing,    Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
-        -- TODO: use i18nWidgetFile instead if this is to become permanent
+                (Nothing   , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
-        $(widgetFile "avs")
+                (Nothing   , Nothing,    Just lic) -> \AvsPersonLicence{..} ->  avsLicenceRampLicence == lic
+                (Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
+                (Just idmin, Nothing,    Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
+                (Nothing   , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
+                (Nothing   , Nothing,    Nothing ) -> const True
+        addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
+        return [whamlet|
+              <h2>Success:</h2>
+              <ul>
+                $forall AvsPersonLicence{..} <- flics
+                  <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+            |]
+  mbGetLic <- formResultMaybe getLicRes (Just <<$>> procFormGetLic)
+
+  ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
+    flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
+                                                <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
+  let procFormSetLic (aid, lic) = do
+        res <- try $ setLicenceAvs (AvsPersonId aid) lic
+        case res of
+          (Right True) ->
+            return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
+          (Right False) ->
+            return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
+          (Left e) -> do
+            let msg = tshow (e :: SomeException)
+            return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+  mbSetLic <- formResultMaybe setLicRes procFormSetLic
+
+
+  (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
+  mbQryLic <- case qryLicRes of
+    Nothing -> return Nothing
+    (Just BtnCheckLicences) -> do
+      res <- try $ do
+        allLicences <- avsQuery AvsQueryGetAllLicences
+        computeDifferingLicences allLicences
+      case res of
+        (Right diffs) -> do
+          let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
+              r_grant = showLics AvsLicenceRollfeld
+              f_set   = showLics AvsLicenceVorfeld
+              revoke  = showLics AvsNoLicence
+          return $ Just [whamlet|
+              <h2>Licence check differences:
+              <h3>Grant R:
+              <p>
+                #{r_grant}
+              <h3>Set to F:
+              <p>
+                #{f_set}
+              <h3>Revoke licence:
+              <p>
+                #{revoke}
+            |]
+        (Left e) -> do
+          let msg = tshow (e :: SomeException)
+          return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
+    -- (Just BtnSynchLicences) -> do
+    --   res <- try synchAvsLicences
+    --   case res of
+    --     (Right True) ->
+    --       return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
+    --     (Right False) ->
+    --       return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
+    --     (Left e) -> do
+    --       let msg = tshow (e :: SomeException)
+    --       return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
+
+  actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
+  siteLayoutMsg MsgMenuAvs $ do
+    setTitleI MsgMenuAvs
+    let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
+        personForm  = wrapFormHere pwidget  penctype
+        statusForm  = wrapFormHere swidget  senctype
+        contactForm = wrapFormHere cwidget  cenctype
+        crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
+        getLicForm  = wrapFormHere getLicWgt getLicEnctype
+        setLicForm  = wrapFormHere setLicWgt setLicEnctype
+    -- TODO: use i18nWidgetFile instead if this is to become permanent
+    $(widgetFile "avs")
 
 {-
 
@@ -689,48 +680,43 @@ 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
+  mbDataPerson <- lookupAvsUser userAvsPersonId
-    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|
-        <p>
-          Vorläufige Admin Ansicht AVS Daten.
-          Ansicht zeigt aktuelle Daten.
-          Es erfolgte damit aber noch kein Update der FRADrive Daten.
-        <p>
-          <dl .deflist>
-            <dt .deflist__dt>InfoPersonContact <br>
-              <i>(bevorzugt)
-            <dd .deflist__dd>
-              $case mbContact
-                $of Left err
-                  Fehler: #{tshow err}
-                $of Right contactInfo
-                  #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
-            <dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
-              <i>(benötigt mehrere AVS Abfragen)
-            <dd .deflist__dd>
-              $maybe dataPerson <- mbDataPerson
-                #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
-              $nothing
-                Keine Daten erhalten.
-        <h3>
-          Provisorische formatierte Ansicht
-        <p>
-          Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
-          In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
-        <p>
-          ^{foldMap jsonWidget mbContact}
-        <p>
-          ^{foldMap jsonWidget mbDataPerson}
-        |]
   let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
   siteLayout heading $ do
     setTitle $ toHtml $ show userAvsNoPerson
-    resWgt
+    [whamlet|
+      <p>
+        Vorläufige Admin Ansicht AVS Daten.
+        Ansicht zeigt aktuelle Daten.
+        Es erfolgte damit aber noch kein Update der FRADrive Daten.
+      <p>
+        <dl .deflist>
+          <dt .deflist__dt>InfoPersonContact <br>
+            <i>(bevorzugt)
+          <dd .deflist__dd>
+            $case mbContact
+              $of Left err
+                ^{exceptionWgt err}
+              $of Right contactInfo
+                #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
+          <dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
+            <i>(benötigt mehrere AVS Abfragen)
+          <dd .deflist__dd>
+            $maybe dataPerson <- mbDataPerson
+              #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
+            $nothing
+              Keine Daten erhalten.
+      <h3>
+        Provisorische formatierte Ansicht
+      <p>
+        Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
+        In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
+      <p>
+        ^{foldMap jsonWidget mbContact}
+      <p>
+        ^{foldMap jsonWidget mbDataPerson}
+    |]
 
 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
@@ -108,7 +116,7 @@ guessAvsUser someid = do
       --     [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard)
       --     _ -> return Nothing
     Just cid@(Left _wholeNumber) -> 
-      maybeUpsertAvsUserByCard cid >>= \case
+        maybeUpsertAvsUserByCard cid >>= \case
         Nothing -> 
           runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case
             [Entity uid _] -> return $ Just uid
@@ -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