refactor(avs): remove need for undecideable super classes by simply using a sensible class definition
This commit is contained in:
parent
caf8e8b71e
commit
57a4aeb475
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user