chore(avs): undecidableSuperclasses to sidestep consequences of type erasure

src/Handler/Utils/Avs.hs

@@ -49,8 +49,6 @@ 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 (ClientError)
-
 
 
 --------------------
@@ -574,28 +572,26 @@ updateReceivers uid = do
 -- CR3 Functions
 
 
-class SomeAvsQuery q where 
+avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, SomeAvsQuery q) => q -> m (SomeAvsResponse q)
-  type SomeAvsResponse q :: Type
+avsQuery qry
-  pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
+    | (Just (qto,qfr)) <- cacheable (pure qry) = do
-  avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
+        cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
-  avsQuery qry = do 
+        let qry' = qto qry
-    qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
+        res <- memcachedBy cexpire qry' $ avsQueryNoCache qry'
-    throwLeftM $ qfun qry
+        return $ qfr res
+    | otherwise = avsQueryNoCache qry
+  
 
--- avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
+avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, SomeAvsQuery q) => q -> m (SomeAvsResponse q)
-avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m
+avsQueryNoCache qry = do 
-                  -- , MonadReader UniWorX ((->) (HandlerSite m))
+  qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
-                  , SomeAvsQuery q
+  throwLeftM $ qfun qry
-                  , Typeable (SomeAvsResponse q), Binary q, NFData (SomeAvsResponse q)
+
-                  , Binary (SomeAvsResponse q)
+-- avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, SomeAvsQueryCached q) => q -> m (SomeAvsResponse q)
-             ) => q -> m (SomeAvsResponse q)
+-- avsQueryCached qry = do
-avsQueryCached qry = do
+--   cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
-  cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
+--   memcachedBy cexpire qry $ avsQuery qry -- assumes that avsQueryNoCache is renamed to avsQuery as the default
-  memcachedBy cexpire qry $ avsQuery qry
 
-instance SomeAvsQuery AvsQueryPerson where
-  type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
-  pickQuery = avsQueryPerson
 
 -- avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson
 -- avsPersonQueryCached = avsQueryCached
@@ -614,7 +610,7 @@ queryAvsCardNos = foldMapM queryAvsCardNo
 
 queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
 queryAvsCardNo crd = do 
-    AvsResponsePerson adps <- avsQueryCached $ qry crd
+    AvsResponsePerson adps <- avsQuery $ qry crd
     return $ Set.map avsPersonPersonID adps
   where 
     qry (Left acno)               = def{ avsPersonQueryCardNo     = Just acno }

src/Model/Types/Avs.hs

@@ -788,6 +788,5 @@ newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
   deriving (Eq, Ord, Show, Generic)
 deriveJSON defaultOptions ''AvsQuerySetLicences
 
-type family SomeAvsQueryResonse a where
+-- Note that separate types were need for Servant to fit the existing AVS/VSM-API.
-  SomeAvsQueryResonse AvsQueryPerson  = AvsResponsePerson
+-- See Utils.Avs.SomeAvsQuery for type class magic to provide a uniform interface to all queries.
-  SomeAvsQueryResonse AvsQueryContact = AvsResponseContact

src/Utils/Avs.hs

@@ -1,7 +1,9 @@
--- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@frapor.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# LANGUAGE UndecidableSuperClasses #-}
+
 module Utils.Avs where
 
 import Import.NoModel
@@ -67,6 +69,36 @@ avsQueryAllLicences :: AvsQueryGetLicences
 avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
 
 
+-- | `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)
+
+--  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
+
+
 mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
 #ifdef DEVELOPMENT
 mkAvsQuery _ _ _ = AvsQuery