diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index e65d1a41b..e8eff78b6 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -29,7 +29,7 @@ import Handler.Utils.AuthorshipStatement as Handler.Utils import Handler.Utils.Term as Handler.Utils -import Handler.Utils.Servant.AVS as Handler.Utils +import Handler.Utils.Servant.AVS as Handler.Utils -- TODO: remove me later! import Control.Monad.Logger diff --git a/src/Handler/Utils/Servant/AVS.hs b/src/Handler/Utils/Servant/AVS.hs index 0e332bbac..51b7406e0 100644 --- a/src/Handler/Utils/Servant/AVS.hs +++ b/src/Handler/Utils/Servant/AVS.hs @@ -8,6 +8,8 @@ module Handler.Utils.Servant.AVS where import Import import Servant import Servant.Client +-- import Servant.API.Flatten -- requires package servant-flatten + import qualified Network.HTTP.Client as HTTP (newManager, defaultManagerSettings) data AvsPersonQuery = AvsPersonQuery @@ -39,19 +41,43 @@ deriveJSON defaultOptions ''AvsStatusQuery type AvsPersonResponse = Value type AvsStatusResponse = Value - -type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse + +type AVSAuth = BasicAuth "avs_fradrive" String + +--type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse -- :<|> ("PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsStatusResponse)) + +type AVSRoute a = AVSAuth :> "FraVSMService" :> "v1" :> a +type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse +type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsStatusResponse + +{- +-- Option 1: +type AVS = AVSRoute (AVSPersonSearch :<|> AVSPersonStatus) +avsPersonSearch :: AvsPersonQuery -> ClientM AvsPersonResponse +avsPersonStatus :: AvsStatusQuery -> ClientM AvsStatusResponse +(avsPersonSearch :<|> avsPersonStatus) = client avsApi (BasicAuthData "foo" "bar") +-} + +{- +-- Option 2: works, but requires yet another package: servant-flatten +type AVS = AVSRoute (AVSPersonSearch :<|> AVSPersonStatus) +avsPersonSearch :: BasicAuthData -> AvsPersonQuery -> ClientM AvsPersonResponse +avsPersonStatus :: BasicAuthData -> AvsStatusQuery -> ClientM AvsStatusResponse +(avsPersonSearch :<|> avsPersonStatus) = client $ flatten avsApi +-} + +-- Option 3: +type AVS = AVSRoute AVSPersonSearch :<|> AVSRoute AVSPersonStatus +avsPersonSearch :: BasicAuthData -> AvsPersonQuery -> ClientM AvsPersonResponse +avsPersonStatus :: BasicAuthData -> AvsStatusQuery -> ClientM AvsStatusResponse +(avsPersonSearch :<|> avsPersonStatus) = client avsApi + + avsApi :: Proxy AVS avsApi = Proxy - -avsPersonSearch :: BasicAuthData -> AvsPersonQuery -> ClientM AvsPersonResponse --- avsPersonStatus :: BasicAuthData -> AvsStatusQuery -> ClientM AvsStatusResponse ---(avsPersonSearch :<|> avsPersonStatus) = client avsApi -avsPersonSearch = client avsApi - avsServer :: BaseUrl avsServer = BaseUrl { baseUrlScheme = Https @@ -64,7 +90,7 @@ avsServer = BaseUrl run :: IO () run = do manager' <- HTTP.newManager HTTP.defaultManagerSettings - let query = avsPersonSearch (BasicAuthData "foo" "bar") $ def { avsPersonQueryFirstName = Just "Steffen" } + let query = avsPersonSearch (BasicAuthData "foo" "bar") $ def { avsPersonQueryFirstName = Just "Steffen" } res <- runClientM query (mkClientEnv manager' avsServer) case res of Left err -> putStrLn $ "Error: " ++ tshow err