diff --git a/cabal.project b/cabal.project index c6e53e56..02adf11e 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,7 @@ packages: servant/ servant-client/ + freer-servant-client/ servant-docs/ servant-foreign/ servant-server/ diff --git a/freer-servant-client/CHANGELOG.md b/freer-servant-client/CHANGELOG.md new file mode 100644 index 00000000..e69de29b diff --git a/freer-servant-client/LICENSE b/freer-servant-client/LICENSE new file mode 100644 index 00000000..e69de29b diff --git a/freer-servant-client/README.md b/freer-servant-client/README.md new file mode 100644 index 00000000..e69de29b diff --git a/freer-servant-client/Setup.hs b/freer-servant-client/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/freer-servant-client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/freer-servant-client/freer-servant-client.cabal b/freer-servant-client/freer-servant-client.cabal new file mode 100644 index 00000000..7e7d940d --- /dev/null +++ b/freer-servant-client/freer-servant-client.cabal @@ -0,0 +1,100 @@ +name: freer-servant-client +version: 0.1 +synopsis: automatical derivation of querying functions for servant webservices +description: + This library lets you derive automatically Haskell functions that + let you query each endpoint of a webservice. +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors +category: Servant Web +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >= 7.8 +homepage: http://haskell-servant.readthedocs.org/ +Bug-reports: http://github.com/haskell-servant/servant/issues +extra-source-files: + include/*.h + CHANGELOG.md + README.md +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git + +library + exposed-modules: + Servant.FreerClient + build-depends: + base >= 4.7 && < 4.11 + , base-compat >= 0.9.1 && < 0.10 + , aeson >= 0.7 && < 1.3 + , attoparsec >= 0.12 && < 0.14 + , base64-bytestring >= 1.0.0.1 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5.7.1 + , exceptions >= 0.8 && < 0.9 + , freer-effects == 0.3.* + , generics-sop >= 0.1.0.0 && < 0.4 + , http-api-data >= 0.3.6 && < 0.4 + , http-client >= 0.4.18.1 && < 0.6 + , http-client-tls >= 0.2.2 && < 0.4 + , http-media >= 0.6.2 && < 0.7 + , http-types >= 0.8.6 && < 0.10 + , monad-control >= 1.0.0.4 && < 1.1 + , network-uri >= 2.6 && < 2.7 + , safe >= 0.3.9 && < 0.4 + , semigroupoids >= 4.3 && < 5.3 + , servant == 0.11.* + , servant-client == 0.11.* + , string-conversions >= 0.3 && < 0.5 + , text >= 1.2 && < 1.3 + , transformers >= 0.3 && < 0.6 + , transformers-base >= 0.4.4 && < 0.5 + , transformers-compat >= 0.4 && < 0.6 + , mtl + , freer-http + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints + include-dirs: include + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Servant.ClientSpec + , Servant.Common.BaseUrlSpec + build-depends: + base == 4.* + , aeson + , base-compat + , bytestring + , deepseq + , hspec == 2.* + , http-api-data + , http-client + , http-media + , http-types + , HUnit + , mtl + , network >= 2.6 + , QuickCheck >= 2.7 + , servant + , servant-client + , servant-server == 0.11.* + , text + , transformers + , transformers-compat + , wai + , warp + , generics-sop \ No newline at end of file diff --git a/freer-servant-client/sidraval@Sids-MacBook-Pro.local.13778 b/freer-servant-client/sidraval@Sids-MacBook-Pro.local.13778 new file mode 100644 index 00000000..e69de29b diff --git a/freer-servant-client/src/Servant/FreerClient.hs b/freer-servant-client/src/Servant/FreerClient.hs new file mode 100644 index 00000000..0e6e4cd7 --- /dev/null +++ b/freer-servant-client/src/Servant/FreerClient.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module Servant.FreerClient where + +import Control.Exception (toException) +import Control.Monad.Freer +import Control.Monad.Freer.Exception +import Control.Monad.Freer.Http +import Control.Monad.Freer.Reader +import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) +import Data.String.Conversions (cs) +import Network.HTTP.Client (Response) +import Network.HTTP.Types +import Network.HTTP.Media +import Servant.Common.Req hiding (ClientM, runClientM') + +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Types.Header as HTTP + +newtype ClientM r a = ClientM { runClientM' :: ( Member (Reader ClientEnv) r + , Member (Exc ServantError) r + , Member Http r) => (Eff r) a } + +instance Functor (ClientM r) where + fmap f a = ClientM $ fmap f (runClientM' a) + +instance Applicative (ClientM r) where + pure a = ClientM $ pure a + f <*> a = ClientM $ (runClientM' f) <*> (runClientM' a) + +instance Monad (ClientM r) where + a >>= f = ClientM $ (runClientM' a) >>= (runClientM' . f) + +performRequest :: ( Member Http r + , Member (Reader ClientEnv) r + , Member (Exc ServantError) r) + => Method -> Req -> ClientM r ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) +performRequest reqMethod req = ClientM $ do + m <- asks manager + reqHost <- asks baseUrl + response <- case (reqToRequest req reqHost) of + Left some -> throwError . ConnectionError $ toException some + Right request -> doRequest request + let status = Client.responseStatus response + body = Client.responseBody response + hdrs = Client.responseHeaders response + status_code = statusCode status + ct <- case lookup "Content-Type" $ Client.responseHeaders response of + Nothing -> pure $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> throwError $ InvalidContentTypeHeader (cs t) body + Just t' -> pure t' + return (status_code, body, ct, hdrs, response) + +runClientM :: ClientM ('[ Reader ClientEnv + , Exc ServantError + , Http + , IO]) a -> ClientEnv -> IO (Either ServantError a) +runClientM cm ce@ClientEnv { manager = mgr } = + runM . (runHttp mgr) . runError . (flip runReader ce) $ runClientM' cm diff --git a/freer-servant-client/test/Spec.hs b/freer-servant-client/test/Spec.hs new file mode 100644 index 00000000..e69de29b diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 37fdfdaf..f80e0ce6 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -47,7 +47,7 @@ library , http-api-data >= 0.3.6 && < 0.4 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 - , http-media >= 0.6.2 && < 0.8 + , http-media >= 0.6.2 && < 0.7 , http-types >= 0.8.6 && < 0.10 , monad-control >= 1.0.0.4 && < 1.1 , network-uri >= 2.6 && < 2.7 diff --git a/servant/servant.cabal b/servant/servant.cabal index 58f440c2..5efd1f12 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -64,7 +64,7 @@ library , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , http-api-data >= 0.3 && < 0.4 - , http-media >= 0.4 && < 0.8 + , http-media >= 0.4 && < 0.7 , http-types >= 0.8 && < 0.10 , natural-transformation >= 0.4 && < 0.5 , mtl >= 2.0 && < 2.3 diff --git a/stack-ghc-7.10.3.yaml b/stack-ghc-7.10.3.yaml index fb18aac7..fb0f5aaf 100644 --- a/stack-ghc-7.10.3.yaml +++ b/stack-ghc-7.10.3.yaml @@ -2,6 +2,7 @@ flags: {} packages: - servant/ - servant-client/ +- freer-servant-client/ - servant-docs/ - servant-foreign/ - servant-server/ diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 01bb6420..173c241a 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -2,6 +2,7 @@ flags: {} packages: - servant/ - servant-client/ +- freer-servant-client/ - servant-docs/ - servant-foreign/ - servant-server/ diff --git a/stack-ghc-8.2.1.yaml b/stack-ghc-8.2.1.yaml index 78d7d383..77e69cd3 100644 --- a/stack-ghc-8.2.1.yaml +++ b/stack-ghc-8.2.1.yaml @@ -1,6 +1,7 @@ resolver: ghc-8.2.0.20170507 packages: - servant-client/ +- freer-servant-client/ - servant-docs/ - servant-foreign/ - servant-server/ diff --git a/stack.yaml b/stack.yaml index 62ff4f2b..f1e104be 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,14 +2,18 @@ resolver: nightly-2017-04-01 packages: - servant/ - servant-client/ +- freer-servant-client/ - servant-docs/ - servant-foreign/ - servant-server/ - doc/tutorial +- location: + git: git@gitlab.com:costar-astrology/freer-http.git + commit: 23310fb0d4d91197a2c6cda071e9f5fb6fe34fcc + extra-dep: true extra-deps: - aeson-1.2.0.0 - attoparsec-iso8601-1.0.0.0 -- http-media-0.7.0 - cabal-doctest-1.0.2 - http-api-data-0.3.7 - servant-js-0.9.3