polysemy-http (empty) → 0.1.0.0

raw patch · 34 files changed

+2022/−0 lines, 34 filesdep +aesondep +ansi-terminaldep +base-noprelude

Dependencies added: aeson, ansi-terminal, base-noprelude, bytestring, case-insensitive, co-log-core, co-log-polysemy, composition, containers, data-default, either, hedgehog, http-client, http-client-tls, http-conduit, http-types, lens, mono-traversable, network, polysemy, polysemy-http, polysemy-plugin, relude, servant, servant-client, servant-server, string-interpolate, tasty, tasty-hedgehog, template-haskell, text, warp

Files

• Changelog.md +2/−0
• LICENSE +34/−0
• README.md +170/−0
• integration/Main.hs +18/−0
• integration/Polysemy/Http/RequestTest.hs +38/−0
• integration/Polysemy/Http/Server.hs +87/−0
• integration/Polysemy/Http/StreamTest.hs +61/−0
• integration/Polysemy/Http/Test.hs +11/−0
• lib/Polysemy/Http.hs +98/−0
• lib/Polysemy/Http/AesonEntity.hs +42/−0
• lib/Polysemy/Http/Data/Entity.hs +87/−0
• lib/Polysemy/Http/Data/Header.hs +21/−0
• lib/Polysemy/Http/Data/Http.hs +39/−0
• lib/Polysemy/Http/Data/HttpError.hs +7/−0
• lib/Polysemy/Http/Data/Log.hs +54/−0
• lib/Polysemy/Http/Data/Manager.hs +9/−0
• lib/Polysemy/Http/Data/Request.hs +113/−0
• lib/Polysemy/Http/Data/Response.hs +70/−0
• lib/Polysemy/Http/Data/StreamChunk.hs +6/−0
• lib/Polysemy/Http/Data/StreamEvent.hs +19/−0
• lib/Polysemy/Http/Http.hs +72/−0
• lib/Polysemy/Http/Json.hs +22/−0
• lib/Polysemy/Http/Log.hs +122/−0
• lib/Polysemy/Http/Manager.hs +27/−0
• lib/Polysemy/Http/Native.hs +147/−0
• lib/Polysemy/Http/Prelude.hs +178/−0
• lib/Polysemy/Http/Request.hs +144/−0
• lib/Polysemy/Http/Strict.hs +62/−0
• lib/Prelude.hs +5/−0
• polysemy-http.cabal +187/−0
• test/Main.hs +18/−0
• test/Polysemy/Http/ResponseTest.hs +21/−0
• test/Polysemy/Http/Test.hs +11/−0
• test/Polysemy/Http/UrlTest.hs +20/−0

@@ -0,0 +1,2 @@+# 0.1.0.0+* initial release

@@ -0,0 +1,34 @@+Copyright (c) 2020 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided with the distribution.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,170 @@+# About++This Haskell library provides a [Polysemy] effect for running HTTP requests+with [http-client].++# Example++```haskell+import Polysemy (runM, resourceToIO)+import qualified Polysemy.Http as Http+import Polysemy.Http (interpretHttpNative, interpretLogStdout)++main :: IO ()+main = do+  result <- runM $+    resourceToIO $+    interpretLogStdout $+    interpretHttpNative $+    Http.request (Http.get "hackage.haskell.org" "package/polysemy-http")+  print result+```++# API++## Request++The effect constructor `Http.request` takes an argument of type+`Polysemy.Http.Data.Request.Request`:++```haskell+data Request =+  Request {+    _method :: Method,+    _host :: Host,+    _port :: Maybe Port,+    _tls :: Tls,+    _path :: Path,+    _headers :: [(HeaderName, HeaderValue)],+    _query :: [(QueryKey, Maybe QueryValue)],+    _body :: Body+  }+```++Most of these fields are just newtypes, except for `Method`, which is an enum:++```haskell+data Method =+  Get | Post | ... | Custom Text+```++It has an `IsString` instance, so you can just write `"GET"` or `"delete"`.++All `Text` newtypes have `IsString` as well, and they will be converted to+`CI` and `ByteString` if needed when they are passed to [http-client].+`Body` is an `LByteString` newtype since that is what [aeson] typically+produces.+The port field is intended for nonstandard ports – if it is `Nothing`, the port+will be determined from `tls`.++## Response++`Http.request` returns `Either HttpError (Response LByteString)`, with+`Polysemy.Http.Data.Response.Response` looking like this:++```haskell+data Response b =+  Response {+    status :: Status,+    body :: b,+    headers :: [Header]+  }++data Header =+  Header {+    name :: HeaderName,+    value :: HeaderValue+  }+```++`Status` is from `http-types`, because it has some helpful combinators. Its+`Header` is just an alias, so this newtype is provided.+The parameter `b` is intended to allow you to write interpreters that produce+`Text` or something else, for example for [#testing].++# Streaming++The higher-order constructor `Http.stream` opens and closes the request+manually and passes the response to a handler function.+The function `streamResponse` provides a simpler interface for this mechanism+that runs a loop that passes individual chunks produced by [http-client] to+a callback handler of type `∀ x . StreamEvent r c h x -> Sem r x` that should+look like this:++```haskell+handle ::+  StreamEvent Double (IO ByteString) Int a ->+  Sem r a+handle = \case+  StreamEvent.Acquire (Response status body headers) ->+    pure 1+  StreamEvent.Chunk handle (StreamChunk c) ->+    pure ()+  StreamEvent.Result (Response status body headers) handle ->+    pure 5.5+  StreamEvent.Release handle ->+    pure ()++run :: Sem r Double+run =+  Http.streamResponse (Request.get "host.com" "path/to/file") handle+```++If you were e.g. to write the data to disk, you would open the file in the+`Acquire` block, write the `ByteString` `c` in `Chunk`, and close the file in+`Release`.+The parameter `h` could then be `Handle`.+The callbacks are wrapped in `Resource.bracket`, so `Release` is guaranteed to+be called (as much as `Resource` is reliable).+The `Result` block is called when the transfer is complete; its returned value+is finally returned from `streamHandler.`+The `handle` is an arbitrary identifier that the user can return from+`Acquire`; it is not needed for the machinery and may be `()`.++# Entity++The library also provides effects for request and response entity de/encoding,+`EntityDecode d m a` and `EntityEncode d m a`, making it possible to abstract+over json implementations or content types using interpreters.+Since the effects are parameterized by the codec data type, one interpreter per+type must be used.++Implementations for [aeson] are available as `interpretEntityDecodeAeson` and+`interpretEntityEncodeAeson`:++```haskell+import Polysemy (run)+import qualified Polysemy.Http as Http+import Polysemy.Http (interpretEntityDecodeAeson)++data Dat { a :: Maybe Int, b :: Text }+deriving (Show, FromJSON)++main :: IO+main =+  print $ run $ interpretEntityDecodeAeson $ Http.decode "{ \"b\": \"hello\" }"+```++There is not integration with the `Http` effect for this.++# Testing++Polysemy makes it very easy to switch the native interpreter for a mock, and+there is a convenience interpreter named `interpretHttpStrict` that allows you+to specify a list of responses and chunks that should be produced:++```haskell+main :: IO ()+main = do+  result <- runM $+    resourceToIO $+    interpretLogStdout $+    interpretHttpStrict [Response (toEnum 200) "foo" []] [] $+    Http.request (Http.get "hackage.haskell.org" "package/polysemy-http")+  print result+```++[Polysemy]: https://hackage.haskell.org/package/polysemy+[http-client]: https://hackage.haskell.org/package/http-client+[http-types]: https://hackage.haskell.org/package/http-types+[aeson]: https://hackage.haskell.org/package/aeson

@@ -0,0 +1,18 @@+module Main where++import Test.Tasty (TestTree, defaultMain, testGroup)++import Polysemy.Http.RequestTest (test_request)+import Polysemy.Http.StreamTest (test_httpStream)+import Polysemy.Http.Test (unitTest)++tests :: TestTree+tests =+  testGroup "integration" [+    unitTest "simple request" test_request,+    unitTest "streaming http response handler" test_httpStream+  ]++main :: IO ()+main =+  defaultMain tests

