diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 22ae8e379..ee51c2672 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -49,6 +49,8 @@ import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E +import Servant.Client.Core.ClientError (ClientError) + -------------------- @@ -572,38 +574,51 @@ updateReceivers uid = do -- CR3 Functions -avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, SomeAvsQuery q) => q -> m (SomeAvsResponse q) -avsQuery qry - | (Just (qto,qfr)) <- cacheable (pure qry) = do - cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right - let qry' = qto qry - res <- memcachedBy cexpire qry' $ avsQueryNoCache qry' - return $ qfr res - | otherwise = avsQueryNoCache qry +-- | `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 + type SomeAvsResponse q :: Type + pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q)) + -- | send query to AVS or maybe look it up within cache, depending on the type of the query + avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) + avsQuery = avsQueryNoCache + -- | send query to AVS directly, never cached + avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) + avsQueryNoCache qry = do + qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery) + throwLeftM $ qfun qry + +avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q) + , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) +avsQueryCached qry = do + cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right + memcachedBy cexpire qry $ avsQueryNoCache qry + + +instance SomeAvsQuery AvsQueryPerson where + type SomeAvsResponse AvsQueryPerson = AvsResponsePerson + pickQuery = avsQueryPerson + avsQuery = avsQueryCached + +instance SomeAvsQuery AvsQueryStatus where + type SomeAvsResponse AvsQueryStatus = AvsResponseStatus + pickQuery = avsQueryStatus + avsQuery = avsQueryCached + +instance SomeAvsQuery AvsQueryContact where + type SomeAvsResponse AvsQueryContact = AvsResponseContact + pickQuery = avsQueryContact + avsQuery = avsQueryCached + +instance SomeAvsQuery AvsQuerySetLicences where + type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences + pickQuery = avsQuerySetLicences + -- NOTE: avsQuery = avsQueryCached -- should not and indeed does not compile + +instance SomeAvsQuery AvsQueryGetAllLicences where + type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences + pickQuery = const . avsQueryGetAllLicences -avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, SomeAvsQuery q) => q -> m (SomeAvsResponse q) -avsQueryNoCache qry = do - qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery) - throwLeftM $ qfun qry - --- avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, SomeAvsQueryCached q) => q -> m (SomeAvsResponse q) --- avsQueryCached qry = do --- cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right --- memcachedBy cexpire qry $ avsQuery qry -- assumes that avsQueryNoCache is renamed to avsQuery as the default - - --- avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson --- avsPersonQueryCached = avsQueryCached - --- avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson --- avsPersonQueryCached apq = do --- cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right --- memcachedBy cexpire apq $ do --- AvsQuery{avsQueryPerson} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery --- throwLeftM $ avsQueryPerson apq - - queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId) queryAvsCardNos = foldMapM queryAvsCardNo diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 7585169b6..e4546b36f 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -2,7 +2,6 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE UndecidableSuperClasses #-} module Utils.Avs where @@ -65,54 +64,6 @@ data AvsQuery = AvsQuery makeLenses_ ''AvsQuery --- | `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 (SomeAvsCachable q), Binary (SomeAvsCachable q), Binary (SomeAvsResponse (SomeAvsCachable q)), Typeable (SomeAvsResponse (SomeAvsCachable q)), NFData (SomeAvsResponse (SomeAvsCachable q))) - => SomeAvsQuery q where - type SomeAvsResponse q :: Type - pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q)) - type SomeAvsCachable q :: Type - cacheable :: Proxy q -> Maybe (q -> SomeAvsCachable q, SomeAvsResponse (SomeAvsCachable q) -> SomeAvsResponse q) - -instance SomeAvsQuery AvsQueryPerson where - type SomeAvsResponse AvsQueryPerson = AvsResponsePerson - pickQuery = avsQueryPerson - type SomeAvsCachable AvsQueryPerson = AvsQueryPerson - cacheable _ = Just (id, id) - -instance SomeAvsQuery AvsQueryStatus where - type SomeAvsResponse AvsQueryStatus = AvsResponseStatus - pickQuery = avsQueryStatus - type SomeAvsCachable AvsQueryStatus = AvsQueryStatus - cacheable _ = Just (id, id) - -instance SomeAvsQuery AvsQueryContact where - type SomeAvsResponse AvsQueryContact = AvsResponseContact - pickQuery = avsQueryContact - type SomeAvsCachable AvsQueryContact = AvsQueryContact - cacheable _ = Just (id, id) - --- class (SomeAvsQuery q, Typeable q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q)) => SomeAvsCachable q --- instance SomeAvsCachable AvsQueryPerson - --- a dummy for non-cacheable queries -instance SomeAvsQuery () where - type SomeAvsResponse () = () - type SomeAvsCachable () = () - pickQuery _ () = return $ Right () - cacheable _ = Just (id,id) - -instance SomeAvsQuery AvsQuerySetLicences where - type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences - pickQuery = avsQuerySetLicences - type SomeAvsCachable AvsQuerySetLicences = () -- not cachable - cacheable _ = Nothing - -instance SomeAvsQuery AvsQueryGetAllLicences where - type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences - pickQuery = const . avsQueryGetAllLicences - type SomeAvsCachable AvsQueryGetAllLicences = () -- not cachable - cacheable _ = Nothing - -- AVS/VSM-Interface currently only allows to query ID 0, which means all licences -- instance SomeAvsQuery AvsQueryGetLicences where -- type SomeAvsResponse AvsQueryGetLicences = AvsResponseGetLicences