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|
Success:
Licence #{tshow lic}|]
- (Right Nothing) ->
- return $ Just [whamlet|Warning:
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|
+ Success:
+
+ $forall AvsPersonLicence{..} <- flics
+ - #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+ |]
+
+ (Left err) -> do
+ let msg = tshow err
return $ Just [whamlet|
Error:
#{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|Success:
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