chore(avs): fix avs interface to botched specifications
This commit is contained in:
Steffen Jost
parent
617706b895
commit
4b295f44d2
@ -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}.|]
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user