From 66ef4066b3617782c5a53fe1da9441e9fc284a9a Mon Sep 17 00:00:00 2001
From: Steffen Jost <s.jost@fraport.de>
Date: Wed, 14 Feb 2024 13:28:19 +0100
Subject: [PATCH] chore(avs): undecidableSuperclasses to sidestep consequences
 of type erasure

---
 src/Handler/Utils/Avs.hs | 42 ++++++++++++++++++----------------------
 src/Model/Types/Avs.hs   |  5 ++---
 src/Utils/Avs.hs         | 34 +++++++++++++++++++++++++++++++-
 3 files changed, 54 insertions(+), 27 deletions(-)

diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 68fe14c19..22ae8e379 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/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 
-  type SomeAvsResponse q :: Type
-  pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
-  avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
-  avsQuery qry = do 
-    qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
-    throwLeftM $ qfun qry
+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
+  
 
--- avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
-avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m
-                  -- , MonadReader UniWorX ((->) (HandlerSite m))
-                  , SomeAvsQuery q
-                  , Typeable (SomeAvsResponse q), Binary q, NFData (SomeAvsResponse q)
-                  , Binary (SomeAvsResponse q)
-             ) => q -> m (SomeAvsResponse q)
-avsQueryCached qry = do
-  cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
-  memcachedBy cexpire qry $ avsQuery qry
+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
 
-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 }
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index ab8b73c11..57976e002 100644
--- a/src/Model/Types/Avs.hs
+++ b/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
-  SomeAvsQueryResonse AvsQueryPerson  = AvsResponsePerson
-  SomeAvsQueryResonse AvsQueryContact = AvsResponseContact
\ No newline at end of file
+-- Note that separate types were need for Servant to fit the existing AVS/VSM-API.
+-- See Utils.Avs.SomeAvsQuery for type class magic to provide a uniform interface to all queries.
\ No newline at end of file
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index b20ef42f1..c5f9a9839 100644
--- a/src/Utils/Avs.hs
+++ b/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