@@ -0,0 +1,38 @@+module Polysemy.Http.RequestTest where++import Control.Lens ((.~))+import qualified Data.Aeson as Aeson+import Hedgehog (evalEither, (===))+import Polysemy (embedToFinal, runFinal)++import qualified Polysemy.Http.Data.Http as Http+import Polysemy.Http.Data.HttpError (HttpError)+import qualified Polysemy.Http.Data.Request as Request+import Polysemy.Http.Data.Request (Body(Body), Port(Port), Tls(Tls))+import qualified Polysemy.Http.Data.Response as Response+import Polysemy.Http.Data.Response (Response)+import Polysemy.Http.Json (jsonContentType)+import Polysemy.Http.Log (interpretLogNull)+import Polysemy.Http.Native (interpretHttpNative)+import qualified Polysemy.Http.Request as Request+import Polysemy.Http.Server (Payload(Payload), withServer)+import Polysemy.Http.Test (UnitTest)+import Polysemy.Resource (resourceToIOFinal)++runRequest ::+  Int ->+  IO (Either HttpError (Response LByteString))+runRequest port = do+  runFinal $ resourceToIOFinal $ embedToFinal $ interpretLogNull $ interpretHttpNative (Http.request request)+  where+  request =+    Request.post "localhost" "add" (Body (Aeson.encode (Payload 2 3)))+    & Request.tls .~ Tls False+    & Request.port .~ Just (Port port)+    & Request.headers .~ [jsonContentType]++test_request :: UnitTest+test_request = do+  result <- lift (withServer runRequest)+  response <- evalEither result+  "5" === Response.body response

