From a8dc8f6d905360f6c4992dc068863cd3e73b4621 Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Thu, 30 Jun 2022 13:32:30 +0200
Subject: [PATCH] refactor(avs): get rid of awkward signatures and contain AVS
 api to one module

---
 src/Application.hs      |  8 ++---
 src/Utils/Avs.hs        | 77 +++++++++++++++++++++++++++++++----------
 test/Model/TypesSpec.hs |  2 ++
 3 files changed, 63 insertions(+), 24 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index c68926a23..a75e8b8bb 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -359,16 +359,12 @@ makeFoundation appSettings''@AppSettings{..} = do
                             , baseUrlPort = avsPort avsConf
                             , baseUrlPath = ""
                             }
+              avsEnv  = mkClientEnv manager avsServer
               avsAuth = BasicAuthData
                           { basicAuthUsername = avsUser avsConf
                           , basicAuthPassword = avsPass avsConf
                           }
-              (avsPersonSearch :<|> avsPersonStatus) = client avsApi avsAuth
-              runQuery query = runClientM query $ mkClientEnv manager avsServer
-          return $ Just AvsQuery
-            { avsQueryPerson = liftIO . runQuery . avsPersonSearch
-            , avsQueryStatus = liftIO . runQuery . avsPersonStatus
-            }
+          return . Just $ mkAvsQuery avsAuth avsEnv
 
       $logDebugS "Runtime configuration" $ tshow appSettings'
 
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index 431a8b6a8..bf174bbd6 100644
--- a/src/Utils/Avs.hs
+++ b/src/Utils/Avs.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE GADTs #-} 
 
 module Utils.Avs where
 
@@ -10,14 +11,19 @@ import Data.Aeson
 import Data.Aeson.Types
 
 import Servant
-import Servant.Client.Core (ClientError)
+import Servant.Client
+
+-- just to speed up type checking
+import qualified Data.Set as Set
+import qualified Network.HTTP.Client as HTTP (newManager, defaultManagerSettings) 
+
 
 
 
 -- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
 --   Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency.
 {-
-(.:~) :: FromJSON a => Object -> Text -> Parser a -- would be useful for AvsDataPerson, where Case is inconsistent
+(.:~) :: FromJSON a => Object -> Text -> Parser a -- would be useful for AvsDataPerson, where Case is inconsistently encoded
 o .:~ key = o .: key <|> maybe empty parseJSON go
     where go = lookup (Text.toLower key) [(Text.toLower k, v) | (k,v) <- HM.toList o]
 -}
@@ -128,23 +134,58 @@ deriveJSON defaultOptions
   } ''AvsResponseStatus
 
 
-data AvsQuery = AvsQuery
-  { avsQueryPerson :: forall m. MonadIO m => AvsPersonQuery -> m (Either ClientError AvsPersonResponse)
-  , avsQueryStatus :: forall m. MonadIO m => AvsStatusQuery -> m (Either ClientError AvsStatusResponse)
-  }
-
-makeLenses_ ''AvsQuery
-
-
-type AVS = AVSRoute (AVSPersonSearch :<|> AVSPersonStatus)
-
-type AVSAuth = BasicAuth "avs_fradrive" String        
-
-type AVSRoute a = AVSAuth :> "FraVSMService" :> "v1" :> a
-
+type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus)
 type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse
-type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsStatusResponse
-
+type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsResponseStatus
 
 avsApi :: Proxy AVS
 avsApi = Proxy
+
+{- Somehow the GADT-style declaration is not flexible enough to compile at the location of the function call
+data AvsQuery where 
+  AvsQuery :: { avsQueryPerson :: MonadIO m => AvsPersonQuery -> m (Either ClientError AvsPersonResponse)
+              , avsQueryStatus :: MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus)
+              } 
+      -> AvsQuery
+-}
+
+data AvsQuery = AvsQuery
+  { avsQueryPerson :: forall m. MonadIO m => AvsPersonQuery -> m (Either ClientError AvsPersonResponse)
+  , avsQueryStatus :: forall m. MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus)
+  }
+
+
+makeLenses_ ''AvsQuery
+
+mkAvsQuery :: BasicAuthData -> ClientEnv -> AvsQuery
+mkAvsQuery basicAuth cliEnv = AvsQuery
+    { avsQueryPerson = \q -> liftIO $ runClientM (rawQueryPerson q) cliEnv
+    , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
+    }
+  where 
+    (rawQueryPerson :<|> rawQueryStatus) = client avsApi basicAuth        
+
+
+
+-- DEMO to check that it types here instead of waiting for Application to be compiled
+run :: IO ()
+run = do
+  let (_avsPersonSearch :<|> avsPersonStatus) = client avsApi avsAuth
+  manager' <- HTTP.newManager HTTP.defaultManagerSettings
+  let query = avsPersonStatus $ AvsStatusQuery $ Set.singleton 123
+  res <- runClientM query (mkClientEnv manager' avsServer)
+  case res of
+    Left err -> putStrLn $ "Error: " ++ tshow err
+    --Right resp -> do
+    Right (AvsResponseStatus resp) -> do
+      print resp
+  where 
+    avsServer :: BaseUrl
+    avsServer = BaseUrl
+      { baseUrlScheme = Https
+      , baseUrlHost   = "skytest.fra.fraport.de"
+      , baseUrlPort   = 80
+      , baseUrlPath   = ""
+      }
+
+    avsAuth = BasicAuthData "foo" "bar"
diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs
index 50f007859..fa6a7d530 100644
--- a/test/Model/TypesSpec.hs
+++ b/test/Model/TypesSpec.hs
@@ -513,6 +513,8 @@ spec = do
       [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ]
     lawsCheckHspec (Proxy @LmsStatus)
       [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @AvsResponseStatus)
+      [ eqLaws, showLaws, showReadLaws, jsonLaws]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $