diff --git a/lib/Polysemy/Http.hs b/lib/Polysemy/Http.hs --- a/lib/Polysemy/Http.hs +++ b/lib/Polysemy/Http.hs @@ -9,6 +9,7 @@ module Polysemy.Http.Data.Response, module Polysemy.Http.Data.Header, module Polysemy.Http.Request, + HttpError(..), -- * Streaming module Polysemy.Http.Http, module Polysemy.Http.Data.StreamEvent, @@ -49,20 +50,21 @@ encode, encodeStrict, ) -import Polysemy.Http.Data.Header (Header(Header), HeaderName(HeaderName), HeaderValue(HeaderValue)) +import Polysemy.Http.Data.Header (Header(..), HeaderName(..), HeaderValue(..)) import Polysemy.Http.Data.Http (Http, request, stream) +import Polysemy.Http.Data.HttpError (HttpError(..)) import Polysemy.Http.Data.Log (Log) import Polysemy.Http.Data.Manager (Manager) import Polysemy.Http.Data.Request ( - Body(Body), - Host(Host), + Body(..), + Host(..), Method(..), - Path(Path), - Port(Port), - QueryKey(QueryKey), - QueryValue(QueryValue), + Path(..), + Port(..), + QueryKey(..), + QueryValue(..), Request(..), - Tls(Tls), + Tls(..), ) import Polysemy.Http.Data.Response ( Response(..), diff --git a/lib/Polysemy/Http/Data/Header.hs b/lib/Polysemy/Http/Data/Header.hs --- a/lib/Polysemy/Http/Data/Header.hs +++ b/lib/Polysemy/Http/Data/Header.hs @@ -1,21 +1,29 @@ +{-# OPTIONS_GHC -fclear-plugins #-} + module Polysemy.Http.Data.Header where -- |The name of a header. newtype HeaderName = HeaderName { unHeaderName :: Text } - deriving (Eq, Show) + deriving (Eq, Show, Generic) deriving newtype (IsString) +defaultJson ''HeaderName + -- |The value of a header. newtype HeaderValue = HeaderValue { unHeaderValue :: Text } - deriving (Eq, Show) + deriving (Eq, Show, Generic) deriving newtype (IsString) +defaultJson ''HeaderValue + -- |An HTTP header. data Header = Header { name :: HeaderName, value :: HeaderValue } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +defaultJson ''Header diff --git a/lib/Polysemy/Http/Data/HttpError.hs b/lib/Polysemy/Http/Data/HttpError.hs --- a/lib/Polysemy/Http/Data/HttpError.hs +++ b/lib/Polysemy/Http/Data/HttpError.hs @@ -1,5 +1,6 @@ module Polysemy.Http.Data.HttpError where +-- |Indicates a critical error caused by an exception in the http-client backend. data HttpError = ChunkFailed Text | diff --git a/lib/Polysemy/Http/Data/Request.hs b/lib/Polysemy/Http/Data/Request.hs --- a/lib/Polysemy/Http/Data/Request.hs +++ b/lib/Polysemy/Http/Data/Request.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fclear-plugins #-} + module Polysemy.Http.Data.Request where import Control.Lens (makeClassy) @@ -28,6 +30,8 @@ Custom Text deriving (Eq, Show) +defaultJson ''Method + instance IsString Method where fromString = \case "GET" -> Get @@ -59,41 +63,57 @@ -- |Request host name. newtype Host = Host { unHost :: Text } - deriving (Eq, Show) + deriving (Eq, Show, Generic) deriving newtype (IsString) +defaultJson ''Host + -- |Request port. newtype Port = Port { unPort :: Int } - deriving (Eq, Show) + deriving (Eq, Show, Generic) +defaultJson ''Port + -- |A flag that indicates whether a request should use TLS. newtype Tls = Tls { unTls :: Bool } - deriving (Eq, Show) + deriving (Eq, Show, Generic) +defaultJson ''Tls + -- |Rrequest path. newtype Path = Path { unPath :: Text } - deriving (Eq, Show) - deriving newtype (IsString) + deriving (Eq, Show, Generic) + deriving newtype (IsString, Monoid) +instance Semigroup Path where + Path l <> Path r = + Path (Text.dropWhileEnd ('/' ==) l <> "/" <> Text.dropWhile ('/' ==) r) + +defaultJson ''Path + -- |The key of a query parameter. newtype QueryKey = QueryKey { unQueryKey :: Text } - deriving (Eq, Show) + deriving (Eq, Show, Generic) deriving newtype (IsString) +defaultJson ''QueryKey + -- |The value of a query parameter. newtype QueryValue = QueryValue { unQueryValue :: Text } - deriving (Eq, Show) + deriving (Eq, Show, Generic) deriving newtype (IsString) +defaultJson ''QueryValue + -- |Request body, using 'LByteString' because it is what 'Aeson.encode' produces. newtype Body = Body { unBody :: LByteString } - deriving (Eq, Show) + deriving (Eq, Show, Generic) deriving newtype (IsString) -- |HTTP request parameters, used by 'Polysemy.Http.Data.Http'. @@ -108,6 +128,6 @@ _query :: [(QueryKey, Maybe QueryValue)], _body :: Body } - deriving (Eq, Show) + deriving (Eq, Show, Generic) makeClassy ''Request diff --git a/lib/Polysemy/Http/Data/Response.hs b/lib/Polysemy/Http/Data/Response.hs --- a/lib/Polysemy/Http/Data/Response.hs +++ b/lib/Polysemy/Http/Data/Response.hs @@ -1,8 +1,11 @@ -module Polysemy.Http.Data.Response where +module Polysemy.Http.Data.Response ( + module Polysemy.Http.Data.Response, + Status(Status), +) where import Network.HTTP.Client (BodyReader) import Network.HTTP.Types ( - Status, + Status(Status), statusIsClientError, statusIsInformational, statusIsRedirection, diff --git a/lib/Polysemy/Http/Native.hs b/lib/Polysemy/Http/Native.hs --- a/lib/Polysemy/Http/Native.hs +++ b/lib/Polysemy/Http/Native.hs @@ -123,7 +123,7 @@ Members [Embed IO, Log, Resource, Manager] r => InterpreterFor (Http BodyReader) r interpretHttpNativeWith = - interpretH $ \case + interpretH \case Http.Request request -> do Log.debug $ [qt|http request: #{request}|] manager <- Manager.get diff --git a/lib/Polysemy/Http/Strict.hs b/lib/Polysemy/Http/Strict.hs --- a/lib/Polysemy/Http/Strict.hs +++ b/lib/Polysemy/Http/Strict.hs @@ -35,10 +35,10 @@ ] interpretHttpStrictWithState :: - Members [Embed IO, State [ByteString], State [Response LByteString], Error HttpError] r => + Members [State [ByteString], State [Response LByteString], Embed IO] r => InterpreterFor (Http Int) r interpretHttpStrictWithState = - interpretH $ \case + interpretH \case Http.Request _ -> liftT . takeResponse =<< raise get Http.Stream _ handler -> do @@ -53,10 +53,14 @@ -- The first parameter is a list of 'Response'. When a request is made, one response is popped of the head and returned. -- If the list is exhausted, a 502 response is returned. interpretHttpStrict :: - Members [Embed IO, Error HttpError] r => + Member (Embed IO) r => [Response LByteString] -> [ByteString] -> InterpreterFor (Http Int) r interpretHttpStrict responses chunks = - evalState chunks . evalState responses . interpretHttpStrictWithState . raiseUnder . raiseUnder + evalState chunks . + evalState responses . + interpretHttpStrictWithState . + raiseUnder . + raiseUnder {-# INLINE interpretHttpStrict #-} diff --git a/polysemy-http.cabal b/polysemy-http.cabal --- a/polysemy-http.cabal +++ b/polysemy-http.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: polysemy-http -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Polysemy effect for http-client description: Please see the README on Github at category: Network @@ -65,13 +65,13 @@ , http-client-tls >=0.3.5 , http-conduit >=2.3.7 , http-types >=0.12.3 - , lens >=4.19.2 + , lens >=4 , mono-traversable >=1.0.15 , polysemy >=1.3.0 , polysemy-plugin >=0.2.5 , relude >=0.7.0 , string-interpolate >=0.2.1 - , template-haskell >=2.16.0 + , template-haskell >=2.14.0 , text >=1.2.3 if impl(ghcjs) else @@ -110,7 +110,7 @@ , http-client-tls >=0.3.5 , http-conduit >=2.3.7 , http-types >=0.12.3 - , lens >=4.19.2 + , lens >=4 , mono-traversable >=1.0.15 , network , polysemy >=1.3.0 @@ -123,7 +123,7 @@ , string-interpolate >=0.2.1 , tasty , tasty-hedgehog - , template-haskell >=2.16.0 + , template-haskell >=2.14.0 , text >=1.2.3 , warp mixins: @@ -165,7 +165,7 @@ , http-client-tls >=0.3.5 , http-conduit >=2.3.7 , http-types >=0.12.3 - , lens >=4.19.2 + , lens >=4 , mono-traversable >=1.0.15 , polysemy >=1.3.0 , polysemy-http @@ -174,7 +174,7 @@ , string-interpolate >=0.2.1 , tasty , tasty-hedgehog - , template-haskell >=2.16.0 + , template-haskell >=2.14.0 , text >=1.2.3 mixins: polysemy-http hiding (Prelude)