@@ -0,0 +1,87 @@+{-# OPTIONS_GHC -fclear-plugins #-}++module Polysemy.Http.Server where++import Control.Concurrent (ThreadId, forkIO, killThread)+import Control.Exception (bracket)+import qualified Data.Text as Text+import Network.HTTP.Client (defaultManagerSettings, newManager)+import Network.Socket (+  PortNumber,+  addrAddress,+  addrFamily,+  addrProtocol,+  addrSocketType,+  bind,+  close,+  defaultHints,+  getAddrInfo,+  socket,+  socketPort,+  withSocketsDo,+  )+import qualified Network.Wai.Handler.Warp as Warp+import Servant (Get, Handler, JSON, PlainText, Post, ReqBody, ServerT, serve, (:<|>)((:<|>)), (:>))+import Servant.Client (BaseUrl(BaseUrl), Client, ClientEnv, ClientM, Scheme(Http), client, mkClientEnv, runClientM)++freePort ::+  IO PortNumber+freePort =+  withSocketsDo $ do+    addr : _ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")+    bracket (open addr) close socketPort+  where+    open addr = do+      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+      bind sock (addrAddress addr)+      return sock++data Payload =+  Payload {+    one :: Int,+    two :: Int+  }+  deriving (Eq, Show)++defaultJson ''Payload++type Api =+  Get '[JSON] Text+  :<|>+  "add" :> ReqBody '[JSON] Payload :> Post '[JSON] Int+  :<|>+  "stream" :> Get '[PlainText] Text++apiClient :: Client ClientM Api+apiClient =+  client (Proxy @Api)++check :: ClientM Text+check :<|> _ =+  apiClient++clientEnv ::+  BaseUrl ->+  IO ClientEnv+clientEnv baseUrl =+  flip mkClientEnv baseUrl <$> newManager defaultManagerSettings++server :: ServerT Api Handler+server =+  pure "OK"+  :<|>+  (\ (Payload a b) -> pure (a + b))+  :<|>+  pure (Text.replicate (10 * 8192) "x")++forkServer :: IO (ThreadId, Int)+forkServer = do+  port <- fromIntegral <$> freePort+  threadId <- forkIO (Warp.run port (serve (Proxy @Api) server))+  env <- clientEnv (BaseUrl Http "localhost" port "")+  runClientM check env+  pure (threadId, port)++withServer :: (Int -> IO a) -> IO a+withServer use =+  bracket forkServer (killThread . fst) (use . snd)

@@ -0,0 +1,61 @@+module Polysemy.Http.StreamTest where++import Control.Lens ((.~))+import qualified Data.ByteString as ByteString+import Hedgehog (assert, evalEither, (===))+import Polysemy (embedToFinal, runFinal)+import Polysemy.Http.Log (interpretLogStdout)+import Polysemy.Resource (resourceToIOFinal)+import Polysemy.State (runState)++import Polysemy.Http.Data.HttpError (HttpError)+import qualified Polysemy.Http.Data.Request as Request+import Polysemy.Http.Data.Request (Port(Port), Request, Tls(Tls))+import Polysemy.Http.Data.StreamChunk (StreamChunk(StreamChunk))+import qualified Polysemy.Http.Data.StreamEvent as StreamEvent+import Polysemy.Http.Data.StreamEvent (StreamEvent)+import qualified Polysemy.Http.Http as Http+import Polysemy.Http.Native (interpretHttpNative)+import qualified Polysemy.Http.Request as Request+import Polysemy.Http.Server (withServer)+import Polysemy.Http.Test (UnitTest)++req :: Int -> Request+req port =+  Request.get "localhost" "stream"+  & Request.port .~ Just (Port port)+  & Request.tls .~ Tls False++handle ::+  Members [Embed IO, State [Int]] r =>+  StreamEvent () (IO ByteString) () a ->+  Sem r a+handle = \case+  StreamEvent.Acquire _ ->+    unit+  StreamEvent.Chunk _ (StreamChunk c) ->+    modify (ByteString.length c :)+  StreamEvent.Result _ _ ->+    unit+  StreamEvent.Release _ ->+    unit++runRequest ::+  Int ->+  IO (Either HttpError ([Int], ()))+runRequest port =+  runFinal $+  resourceToIOFinal $+  embedToFinal $+  runError @HttpError $+  runState empty $+  interpretLogStdout $+  interpretHttpNative $+  Http.streamResponse (req port) handle++test_httpStream :: UnitTest+test_httpStream = do+  result <- lift (withServer runRequest)+  (chunkSizes, ()) <- evalEither result+  assert (length chunkSizes >= 10)+  sum chunkSizes === 10 * 8192

@@ -0,0 +1,11 @@+module Polysemy.Http.Test where++import Hedgehog (TestT, property, test, withTests)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++type UnitTest = TestT IO ()++unitTest :: TestName -> UnitTest -> TestTree+unitTest desc =+  testProperty desc . withTests 1 . property . test

@@ -0,0 +1,98 @@+module Polysemy.Http (+  -- $intro+  module Polysemy.Http.Data.Http,+  -- * Interpreters+  module Polysemy.Http.Native,+  module Polysemy.Http.Strict,+  -- * Request and Response+  module Polysemy.Http.Data.Request,+  module Polysemy.Http.Data.Response,+  module Polysemy.Http.Data.Header,+  module Polysemy.Http.Request,+  -- * Streaming+  module Polysemy.Http.Http,+  module Polysemy.Http.Data.StreamEvent,+  -- * Entity+  EntityDecode,+  decode,+  decodeStrict,+  EntityEncode,+  encode,+  encodeStrict,+  Entities,+  Decode,+  Encode,+  Decoders,+  Encoders,+  EntityError(EntityError),+  module Polysemy.Http.AesonEntity,+  -- * Utilities+  -- ** Connection Pool+  module Polysemy.Http.Data.Manager,+  -- ** Logging+  module Polysemy.Http.Data.Log,+  module Polysemy.Http.Log,+) where++import Polysemy.Http.AesonEntity (interpretEntityDecodeAeson, interpretEntityEncodeAeson)+import Polysemy.Http.Data.Entity (+  Decode,+  Decoders,+  Encode,+  Encoders,+  Entities,+  EntityDecode,+  EntityEncode,+  EntityError(EntityError),+  decode,+  decodeStrict,+  encode,+  encodeStrict,+  )+import Polysemy.Http.Data.Header (Header(Header), HeaderName(HeaderName), HeaderValue(HeaderValue))+import Polysemy.Http.Data.Http (Http, request, stream)+import Polysemy.Http.Data.Log (Log)+import Polysemy.Http.Data.Manager (Manager)+import Polysemy.Http.Data.Request (+  Body(Body),+  Host(Host),+  Method(..),+  Path(Path),+  Port(Port),+  QueryKey(QueryKey),+  QueryValue(QueryValue),+  Request(..),+  Tls(Tls),+  )+import Polysemy.Http.Data.Response (+  Response(..),+  pattern Client,+  pattern Info,+  pattern Redirect,+  pattern Server,+  pattern Success,+  )+import Polysemy.Http.Data.StreamEvent (StreamEvent(..))+import Polysemy.Http.Http (streamResponse)+import Polysemy.Http.Log (interpretLogNull, interpretLogStdout)+import Polysemy.Http.Native (interpretHttpNative)+import Polysemy.Http.Request (delete, deleteUrl, get, getUrl, post, postUrl, put, putUrl)+import Polysemy.Http.Strict (interpretHttpStrict)++-- $intro+-- A basic 'Polysemy' effect abstracting HTTP requests:+--+-- @+-- import Polysemy (resourceToIO, runM)+-- import qualified Polysemy.Http as Http+-- import Polysemy.Http (interpretHttpNative, interpretLogStdout)+--+-- main :: IO ()+-- main = do+--   result <- runM $+--     resourceToIO $+--     interpretLogStdout $+--     interpretHttpNative $+--     Http.request (Http.get "hackage.haskell.org" "package\/polysemy-http")+--   print result+-- @

@@ -0,0 +1,42 @@+module Polysemy.Http.AesonEntity where++import Data.Aeson (FromJSON, ToJSON, eitherDecode', eitherDecodeStrict', encode)+import Polysemy (Sem, interpret)++import Polysemy.Http.Data.Entity (EntityDecode, EntityEncode, EntityError(EntityError))+import qualified Polysemy.Http.Data.Entity as Entity (EntityDecode(..), EntityEncode(..))++-- |Interpreter for 'EntityEncode' that uses Aeson.+interpretEntityEncodeAeson ::+  ToJSON d =>+  Sem (EntityEncode d : r) a ->+  Sem r a+interpretEntityEncodeAeson =+  interpret \case+    Entity.Encode a ->+      pure (encode a)+    Entity.EncodeStrict a ->+      pure (toStrict (encode a))+{-# INLINE interpretEntityEncodeAeson #-}++decodeWith ::+  ConvertUtf8 Text s =>+  (s -> Either String a) ->+  s ->+  Sem r (Either EntityError a)+decodeWith dec body =+  pure . mapLeft (EntityError (decodeUtf8 body) . toText) $ dec body+{-# INLINE decodeWith #-}++-- |Interpreter for 'EntityDecode' that uses Aeson.+interpretEntityDecodeAeson ::+  FromJSON d =>+  Sem (EntityDecode d : r) a ->+  Sem r a+interpretEntityDecodeAeson =+  interpret \case+    Entity.Decode body ->+      decodeWith eitherDecode' body+    Entity.DecodeStrict body ->+      decodeWith eitherDecodeStrict' body+{-# INLINE interpretEntityDecodeAeson #-}

@@ -0,0 +1,87 @@+module Polysemy.Http.Data.Entity where++import Polysemy (makeSem_)++-- |Generic error type for decoders.+data EntityError =+  EntityError {+    body :: Text,+    message :: Text+  }+  deriving (Eq, Show)++-- |Abstraction of json encoding, potentially usable for other content types like xml.+data EntityEncode d :: Effect where+  Encode :: d -> EntityEncode d m LByteString+  EncodeStrict :: d -> EntityEncode d m ByteString++makeSem_ ''EntityEncode++-- |Lazily encode a value of type @d@ to a 'LByteString'+encode ::+  ∀ d r .+  Member (EntityEncode d) r =>+  d ->+  Sem r LByteString++-- |Strictly encode a value of type @d@ to a 'ByteString'+encodeStrict ::+  ∀ d r .+  Member (EntityEncode d) r =>+  d ->+  Sem r ByteString++-- |Abstraction of json decoding, potentially usable for other content types like xml.+data EntityDecode d :: Effect where+  Decode :: LByteString -> EntityDecode d m (Either EntityError d)+  DecodeStrict :: ByteString -> EntityDecode d m (Either EntityError d)++makeSem_ ''EntityDecode++-- |Lazily decode a 'LByteString' to a value of type @d@+decode ::+  ∀ d r .+  Member (EntityDecode d) r =>+  LByteString ->+  Sem r (Either EntityError d)++-- |Strictly decode a 'ByteString' to a value of type @d@+decodeStrict ::+  ∀ d r .+  Member (EntityDecode d) r =>+  ByteString ->+  Sem r (Either EntityError d)++-- |Marker type to be used with 'Entities'+data Encode a++-- |Marker type to be used with 'Entities'+data Decode a++-- |Convenience constraint for requiring multiple entity effects, to be used like 'Polysemy.Members'.+--+-- @+-- foo :: Entities [Encode Int, Decode Double] r => Sem r ()+-- @+type family Entities es r :: Constraint where+  Entities '[] r = ()+  Entities (Encode d ': ds) r = (Member (EntityEncode d) r, Entities ds r)+  Entities (Decode d ': ds) r = (Member (EntityDecode d) r, Entities ds r)++-- |Convenience constraint for requiring multiple encoders.+--+-- @+-- foo :: Encoders [Int, Double] r => Sem r ()+-- @+type family Encoders es r :: Constraint where+  Encoders '[] r = ()+  Encoders (d ': ds) r = (Member (EntityEncode d) r, Encoders ds r)++-- |Convenience constraint for requiring multiple decoders.+--+-- @+-- foo :: Decoders [Int, Double] r => Sem r ()+-- @+type family Decoders ds r :: Constraint where+  Decoders '[] r = ()+  Decoders (d ': ds) r = (Member (EntityDecode d) r, Decoders ds r)

@@ -0,0 +1,21 @@+module Polysemy.Http.Data.Header where++-- |The name of a header.+newtype HeaderName =+  HeaderName { unHeaderName :: Text }+  deriving (Eq, Show)+  deriving newtype (IsString)++-- |The value of a header.+newtype HeaderValue =+  HeaderValue { unHeaderValue :: Text }+  deriving (Eq, Show)+  deriving newtype (IsString)++-- |An HTTP header.+data Header =+  Header {+    name :: HeaderName,+    value :: HeaderValue+  }+  deriving (Eq, Show)

@@ -0,0 +1,39 @@+module Polysemy.Http.Data.Http where++import Polysemy (makeSem_)++import Polysemy.Http.Data.HttpError (HttpError)+import Polysemy.Http.Data.Request (Request)+import Polysemy.Http.Data.Response (Response)++-- |The main effect for HTTP requests.+-- The parameter @c@ determines the representation of raw chunks.+data Http c :: Effect where+  Request :: Request -> Http c m (Either HttpError (Response LByteString))+  Stream :: Request -> (Response c -> m (Either HttpError a)) -> Http c m (Either HttpError a)+  -- |Internal effect for streaming transfers.+  ConsumeChunk :: c -> Http c m (Either HttpError ByteString)++makeSem_ ''Http++-- |Synchronously run an HTTP request and return the response.+request ::+  ∀ c r .+  Member (Http c) r =>+  Request ->+  Sem r (Either HttpError (Response LByteString))++-- |Open a connection without consuming data and pass the response to a handler for custom transmission.+-- The intended purpose is to allow streaming transfers.+stream ::+  ∀ c r a .+  Member (Http c) r =>+  Request ->+  (Response c -> Sem r (Either HttpError a)) ->+  Sem r (Either HttpError a)++consumeChunk ::+  ∀ c r .+  Member (Http c) r =>+  c ->+  Sem r (Either HttpError ByteString)

@@ -0,0 +1,7 @@+module Polysemy.Http.Data.HttpError where++data HttpError =+  ChunkFailed Text+  |+  Internal Text+  deriving (Eq, Show)

@@ -0,0 +1,54 @@+module Polysemy.Http.Data.Log where++import Polysemy.Internal (send)++-- |An effect that wraps 'Colog.Polysemy.Log' for less boilerplate.+-- Constructors are manual because 'HasCallStack' is always in scope.+data Log :: Effect where+  Debug :: HasCallStack => Text -> Log m ()+  Info :: HasCallStack => Text -> Log m ()+  Warn :: HasCallStack => Text -> Log m ()+  Error :: HasCallStack => Text -> Log m ()+  ErrorPlus :: (HasCallStack, Traversable t) => Text -> t Text -> Log m ()++debug ::+  HasCallStack =>+  Member Log r =>+  Text ->+  Sem r ()+debug =+  send . Debug++info ::+  HasCallStack =>+  Member Log r =>+  Text ->+  Sem r ()+info =+  send . Info++warn ::+  HasCallStack =>+  Member Log r =>+  Text ->+  Sem r ()+warn =+  send . Warn++error ::+  HasCallStack =>+  Member Log r =>+  Text ->+  Sem r ()+error =+  send . Error++errorPlus ::+  HasCallStack =>+  Traversable t =>+  Member Log r =>+  Text ->+  t Text ->+  Sem r ()+errorPlus =+  send .: ErrorPlus

@@ -0,0 +1,9 @@+module Polysemy.Http.Data.Manager where++import qualified Network.HTTP.Client as HTTP (Manager)++-- |This effect abstracts the creation of a 'Manager' in order to allow pool sharing in a flexible way.+data Manager :: Effect where+  Get :: Manager m HTTP.Manager++makeSem ''Manager

@@ -0,0 +1,113 @@+module Polysemy.Http.Data.Request where++import Control.Lens (makeClassy)+import qualified Data.Text as Text++import Polysemy.Http.Data.Header (HeaderName, HeaderValue)++-- |All standard HTTP methods, mirroring those from 'Network.HTTP.Types', plus a constructor for arbitrary strings.+data Method =+  Get+  |+  Post+  |+  Put+  |+  Delete+  |+  Head+  |+  Trace+  |+  Connect+  |+  Options+  |+  Patch+  |+  Custom Text+  deriving (Eq, Show)++instance IsString Method where+  fromString = \case+    "GET" -> Get+    "POST" -> Post+    "PUT" -> Put+    "DELETE" -> Delete+    "HEAD" -> Head+    "TRACE" -> Trace+    "CONNECT" -> Connect+    "OPTIONS" -> Options+    "PATCH" -> Patch+    "get" -> Get+    "post" -> Post+    "put" -> Put+    "delete" -> Delete+    "head" -> Head+    "trace" -> Trace+    "connect" -> Connect+    "options" -> Options+    "patch" -> Patch+    a -> Custom (toText a)++-- |Produce the usual uppercase representation of a method.+methodUpper :: Method -> Text+methodUpper = \case+  Custom n -> Text.toUpper n+  a -> Text.toUpper (show a)++-- |Request host name.+newtype Host =+  Host { unHost :: Text }+  deriving (Eq, Show)+  deriving newtype (IsString)++-- |Request port.+newtype Port =+  Port { unPort :: Int }+  deriving (Eq, Show)++-- |A flag that indicates whether a request should use TLS.+newtype Tls =+  Tls { unTls :: Bool }+  deriving (Eq, Show)++-- |Rrequest path.+newtype Path =+  Path { unPath :: Text }+  deriving (Eq, Show)+  deriving newtype (IsString)++-- |The key of a query parameter.+newtype QueryKey =+  QueryKey { unQueryKey :: Text }+  deriving (Eq, Show)+  deriving newtype (IsString)++-- |The value of a query parameter.+newtype QueryValue =+  QueryValue { unQueryValue :: Text }+  deriving (Eq, Show)+  deriving newtype (IsString)++-- |Request body, using 'LByteString' because it is what 'Aeson.encode' produces.+newtype Body =+  Body { unBody :: LByteString }+  deriving (Eq, Show)+  deriving newtype (IsString)++-- |HTTP request parameters, used by 'Polysemy.Http.Data.Http'.+data Request =+  Request {+    _method :: Method,+    _host :: Host,+    _port :: Maybe Port,+    _tls :: Tls,+    _path :: Path,+    _headers :: [(HeaderName, HeaderValue)],+    _query :: [(QueryKey, Maybe QueryValue)],+    _body :: Body+  }+  deriving (Eq, Show)++makeClassy ''Request

@@ -0,0 +1,70 @@+module Polysemy.Http.Data.Response where++import Network.HTTP.Client (BodyReader)+import Network.HTTP.Types (+  Status,+  statusIsClientError,+  statusIsInformational,+  statusIsRedirection,+  statusIsServerError,+  statusIsSuccessful,+  )+import qualified Text.Show as Text (Show(show))++import Polysemy.Http.Data.Header (Header)++-- |The response produced by 'Polysemy.Http.Data.Http'.+data Response b =+  Response {+    -- |Uses the type from 'Network.HTTP' for convenience+    status :: Status,+    -- |parameterized in the body to allow different interpreters to use other representations.+    body :: b,+    -- |Does not use the type from 'Network.HTTP' because it is an alias.+    headers :: [Header]+  }+  deriving (Eq, Show)++instance {-# OVERLAPPING #-} Show (Response BodyReader) where+  show (Response s _ hs) =+    [qt|StreamingResponse { status :: #{s}, headers :: #{hs} }|]++-- |Match on a response with a 1xx status.+pattern Info ::+  Status ->+  b ->+  [Header] ->+  Response b+pattern Info s b h <- Response s@(statusIsInformational -> True) b h++-- |Match on a response with a 2xx status.+pattern Success ::+  Status ->+  b ->+  [Header] ->+  Response b+pattern Success s b h <- Response s@(statusIsSuccessful -> True) b h++-- |Match on a response with a 3xx status.+pattern Redirect ::+  Status ->+  b ->+  [Header] ->+  Response b+pattern Redirect s b h <- Response s@(statusIsRedirection -> True) b h++-- |Match on a response with a 4xx status.+pattern Client ::+  Status ->+  b ->+  [Header] ->+  Response b+pattern Client s b h <- Response s@(statusIsClientError -> True) b h++-- |Match on a response with a 5xx status.+pattern Server ::+  Status ->+  b ->+  [Header] ->+  Response b+pattern Server s b h <- Response s@(statusIsServerError -> True) b h

@@ -0,0 +1,6 @@+module Polysemy.Http.Data.StreamChunk where++-- |A single chunk produced by 'Network.HTTP.Client.BodyReader'.+newtype StreamChunk =+  StreamChunk ByteString+  deriving (Eq, Show)

@@ -0,0 +1,19 @@+module Polysemy.Http.Data.StreamEvent where++import Polysemy.Http.Data.Response (Response)+import Polysemy.Http.Data.StreamChunk (StreamChunk)++-- |Control algebra for streaming requests.+-- @r@ is the final return type of the stream handler, after the request is processed to completion.+-- @c@ is the raw chunk data type+-- @h@ is the handle type that identifies the active request. It is entirely controlled by the consumer and may be+-- empty.+data StreamEvent r c h a where+  -- |Used when calling the handler after the request has been initiated, but no data has been read.+  Acquire :: Response c -> StreamEvent r c h h+  -- |Used when calling the handler for each received chunk.+  Chunk :: h -> StreamChunk -> StreamEvent r c h ()+  -- |Used when calling the handler after the request has finished transferring. It should return the final result.+  Result :: Response c -> h -> StreamEvent r c h r+  -- |Used to finalize the transfer, e.g. for resource cleanup.+  Release :: h -> StreamEvent r c h ()

@@ -0,0 +1,72 @@+module Polysemy.Http.Http where++import qualified Data.ByteString as ByteString+import Polysemy.Resource (Resource, bracket)++import qualified Polysemy.Http.Data.Http as Http+import Polysemy.Http.Data.Http (Http)+import Polysemy.Http.Data.HttpError (HttpError)+import Polysemy.Http.Data.Request (Request)+import Polysemy.Http.Data.Response (Response(Response))+import Polysemy.Http.Data.StreamChunk (StreamChunk(StreamChunk))+import qualified Polysemy.Http.Data.StreamEvent as StreamEvent+import Polysemy.Http.Data.StreamEvent (StreamEvent)++streamLoop ::+  Members [Http c, Error HttpError] r =>+  (∀ x . StreamEvent o c h x -> Sem r x) ->+  Response c ->+  h ->+  Sem r o+streamLoop process response@(Response _ body _) handle =+  spin+  where+    spin =+      handleChunk =<< fromEither =<< Http.consumeChunk body+    handleChunk (ByteString.null -> True) =+      process (StreamEvent.Result response handle)+    handleChunk !chunk = do+      process (StreamEvent.Chunk handle (StreamChunk chunk))+      spin++streamHandler ::+  ∀ o r c h .+  Members [Http c, Error HttpError, Resource] r =>+  (∀ x . StreamEvent o c h x -> Sem r x) ->+  Response c ->+  Sem r o+streamHandler process response = do+  bracket acquire release (streamLoop process response)+  where+    acquire =+      process (StreamEvent.Acquire response)+    release handle =+      process (StreamEvent.Release handle)++-- |Initiate a request and stream the response, calling 'process' after connecting, for every chunk, after closing the+-- connection, and for the return value.+-- 'StreamEvent' is used to indicate the stage of the request cycle.+--+-- @+-- handle ::+--   StreamEvent Double (IO ByteString) Int a ->+--   Sem r a+-- handle = \\case+--   StreamEvent.Acquire (Response status body headers) ->+--     pure 1+--   StreamEvent.Chunk handle (StreamChunk c) ->+--     pure ()+--   StreamEvent.Result (Response status body headers) handle ->+--     pure 5.5+--   StreamEvent.Release handle ->+--     pure ()+-- @+-- >>> runInterpreters $ streamResponse (Http.get "host.com" "path/to/file") handle+-- 5.5+streamResponse ::+  Members [Http c, Error HttpError, Resource] r =>+  Request ->+  (∀ x . StreamEvent o c h x -> Sem r x) ->+  Sem r o+streamResponse request process =+  fromEither =<< Http.stream request (runError . streamHandler (raise . process))

@@ -0,0 +1,22 @@+module Polysemy.Http.Json where++import Control.Lens ((%~))++import Polysemy.Http.Data.Header (HeaderName, HeaderValue)+import qualified Polysemy.Http.Data.Http as Http+import Polysemy.Http.Data.Http (Http)+import Polysemy.Http.Data.HttpError (HttpError)+import qualified Polysemy.Http.Data.Request as Request+import Polysemy.Http.Data.Request (Request)+import Polysemy.Http.Data.Response (Response)++jsonContentType :: (HeaderName, HeaderValue)+jsonContentType =+  ("content-type", "application/json")++jsonRequest ::+  Member (Http c) r =>+  Request ->+  Sem r (Either HttpError (Response LByteString))+jsonRequest =+  Http.request . (Request.headers %~ (jsonContentType :))

@@ -0,0 +1,122 @@+module Polysemy.Http.Log where++import Colog.Core (LogAction(LogAction), Severity, cmapM)+import qualified Colog.Core as Severity (Severity(Error, Info, Debug, Warning))+import qualified Colog.Polysemy as Colog (Log, log)+import Colog.Polysemy.Effect (runLogAction)+import qualified Data.ByteString.Char8 as BS8+import GHC.Stack (SrcLoc(SrcLoc), popCallStack, srcLocModule, srcLocStartLine)+import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleLayer (Foreground), SGR (..), setSGRCode)++import Polysemy.Http.Data.Log (Log(..))++data Message =+  Message {+    msgSeverity :: !Severity,+    msgStack :: !CallStack,+    msgText :: !Text+  }++showSeverity :: Severity -> Text+showSeverity = \case+  Severity.Debug -> color Green "[Debug]   "+  Severity.Info -> color Blue "[Info]    "+  Severity.Warning -> color Yellow "[Warning] "+  Severity.Error -> color Red "[Error]   "+ where+   color :: Color -> Text -> Text+   color c txt =+     toText (setSGRCode [SetColor Foreground Vivid c]) <>+     txt <>+     toText (setSGRCode [Reset])++showSourceLoc :: CallStack -> Text+showSourceLoc cs =+  square showCallStack+  where+    showCallStack :: Text+    showCallStack = case getCallStack cs of+      [] -> "<unknown loc>"+      [(name, loc)] -> showLoc name loc+      (_, loc) : (callerName, _) : _ -> showLoc callerName loc+    square t = "[" <> t <> "] "+    showLoc :: String -> SrcLoc -> Text+    showLoc name SrcLoc{..} =+      toText srcLocModule <> "." <> toText name <> "#" <> show srcLocStartLine++fmtRichMessageDefault :: Message -> IO Text+fmtRichMessageDefault =+  pure . formatRichMessage+  where+    formatRichMessage :: Message -> Text+    formatRichMessage Message{..} =+        showSeverity msgSeverity+     <> showSourceLoc msgStack+     <> msgText++logByteStringStdout :: LogAction IO ByteString+logByteStringStdout = LogAction BS8.putStrLn++richMessageAction :: LogAction IO Message+richMessageAction =+    cmapM (fmap encodeUtf8 . fmtRichMessageDefault) logByteStringStdout+{-# INLINE richMessageAction #-}++log ::+  HasCallStack =>+  Member (Colog.Log Message) r =>+  Severity ->+  Text ->+  Sem r ()+log severity text =+  Colog.log (Message severity stack text)+  where+    stack =+      popCallStack (popCallStack callStack)++-- |No-op interpreter for 'Log'+interpretLogNull ::+  InterpreterFor Log r+interpretLogNull =+  interpret \case+    Debug _ -> unit+    Info _ -> unit+    Warn _ -> unit+    Error _ -> unit+    ErrorPlus _ _ -> unit+{-# INLINE interpretLogNull #-}++runCologStdout ::+  Member (Embed IO) r =>+  InterpreterFor (Colog.Log Message) r+runCologStdout =+  runLogAction @IO richMessageAction+{-# INLINE runCologStdout #-}++toColog ::+  HasCallStack =>+  Member (Colog.Log Message) r =>+  Sem (Log : r) a ->+  Sem r a+toColog =+  interpret \case+    Debug msg ->+      log Severity.Debug msg+    Info msg ->+      log Severity.Info msg+    Warn msg ->+      log Severity.Warning msg+    Error msg ->+      log Severity.Error msg+    ErrorPlus msg detailed ->+      log Severity.Error msg *> traverse_ (log Severity.Debug) detailed+{-# INLINE toColog #-}++-- |Default interpreter for 'Log' that uses 'Colog.Log' to print to stdout+interpretLogStdout ::+  Member (Embed IO) r =>+  Sem (Log : r) a ->+  Sem r a+interpretLogStdout =+  runCologStdout . toColog . raiseUnder+{-# INLINE interpretLogStdout #-}

@@ -0,0 +1,27 @@+module Polysemy.Http.Manager where++import Network.HTTP.Client (newManager)+import qualified Network.HTTP.Client as HTTP (Manager)+import Network.HTTP.Client.TLS (mkManagerSettings)++import Polysemy.Http.Data.Manager (Manager(..))++interpretManagerWith ::+  Member (Embed IO) r =>+  HTTP.Manager ->+  InterpreterFor Manager r+interpretManagerWith manager = do+  interpret \ Get -> pure manager+{-# INLINE interpretManagerWith #-}++-- |Trivial interpreter with a globally shared 'Manager' instance.+interpretManager ::+  Member (Embed IO) r =>+  InterpreterFor Manager r+interpretManager sem = do+  manager <- embed (newManager settings)+  interpretManagerWith manager sem+  where+    settings =+      mkManagerSettings def Nothing+{-# INLINE interpretManager #-}

@@ -0,0 +1,147 @@+module Polysemy.Http.Native where++import qualified Data.CaseInsensitive as CaseInsensitive+import Data.CaseInsensitive (foldedCase)+import Network.HTTP.Client (BodyReader, httpLbs, responseClose, responseOpen)+import qualified Network.HTTP.Client as HTTP (Manager)+import Network.HTTP.Simple (+  defaultRequest,+  getResponseBody,+  getResponseHeaders,+  getResponseStatus,+  setRequestBodyLBS,+  setRequestHeaders,+  setRequestHost,+  setRequestMethod,+  setRequestPath,+  setRequestPort,+  setRequestQueryString,+  setRequestSecure,+  )+import qualified Network.HTTP.Simple as N (Request, Response)+import Polysemy (Tactical, interpretH, runT)+import qualified Polysemy.Http.Data.Log as Log+import Polysemy.Http.Data.Log (Log)+import Polysemy.Resource (Resource, bracket)++import Polysemy.Http.Data.Header (Header(Header), unHeaderName, unHeaderValue)+import qualified Polysemy.Http.Data.Http as Http+import Polysemy.Http.Data.Http (Http)+import qualified Polysemy.Http.Data.HttpError as HttpError+import Polysemy.Http.Data.HttpError (HttpError)+import qualified Polysemy.Http.Data.Manager as Manager+import Polysemy.Http.Data.Manager (Manager)+import Polysemy.Http.Data.Request (+  Body(Body),+  Host(Host),+  Path(Path),+  Request(Request),+  Tls(Tls),+  methodUpper,+  unPort,+  unQueryKey,+  unQueryValue,+  )+import Polysemy.Http.Data.Response (Response(Response))+import Polysemy.Http.Manager (interpretManager)++-- |Converts a 'Request' to a native 'N.Request'.+nativeRequest :: Request -> N.Request+nativeRequest (Request method (Host host) portOverride (Tls tls) (Path path) headers query (Body body)) =+  cons defaultRequest+  where+    cons =+      scheme .+      setRequestMethod (encodeUtf8 $ methodUpper method) .+      setRequestHeaders encodedHeaders .+      setRequestHost (encodeUtf8 host) .+      setRequestPort port .+      setRequestPath (encodeUtf8 path) .+      setRequestQueryString queryParam .+      setRequestBodyLBS body+    queryParam =+      bimap (encodeUtf8 . unQueryKey) (fmap (encodeUtf8 . unQueryValue)) <$> query+    scheme =+      if tls then setRequestSecure True else id+    port =+      maybe (if tls then 443 else 80) unPort portOverride+    encodedHeaders =+      bimap (CaseInsensitive.mk . encodeUtf8 . unHeaderName) (encodeUtf8 . unHeaderValue) <$> headers++convertResponse :: N.Response b -> Response b+convertResponse response =+  Response (getResponseStatus response) (getResponseBody response) headers+  where+    headers =+      header <$> getResponseHeaders response+    header (foldedCase -> decodeUtf8 -> name, decodeUtf8 -> value) =+      Header (fromString name) (fromString value)++internalError ::+  Member (Embed IO) r =>+  IO a ->+  Sem r (Either HttpError a)+internalError =+  tryHoist HttpError.Internal++executeRequest ::+  Member (Embed IO) r =>+  HTTP.Manager ->+  Request ->+  Sem r (Either HttpError (Response LByteString))+executeRequest manager request =+  fmap convertResponse <$> internalError (httpLbs (nativeRequest request) manager)++-- |Default handler for 'Http.Stream'.+-- Uses 'bracket' to acquire and close the connection, calling 'StreamEvent.Acquire' and 'StreamEvent.Release' in the+-- corresponding phases.+httpStream ::+  Members [Embed IO, Log, Resource, Manager] r =>+  Request ->+  (Response BodyReader -> m (Either HttpError a)) ->+  Tactical (Http BodyReader) m r (Either HttpError a)+httpStream request handler =+  bracket acquire release use+  where+    acquire = do+      manager <- Manager.get+      internalError (responseOpen (nativeRequest request) manager)+    release (Right response) =+      tryAny (responseClose response) >>= traverseLeft closeFailed+    release (Left _) =+      unit+    use (Right response) = do+      raise . interpretHttpNativeWith =<< runT (handler (convertResponse response))+    use (Left err) =+      pureT (Left err)+    closeFailed err =+      Log.error [qt|closing response failed: #{err}|]+{-# INLINE httpStream #-}++-- |Same as 'interpretHttpNative', but the interpretation of 'Manager' is left to the user.+interpretHttpNativeWith ::+  Members [Embed IO, Log, Resource, Manager] r =>+  InterpreterFor (Http BodyReader) r+interpretHttpNativeWith =+  interpretH $ \case+    Http.Request request -> do+      Log.debug $ [qt|http request: #{request}|]+      manager <- Manager.get+      liftT do+        response <- executeRequest manager request+        response <$ Log.debug [qt|http response: #{response}|]+    Http.Stream request handler ->+      httpStream request handler+    Http.ConsumeChunk body ->+      pureT =<< mapLeft HttpError.ChunkFailed <$> tryAny body+{-# INLINE interpretHttpNativeWith #-}++-- |Interpret @'Http' 'BodyReader'@ using the native 'Network.HTTP.Client' implementation.+-- 'BodyReader' is an alias for @'IO' 'ByteString'@, it is how http-client represents chunks.+-- This uses the default interpreter for 'Manager'.+interpretHttpNative ::+  Members [Embed IO, Log, Resource] r =>+  InterpreterFor (Http BodyReader) r+interpretHttpNative =+  interpretManager . interpretHttpNativeWith . raiseUnder+{-# INLINE interpretHttpNative #-}

@@ -0,0 +1,178 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Polysemy.Http.Prelude (+  module Polysemy.Http.Prelude,+  module Data.Aeson,+  module Data.Aeson.TH,+  module Data.Composition,+  module Data.Default,+  module Data.Either.Combinators,+  module Data.Foldable,+  module Data.Map.Strict,+  module GHC.Err,+  module Polysemy,+  module Polysemy.State,+  module Polysemy.Error,+  module Relude,+) where++import Control.Exception (try)+import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson.TH (deriveFromJSON, deriveJSON)+import qualified Data.Aeson.TH as Aeson (Options, defaultOptions, unwrapUnaryRecords)+import Data.Composition ((.:))+import Data.Default (Default(def))+import Data.Either.Combinators (mapLeft)+import Data.Foldable (foldl, traverse_)+import Data.Map.Strict (Map)+import Data.String.Interpolate (i)+import GHC.Err (undefined)+import GHC.IO.Unsafe (unsafePerformIO)+import Language.Haskell.TH.Quote (QuasiQuoter)+import qualified Language.Haskell.TH.Syntax as TH+import Polysemy (+  Effect,+  Embed,+  InterpreterFor,+  Member,+  Members,+  Sem,+  WithTactics,+  embed,+  interpret,+  makeSem,+  pureT,+  raise,+  raiseUnder,+  raiseUnder2,+  raiseUnder3,+  )+import Polysemy.Error (Error, fromEither, runError, throw)+import Polysemy.State (State, evalState, get, gets, modify, put)+import Relude hiding (+  Reader,+  State,+  Type,+  ask,+  asks,+  evalState,+  get,+  gets,+  hoistEither,+  modify,+  put,+  readFile,+  runReader,+  runState,+  state,+  undefined,+  )++dbg :: Monad m => Text -> m ()+dbg msg = do+  () <- return $ unsafePerformIO (putStrLn (toString msg))+  return ()+{-# INLINE dbg #-}++dbgs :: Monad m => Show a => a -> m ()+dbgs a =+  dbg (show a)+{-# INLINE dbgs_ #-}++dbgs_ :: Monad m => Show a => a -> m a+dbgs_ a =+  a <$ dbg (show a)+{-# INLINE dbgs #-}++unit ::+  Applicative f =>+  f ()+unit =+  pure ()+{-# INLINE unit #-}++tuple ::+  Applicative f =>+  f a ->+  f b ->+  f (a, b)+tuple fa fb =+  (,) <$> fa <*> fb+{-# INLINE tuple #-}++unsafeLogSAnd :: Show a => a -> b -> b+unsafeLogSAnd a b =+  unsafePerformIO $ print a >> return b+{-# INLINE unsafeLogSAnd #-}++unsafeLogAnd :: Text -> b -> b+unsafeLogAnd a b =+  unsafePerformIO $ putStrLn (toString a) >> return b+{-# INLINE unsafeLogAnd #-}++unsafeLogS :: Show a => a -> a+unsafeLogS a =+  unsafePerformIO $ print a >> return a+{-# INLINE unsafeLogS #-}++qt :: QuasiQuoter+qt =+  i+{-# INLINE qt #-}++liftT ::+  forall m f r e a .+  Functor f =>+  Sem r a ->+  Sem (WithTactics e f m r) (f a)+liftT =+  pureT <=< raise+{-# INLINE liftT #-}++defaultOptions :: Aeson.Options+defaultOptions =+  Aeson.defaultOptions { Aeson.unwrapUnaryRecords = True }++hoistEither ::+  Member (Error e2) r =>+  (e1 -> e2) ->+  Either e1 a ->+  Sem r a+hoistEither f =+  fromEither . mapLeft f++tryAny ::+  Member (Embed IO) r =>+  IO a ->+  Sem r (Either Text a)+tryAny =+  embed . fmap (mapLeft show) . try @SomeException++tryHoist ::+  Member (Embed IO) r =>+  (Text -> e) ->+  IO a ->+  Sem r (Either e a)+tryHoist f =+  fmap (mapLeft f) . tryAny++tryThrow ::+  Members [Embed IO, Error e] r =>+  (Text -> e) ->+  IO a ->+  Sem r a+tryThrow f =+  fromEither <=< tryHoist f++traverseLeft ::+  Applicative m =>+  (a -> m b) ->+  Either a b ->+  m b+traverseLeft f =+  either f pure+{-# INLINE traverseLeft #-}++defaultJson :: TH.Name -> TH.Q [TH.Dec]+defaultJson =+  deriveJSON defaultOptions

@@ -0,0 +1,144 @@+module Polysemy.Http.Request where++import qualified Data.Text as Text+import Prelude hiding (get)++import Polysemy.Http.Data.Request (Body, Host(Host), Method(..), Path(Path), Port(Port), Request(Request), Tls(Tls))++invalidScheme ::+  Text ->+  Text ->+  Either Text a+invalidScheme scheme url =+  Left [qt|invalid scheme `#{scheme}` in url: #{url}|]++split ::+  Text ->+  Text ->+  (Text, Maybe Text)+split target t =+  case Text.breakOn target t of+    (a, "") -> (a, Nothing)+    (a, b) -> (a, Just (Text.drop (Text.length target) b))++parseScheme ::+  Text ->+  (Text, Maybe Text) ->+  Either Text (Tls, Text)+parseScheme url = \case+  (full, Nothing) -> Right (Tls True, full)+  ("https", Just rest) -> Right (Tls True, rest)+  ("http", Just rest) -> Right (Tls False, rest)+  (scheme, _) -> invalidScheme scheme url++parseHostPort ::+  Text ->+  (Text, Maybe Text) ->+  Either Text (Host, Maybe Port)+parseHostPort url = \case+  (host, Nothing) -> Right (Host host, Nothing)+  (host, Just (readMaybe . toString -> Just port)) -> Right (Host host, Just (Port port))+  (_, Just port) -> Left [qt|invalid port `#{port}` in url: #{url}|]++parseUrl ::+  Text ->+  Either Text (Tls, Host, Maybe Port, Path)+parseUrl url = do+  (tls, split "/" -> (hostPort, path)) <- parseScheme url (split "://" url)+  (host, port) <- parseHostPort url (split ":" hostPort)+  pure (tls, host, port, Path (fromMaybe "" path))++withPort ::+  Maybe Port ->+  Tls ->+  Method ->+  Host ->+  Path ->+  Body ->+  Request+withPort port tls method host path =+  Request method host port tls path [] []++withTls ::+  Tls ->+  Method ->+  Host ->+  Path ->+  Body ->+  Request+withTls =+  withPort Nothing++simple ::+  Method ->+  Host ->+  Path ->+  Body ->+  Request+simple =+  withTls (Tls True)++get ::+  Host ->+  Path ->+  Request+get host path =+  simple Get host path ""++post ::+  Host ->+  Path ->+  Body ->+  Request+post host path =+  simple Post host path++put ::+  Host ->+  Path ->+  Body ->+  Request+put host path =+  simple Put host path++delete ::+  Host ->+  Path ->+  Request+delete host path =+  simple Delete host path ""++fromUrl ::+  Method ->+  Body ->+  Text ->+  Either Text Request+fromUrl method body url = do+  (tls, host, port, path) <- parseUrl url+  pure (withPort port tls method host path body)++getUrl ::+  Text ->+  Either Text Request+getUrl =+  fromUrl Get ""++postUrl ::+  Body ->+  Text ->+  Either Text Request+postUrl =+  fromUrl Post++putUrl ::+  Body ->+  Text ->+  Either Text Request+putUrl =+  fromUrl Put++deleteUrl ::+  Text ->+  Either Text Request+deleteUrl =+  fromUrl Delete ""

@@ -0,0 +1,62 @@+module Polysemy.Http.Strict where++import Polysemy (interpretH, pureT)+import Polysemy.Internal.Tactics hiding (liftT)++import Polysemy.Http.Data.Header (Header(Header))+import qualified Polysemy.Http.Data.Http as Http+import Polysemy.Http.Data.Http (Http)+import Polysemy.Http.Data.HttpError (HttpError)+import Polysemy.Http.Data.Response (Response(Response))++takeResponse ::+  Member (State [Response LByteString]) r =>+  [Response LByteString] ->+  Sem r (Either a (Response LByteString))+takeResponse (response : rest) =+  Right response <$ put rest+takeResponse [] =+  pure (Right (Response (toEnum 502) "test responses exhausted" []))++takeChunk ::+  Member (State [ByteString]) r =>+  [ByteString] ->+  Sem r ByteString+takeChunk (chunk : rest) =+  chunk <$ put rest+takeChunk [] =+  pure ""++streamResponse :: Response Int+streamResponse =+  Response (toEnum 200) 1 [+    Header "content-disposition" [qt|filename="file.txt"|],+    Header "content-length" "5000000"+    ]++interpretHttpStrictWithState ::+  Members [Embed IO, State [ByteString], State [Response LByteString], Error HttpError] r =>+  InterpreterFor (Http Int) r+interpretHttpStrictWithState =+  interpretH $ \case+    Http.Request _ ->+      liftT . takeResponse =<< raise get+    Http.Stream _ handler -> do+      handle <- bindT handler+      resp <- pureT streamResponse+      raise (interpretHttpStrictWithState (handle resp))+    Http.ConsumeChunk _ ->+      liftT . fmap Right . takeChunk =<< raise get+{-# INLINE interpretHttpStrictWithState #-}++-- |In-Memory interpreter for 'Http'.+-- 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 =>+  [Response LByteString] ->+  [ByteString] ->+  InterpreterFor (Http Int) r+interpretHttpStrict responses chunks =+  evalState chunks . evalState responses . interpretHttpStrictWithState . raiseUnder . raiseUnder+{-# INLINE interpretHttpStrict #-}

@@ -0,0 +1,5 @@+module Prelude (+  module Polysemy.Http.Prelude,+) where++import Polysemy.Http.Prelude

@@ -0,0 +1,187 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.2.+--+-- see: https://github.com/sol/hpack++name:           polysemy-http+version:        0.1.0.0+synopsis:       Polysemy effect for http-client+description:    Please see the README on Github at <https://github.com/tek/polysemy-http>+category:       Network+author:         Torsten Schmits+maintainer:     tek@tryp.io+copyright:      2020 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    Changelog.md++library+  exposed-modules:+      Polysemy.Http+      Polysemy.Http.AesonEntity+      Polysemy.Http.Data.Entity+      Polysemy.Http.Data.Header+      Polysemy.Http.Data.Http+      Polysemy.Http.Data.HttpError+      Polysemy.Http.Data.Log+      Polysemy.Http.Data.Manager+      Polysemy.Http.Data.Request+      Polysemy.Http.Data.Response+      Polysemy.Http.Data.StreamChunk+      Polysemy.Http.Data.StreamEvent+      Polysemy.Http.Http+      Polysemy.Http.Json+      Polysemy.Http.Log+      Polysemy.Http.Manager+      Polysemy.Http.Native+      Polysemy.Http.Prelude+      Polysemy.Http.Request+      Polysemy.Http.Strict+      Paths_polysemy_http+  other-modules:+      Prelude+  autogen-modules:+      Paths_polysemy_http+  hs-source-dirs:+      lib+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns+  build-depends:+      aeson >=1.4.7+    , ansi-terminal >=0.10.3+    , base-noprelude >=4.13.0+    , bytestring >=0.10.10+    , case-insensitive >=1.2.1+    , co-log-core >=0.2.1+    , co-log-polysemy >=0.0.1+    , composition >=1.0.2+    , containers >=0.6.2+    , data-default >=0.7.1+    , either >=5.0.1+    , http-client >=0.6.4+    , http-client-tls >=0.3.5+    , http-conduit >=2.3.7+    , http-types >=0.12.3+    , lens >=4.19.2+    , 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+    , text >=1.2.3+  if impl(ghcjs)+  else+    ghc-options: -fplugin=Polysemy.Plugin -O2 -flate-specialise -fspecialise-aggressively+    build-depends:+        polysemy-plugin+  default-language: Haskell2010++test-suite polysemy-http-integration+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Polysemy.Http.RequestTest+      Polysemy.Http.Server+      Polysemy.Http.StreamTest+      Polysemy.Http.Test+      Paths_polysemy_http+  hs-source-dirs:+      integration+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson >=1.4.7+    , ansi-terminal >=0.10.3+    , base-noprelude >=4.13.0+    , bytestring >=0.10.10+    , case-insensitive >=1.2.1+    , co-log-core >=0.2.1+    , co-log-polysemy >=0.0.1+    , composition >=1.0.2+    , containers >=0.6.2+    , data-default >=0.7.1+    , either >=5.0.1+    , hedgehog+    , http-client >=0.6.4+    , http-client-tls >=0.3.5+    , http-conduit >=2.3.7+    , http-types >=0.12.3+    , lens >=4.19.2+    , mono-traversable >=1.0.15+    , network+    , polysemy >=1.3.0+    , polysemy-http+    , polysemy-plugin >=0.2.5+    , relude >=0.7.0+    , servant+    , servant-client+    , servant-server+    , string-interpolate >=0.2.1+    , tasty+    , tasty-hedgehog+    , template-haskell >=2.16.0+    , text >=1.2.3+    , warp+  mixins:+      polysemy-http hiding (Prelude)+    , polysemy-http (Polysemy.Http.Prelude as Prelude)+  if impl(ghcjs)+  else+    ghc-options: -fplugin=Polysemy.Plugin -O2 -flate-specialise -fspecialise-aggressively+    build-depends:+        polysemy-plugin+  default-language: Haskell2010++test-suite polysemy-http-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Polysemy.Http.ResponseTest+      Polysemy.Http.Test+      Polysemy.Http.UrlTest+      Paths_polysemy_http+  hs-source-dirs:+      test+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson >=1.4.7+    , ansi-terminal >=0.10.3+    , base-noprelude >=4.13.0+    , bytestring >=0.10.10+    , case-insensitive >=1.2.1+    , co-log-core >=0.2.1+    , co-log-polysemy >=0.0.1+    , composition >=1.0.2+    , containers >=0.6.2+    , data-default >=0.7.1+    , either >=5.0.1+    , hedgehog+    , http-client >=0.6.4+    , http-client-tls >=0.3.5+    , http-conduit >=2.3.7+    , http-types >=0.12.3+    , lens >=4.19.2+    , mono-traversable >=1.0.15+    , polysemy >=1.3.0+    , polysemy-http+    , polysemy-plugin >=0.2.5+    , relude >=0.7.0+    , string-interpolate >=0.2.1+    , tasty+    , tasty-hedgehog+    , template-haskell >=2.16.0+    , text >=1.2.3+  mixins:+      polysemy-http hiding (Prelude)+    , polysemy-http (Polysemy.Http.Prelude as Prelude)+  if impl(ghcjs)+  else+    ghc-options: -fplugin=Polysemy.Plugin -O2 -flate-specialise -fspecialise-aggressively+    build-depends:+        polysemy-plugin+  default-language: Haskell2010

@@ -0,0 +1,18 @@+module Main where++import Polysemy.Http.Test (unitTest)+import Test.Tasty (TestTree, defaultMain, testGroup)++import Polysemy.Http.ResponseTest (test_statusPattern)+import Polysemy.Http.UrlTest (test_url)++tests :: TestTree+tests =+  testGroup "unit" [+    unitTest "url parser" test_url,+    unitTest "status pattern" test_statusPattern+    ]++main :: IO ()+main =+  defaultMain tests

@@ -0,0 +1,21 @@+module Polysemy.Http.ResponseTest where++import Hedgehog ((===))++import qualified Polysemy.Http.Data.Response as Response+import Polysemy.Http.Data.Response (Response(Response))+import Polysemy.Http.Test (UnitTest)++response :: Response ()+response =+  Response (toEnum 404) () []++match :: Response a -> Int+match = \case+  Response.Success _ _ _ -> 0+  Response.Client _ _ _ -> 1+  _ -> 2++test_statusPattern :: UnitTest+test_statusPattern =+  1 === match response

@@ -0,0 +1,11 @@+module Polysemy.Http.Test where++import Hedgehog (TestT, property, test, withTests)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++type UnitTest = TestT IO ()++unitTest :: TestName -> UnitTest -> TestTree+unitTest desc =+  testProperty desc . withTests 1 . property . test

@@ -0,0 +1,20 @@+module Polysemy.Http.UrlTest where++import Hedgehog ((===))++import Polysemy.Http.Data.Request (Host(Host), Path(Path), Port(Port), Tls(Tls))+import Polysemy.Http.Request (parseUrl)+import Polysemy.Http.Test (UnitTest)++test_url :: UnitTest+test_url = do+  Right (Tls True, Host "host.com", Nothing, Path "path") === parseUrl "https://host.com/path"+  Right (Tls True, Host "host.com", Nothing, Path "path/to/file") === parseUrl "host.com/path/to/file"+  Right (Tls False, Host "host.com", Just (Port 553), Path "path") === parseUrl "http://host.com:553/path"+  Left [qt|invalid port `foo` in url: #{url1}|] === parseUrl url1+  Left [qt|invalid scheme `httpx` in url: #{url2}|] === parseUrl url2+  where+    url1 =+      "http://host.com:foo"+    url2 =+      "httpx://host.com/path"