From 4b295f44d22eff08e55409f8d51ff9ddf2e49270 Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Wed, 30 Nov 2022 13:30:00 +0100
Subject: [PATCH] chore(avs): fix avs interface to botched specifications

---
 src/Handler/Admin/Avs.hs | 40 +++++++++++++++++++++++++++++-----------
 src/Handler/Utils/Avs.hs | 18 ++++++++++--------
 src/Model/Types/Avs.hs   |  2 +-
 src/Utils/Avs.hs         |  8 ++++----
 4 files changed, 44 insertions(+), 24 deletions(-)

diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 10704553a..c36b45493 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -113,7 +113,7 @@ postAdminAvsR = do
       ((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)
+            -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
             res <- try $ upsertAvsUser fr
             case res of
               (Right (Just uid)) -> do
@@ -127,17 +127,33 @@ postAdminAvsR = do
       mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
 
       ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
-        flip (renderAForm FormStandard) html $ areq intField (fslI MsgAvsPersonId) Nothing
+        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
-            addMessage Info $ text2Html $ "Query: " <> tshow (toJSON (AvsPersonId fr))
-            res <- try $ getLicenceByAvsId $ AvsPersonId fr
+            res <- avsQueryGetAllLicences
             case res of
-              (Right (Just lic)) ->
-                return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow lic}|]
-              (Right Nothing) ->
-                return $ Just [whamlet|<h2>Warning:</h2> User not found.|]
-              (Left e) -> do
-                let msg = tshow (e :: SomeException)
+              (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> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+                  |]
+              
+              (Left err) -> do
+                let msg = tshow err
                 return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
       mbGetLic <- formResultMaybe getLicRes procFormGetLic
 
@@ -145,7 +161,9 @@ postAdminAvsR = do
         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
+            let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = AvsPersonId aid }
+            addMessage Info $ text2Html $ "See log for detailed errors. Query: " <> tshow (toJSON $ AvsQuerySetLicences req)
+            res <- try $ setLicencesAvs req
             case res of
               (Right True) ->
                 return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index b83f16a4e..9c070221b 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -7,7 +7,7 @@
 
 module Handler.Utils.Avs
   ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
-  , getLicence, getLicenceDB, getLicenceByAvsId
+  -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , setLicence, setLicenceAvs, setLicencesAvs
   , checkLicences
   , lookupAvsUser, lookupAvsUsers
@@ -67,6 +67,7 @@ instance Exception AvsException
 
 -}
 
+{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround 
 -- Do we need this?
 -- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB
 getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence)
@@ -85,14 +86,15 @@ getLicenceDB uid = do
   let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
   return (avsLicenceRampLicence <$> ulicence)
 
-getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) =>
-                      AvsPersonId -> m (Maybe AvsLicence)
-getLicenceByAvsId aid = do
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
-  AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId aid
-  let ulicence = Set.lookupMax $ Set.filter ((aid ==) . avsLicencePersonID) licences
-  return (avsLicenceRampLicence <$> ulicence)
 
+-- | Should be avoided, since all licences must be requested at once.
+getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) =>
+                      Set AvsPersonId -> m (Set AvsPersonLicence)
+getLicenceByAvsId aids = do
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
+  AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences
+  return $ Set.filter (\x -> avsLicencePersonID x `Set.member` aids) licences
+-}
 
 -- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool
 setLicence :: (PersistUniqueRead backend, MonadThrow m,
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index 2eb1210dc..3443d6938 100644
--- a/src/Model/Types/Avs.hs
+++ b/src/Model/Types/Avs.hs
@@ -470,7 +470,7 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
   deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions ''AvsQueryStatus
 
-newtype AvsQueryGetLicences = AvsQueryGetLicences (Set AvsObjPersonId)
+newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
   deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions ''AvsQueryGetLicences
 
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index dfd2d7c04..ef5aaf46c 100644
--- a/src/Utils/Avs.hs
+++ b/src/Utils/Avs.hs
@@ -45,15 +45,15 @@ data AvsQuery = AvsQuery
   { avsQueryPerson         :: forall m. MonadIO m => AvsQueryPerson      -> m (Either ClientError AvsResponsePerson)
   , avsQueryStatus         :: forall m. MonadIO m => AvsQueryStatus      -> m (Either ClientError AvsResponseStatus)
   , avsQuerySetLicences    :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
-  , avsQueryGetLicences    :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences)
+  -- , avsQueryGetLicences    :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM
   , avsQueryGetAllLicences :: forall m. MonadIO m =>                        m (Either ClientError AvsResponseGetLicences)
   }
 
 makeLenses_ ''AvsQuery
 
--- | To query all active licences, a special argument must be prepared
+-- | To query all active licences, a special constant argument must be prepared
 avsQueryAllLicences :: AvsQueryGetLicences
-avsQueryAllLicences = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId $ AvsPersonId 0
+avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId $ AvsPersonId 0
 
 
 mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
@@ -61,7 +61,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
     { avsQueryPerson      = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson      q)  cliEnv
     , avsQueryStatus      = \q -> liftIO $                     runClientM (rawQueryStatus      q)  cliEnv
     , avsQuerySetLicences = \q -> liftIO $                     runClientM (rawQuerySetLicences q)  cliEnv
-    , avsQueryGetLicences = \q -> liftIO $                     runClientM (rawQueryGetLicences q)  cliEnv
+    -- , avsQueryGetLicences = \q -> liftIO $                     runClientM (rawQueryGetLicences q)  cliEnv
     , avsQueryGetAllLicences =    liftIO $                     runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
     }
   where