├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── benchmarks ├── Main.hs ├── benchmarks.html └── benchmarks.png ├── free-http.cabal ├── free-http.nix ├── shell.nix └── src └── Network └── HTTP └── Client ├── Free.hs └── Free ├── ArbitraryClient.hs ├── Examples.hs ├── HttpClient.hs ├── PureClient.hs ├── Types.hs └── Util.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.tags 2 | dist/* 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 aaron levin 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Free Your Client... and Your Requests Will Follow 2 | ================================================= 3 | 4 | `free-http` is an http-client based on Free Monads. `free-http` exposes a Free Monad to express standard http verbs as well as several backends to interpet programs written in the free monad using various http clients (currently: a pure client, an `http-client`-backed client, and a random client). 5 | 6 | See [here](https://github.com/aaronlevin/free-http/blob/master/src/Network/HTTP/Client/Free/Examples.hs#L152) for an example. 7 | 8 | To use free-http, simply: 9 | 10 | 1. Import Network.HTTP.Client.Free to use the library. 11 | 2. Choose your base request type by defining your own instance of the `RequestType` type family or importing one from an interpreter. E.g. 12 | 13 | ``` 14 | data MyClient 15 | type instance RequestType MyClient = Request 16 | ``` 17 | 18 | or 19 | 20 | ``` 21 | import Network.HTTP.Free.Client.HttpClient (HttpClient) 22 | ``` 23 | 24 | 3. Choose your base response type by defining your own instance of the `ResponseTYpe` type family or importing one from an interpreter. E.g. 25 | 26 | ``` 27 | type instance ResponseType MyClient = Response ByteString 28 | ``` 29 | 30 | or 31 | 32 | ``` 33 | import Network.HTTP.Free.Client.HttpClient (HttpClient) 34 | ``` 35 | 36 | 4. Write a program in the 'FreeHttp MyClient m a' free monad. 37 | 5. Import an interpreter, such as 'HttpClient' 38 | 39 | ``` 40 | import Network.HTTP.Free.Client.HttpClient 41 | ``` 42 | 43 | 6. Run your program against the interpreter: 44 | 45 | ``` 46 | runHttp (myProgram :: FreeHttp MyClient IO String) 47 | ``` 48 | 49 | ## Design Choices 50 | 51 | ### `RequestType` and `ResponseType` 52 | 53 | Haskell is fortunate to have several very well-designed http clients: [http-client](https://hackage.haskell.org/package/http-client-0.4.16/docs/Network-HTTP-Client.html), [wreq](http://www.serpentine.com/wreq/), [http-conduit](https://hackage.haskell.org/package/http-conduit), [pipes-http](https://hackage.haskell.org/package/pipes-http), etc. Unfortunately, a few of those clients support several different *Request* and *Response* types. To keep `free-http` flexible, we use two type families defined as: 54 | 55 | ``` 56 | type family RequestType client :: * 57 | type family ResponseType client :: * 58 | ``` 59 | 60 | Our `HttpF` functor is thus defined as: 61 | 62 | ``` 63 | data HttpF client a = HttpF StdMethod (RequestType client) (ResponseType client -> a) 64 | deriving Functor 65 | ``` 66 | 67 | This allows our `HttpF` functor to be agnostic of the foundational request and response type, while allowing interpreter authors to specify the concrete types they need for their http client libraries (e.g. `Request` in the case of `http-client`). A consequence of this is that `free-http` clients (you) need to specify, at some point, the foundation you're using. This can be done in two ways: 68 | 69 | 1. You can define your own foundation (see above). 70 | 2. You can import one from an interpreter. 71 | 72 | To specify your request and response foundation, use replace the `client` type in `HttpF client a` or `FreeHttp client m a` to the type signalling your foundation. For example, the http-client, pure, and arbitrary interpreters use `HttpClient`, `PureClient`, and `ArbitraryClient` respectively. 73 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad (replicateM, foldM, foldM_) 6 | import Control.Monad.Trans.Free.Church (FT) 7 | import Criterion.Main (bench, defaultMain, nfIO) 8 | import Data.ByteString.Lazy (ByteString) 9 | import Network.HTTP.Client (Manager, Request, 10 | Response, 11 | defaultManagerSettings, 12 | httpLbs, newManager, 13 | parseUrl, responseBody) 14 | import Network.HTTP.Client.Free (HttpF, get) 15 | import Network.HTTP.Client.Free.HttpClient (HttpClient, runHttp) 16 | import System.Environment (getArgs) 17 | import System.Remote.Monitoring 18 | 19 | type Client = FT (HttpF HttpClient) IO ByteString 20 | 21 | freeProgram :: Int -> Request -> FT (HttpF HttpClient) IO [ByteString] 22 | freeProgram i req = fmap responseBody <$> replicateM i (get req) 23 | 24 | ioProgram :: Manager -> Int -> Request -> IO [ByteString] 25 | ioProgram manager i req = fmap responseBody <$> replicateM i (httpLbs req manager) 26 | 27 | foldProgram :: Int -> Request -> FT (HttpF HttpClient) IO () 28 | foldProgram i req = foldM_ (const . const $ get req) undefined [1..i] 29 | 30 | foldIo :: Manager -> Int -> Request -> IO () 31 | foldIo manager i req = foldM_ (const . const $ httpLbs req manager) undefined [1..i] 32 | 33 | main :: IO () 34 | main = do 35 | forkServer "localhost" 8000 36 | req <- parseUrl "http://localhost:8000" 37 | manager <- newManager defaultManagerSettings 38 | defaultMain [ bench "http-client: replicateM 1 request" $ nfIO (ioProgram manager 1 req) 39 | , bench "free-http: replicateM 1 request" $ nfIO (runHttp manager (freeProgram 1 req)) 40 | , bench "http-client: replicateM 10 requests" $ nfIO (ioProgram manager 10 req) 41 | , bench "free-http: replicateM 10 requests" $ nfIO (runHttp manager (freeProgram 10 req)) 42 | , bench "http-client: replicateM 100 requests" $ nfIO (ioProgram manager 100 req) 43 | , bench "free-http: replicateM 100 requests" $ nfIO (runHttp manager (freeProgram 100 req)) 44 | , bench "http-client: replicateM 1000 requests" $ nfIO (ioProgram manager 1000 req) 45 | , bench "free-http: replicateM 1000 requests" $ nfIO (runHttp manager (freeProgram 1000 req)) 46 | , bench "http-client: replicateM 10000 requests" $ nfIO (ioProgram manager 10000 req) 47 | , bench "free-http: replicateM 10000 requests" $ nfIO (runHttp manager (freeProgram 10000 req)) 48 | , bench "http-client: foldM 1000 requests" $ nfIO (foldIo manager 1000 req) 49 | , bench "free-http: foldM 1000 requests" $ nfIO (runHttp manager (foldProgram 1000 req)) 50 | ] 51 | 52 | -------------------------------------------------------------------------------- /benchmarks/benchmarks.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/aaronlevin/free-http/25c3d94aeffd5c1191072dfa8f51ccb9d6016373/benchmarks/benchmarks.png -------------------------------------------------------------------------------- /free-http.cabal: -------------------------------------------------------------------------------- 1 | name: free-http 2 | 3 | version: 0.2.0 4 | 5 | synopsis: An HTTP Client based on Free Monads. 6 | 7 | description: `free-http` is an http-client based on Free Monads. 8 | `free-http` exposes a Free Monad to express standard http 9 | verbs as well as several backends to interpet programs 10 | written in the free monad using various http clients 11 | (currently: a pure client, an `http-client`-backed client, 12 | and a random client). Please see the ReadMe for usage. 13 | 14 | homepage: https://github.com/aaronlevin/free-http 15 | 16 | license: MIT 17 | 18 | license-file: LICENSE 19 | 20 | author: Aaron Levin 21 | 22 | maintainer: vilevin@gmail.com 23 | 24 | category: Network 25 | 26 | build-type: Simple 27 | 28 | extra-source-files: README.md 29 | , LICENSE 30 | 31 | cabal-version: >=1.10 32 | 33 | source-repository head 34 | type: git 35 | location: git://github.com/aaronlevin/free-http.git 36 | 37 | library 38 | exposed-modules: Network.HTTP.Client.Free 39 | Network.HTTP.Client.Free.ArbitraryClient 40 | Network.HTTP.Client.Free.HttpClient 41 | Network.HTTP.Client.Free.PureClient 42 | Network.HTTP.Client.Free.Types 43 | Network.HTTP.Client.Free.Util 44 | 45 | other-modules: Network.HTTP.Client.Free.Examples 46 | 47 | -- other-extensions: 48 | 49 | build-depends: base > 4.6 && < 4.9 50 | , bytestring >= 0.10.0.0 51 | , free >= 4.0 52 | , http-client >= 0.4.0 53 | , http-types >= 0.8.0 54 | , mtl >= 2.0.0.0 55 | , QuickCheck >= 2.7 56 | , text >= 1.0.0.0 57 | , time >= 1.4.0.1 58 | , transformers >= 0.4.0.0 59 | 60 | hs-source-dirs: src 61 | 62 | default-language: Haskell2010 63 | 64 | executable benchmarks 65 | hs-source-dirs: benchmarks 66 | main-is: Main.hs 67 | ghc-options: -O -threaded -rtsopts -with-rtsopts=-N 68 | build-depends: base 69 | , bytestring 70 | , criterion 71 | , ekg 72 | , free 73 | , free-http 74 | , http-client 75 | -------------------------------------------------------------------------------- /free-http.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, free, http-client, http-types 2 | , mtl, QuickCheck, stdenv, text, time, transformers 3 | }: 4 | mkDerivation { 5 | pname = "free-http"; 6 | version = "0.1.0.0"; 7 | src = ./.; 8 | buildDepends = [ 9 | base bytestring free http-client http-types mtl QuickCheck text 10 | time transformers 11 | ]; 12 | homepage = "https://github.com/aaronlevin/free-http"; 13 | description = "Free Monad-based HTTP Client"; 14 | license = stdenv.lib.licenses.mit; 15 | } 16 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? (import {}) }: 2 | let 3 | lib = nixpkgs.haskell-ng.lib; 4 | haskell = nixpkgs.haskellngPackages.override { 5 | overrides = self: super: { 6 | # overrides here 7 | 8 | machines = lib.overrideCabal super.machines (drv: { 9 | src = nixpkgs.fetchFromGitHub { 10 | owner = "ekmett"; 11 | repo = "machines"; 12 | rev = "c1386ae0cbbd4aa843ad4512a0c19b0c6c8a4786"; 13 | sha256 = "1nlh7b1p7fpxs6dw68h1c77ygspdv30hzi7ryr8v9pjs47f1ala1"; 14 | }; 15 | }); 16 | cabal-helper = lib.overrideCabal super.cabal-helper (drv: { 17 | src = nixpkgs.fetchFromGitHub { 18 | owner = "DanielG"; 19 | repo = "cabal-helper"; 20 | rev = "f69f35bc4af49b3a25ed6407375c03f5b7569432"; 21 | sha256 = "0ngim8j159ssxmaqn8vm9znr2gn22jgmc5bwk2z8fgvsxvzrslfl"; 22 | }; 23 | buildDepends = drv.buildDepends ++ [ self.utf8-string self.extra self.unix ]; 24 | }); 25 | 26 | ghc-mod = lib.overrideCabal super.ghc-mod (drv: { 27 | broken = false; 28 | src = nixpkgs.fetchFromGitHub { 29 | owner = "kazu-yamamoto"; 30 | repo = "ghc-mod"; 31 | rev = "bfa0b965ee3497f5f41d261072dc6bae0af00a06"; 32 | sha256 = "10id8hmkzw03v7910h7z6m1vzafrwrazjkmnzc993fwrpg0n85i7"; 33 | }; 34 | version = "5.2.1"; 35 | buildDepends = drv.buildDepends ++ [ self.cabal-helper self.cereal ]; 36 | }); 37 | 38 | # we override `my-project` to add dev/build dependencies 39 | # note that because we use `self.callPackage` self will have local-common-lib. 40 | free-http = lib.addBuildTools (self.callPackage ./free-http.nix {}) [ 41 | # haskell-related build/dev tools 42 | self.cabal-install 43 | self.ghc-mod 44 | self.hasktags 45 | self.stylish-haskell 46 | self.codex 47 | 48 | # non-haskell-related build/dev tools 49 | self.cabal2nix 50 | ]; 51 | }; 52 | }; 53 | in 54 | haskell.free-http.env 55 | -------------------------------------------------------------------------------- /src/Network/HTTP/Client/Free.hs: -------------------------------------------------------------------------------- 1 | {-| The primary Free Monad wrapping HTTP actions. 2 | -} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Network.HTTP.Client.Free ( 7 | 8 | -- * Type Families 9 | -- ** Base Request type 10 | RequestType 11 | -- ** Base Response type 12 | , ResponseType 13 | 14 | -- * Types 15 | -- ** The base functor from which our free monad is generated. 16 | , HttpF(HttpF) 17 | -- ** A helpful type alias 18 | , FreeHttp 19 | 20 | -- * Handy morphisms for working with HttpF 21 | , natHttpF 22 | , transHttp 23 | 24 | -- * smart constructors for http verbs 25 | , connect 26 | , delete 27 | , get 28 | , head 29 | , options 30 | , patch 31 | , post 32 | , put 33 | , trace 34 | 35 | ) where 36 | 37 | import Control.Monad.Trans.Free.Church (FT, liftF, transFT) 38 | import Network.HTTP.Client (httpLbs, Manager, Request, Response) 39 | import Network.HTTP.Client.Free.Types (FreeHttp, HttpF(HttpF), RequestType, ResponseType) 40 | import Network.HTTP.Types.Method (StdMethod(..)) 41 | import Prelude hiding (head) 42 | 43 | get :: Monad m 44 | => RequestType client 45 | -> FT (HttpF client) m (ResponseType client) 46 | get req = liftF (HttpF GET req id) 47 | 48 | post :: Monad m 49 | => RequestType client 50 | -> FT (HttpF client) m (ResponseType client) 51 | post req = liftF (HttpF POST req id) 52 | 53 | head :: Monad m 54 | => RequestType client 55 | -> FT (HttpF client) m (ResponseType client) 56 | head req = liftF (HttpF HEAD req id) 57 | 58 | put :: Monad m 59 | => RequestType client 60 | -> FT (HttpF client) m (ResponseType client) 61 | put req = liftF (HttpF PUT req id) 62 | 63 | delete :: Monad m 64 | => RequestType client 65 | -> FT (HttpF client) m (ResponseType client) 66 | delete req = liftF (HttpF DELETE req id) 67 | 68 | trace :: Monad m 69 | => RequestType client 70 | -> FT (HttpF client) m (ResponseType client) 71 | trace req = liftF (HttpF TRACE req id) 72 | 73 | connect :: Monad m 74 | => RequestType client 75 | -> FT (HttpF client) m (ResponseType client) 76 | connect req = liftF (HttpF CONNECT req id) 77 | 78 | options :: Monad m 79 | => RequestType client 80 | -> FT (HttpF client) m (ResponseType client) 81 | options req = liftF (HttpF OPTIONS req id) 82 | 83 | patch :: Monad m 84 | => RequestType client 85 | -> FT (HttpF client) m (ResponseType client) 86 | patch req = liftF (HttpF PATCH req id) 87 | 88 | -- | A natural transformation between 'HttpF' types. 89 | natHttpF :: (RequestType client1 -> RequestType client2) 90 | -> (ResponseType client2 -> ResponseType client1) 91 | -> HttpF client1 a 92 | -> HttpF client2 a 93 | natHttpF reqT respT (HttpF method req resp) = HttpF method (reqT req) (resp . respT) 94 | 95 | -- | 'transHttp' allows clients to mix-and-match http request and response 96 | -- foundations, so long as there is an appropriate morphism. 97 | transHttp :: Monad m 98 | => (RequestType client1 -> RequestType client2) 99 | -> (ResponseType client2 -> ResponseType client1) 100 | -> FreeHttp client1 m a 101 | -> FreeHttp client2 m a 102 | transHttp reqT respT = transFT (natHttpF reqT respT) 103 | -------------------------------------------------------------------------------- /src/Network/HTTP/Client/Free/ArbitraryClient.hs: -------------------------------------------------------------------------------- 1 | {-| An interpreter that fails randomly 2 | -} 3 | 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Network.HTTP.Client.Free.ArbitraryClient where 7 | 8 | import Control.Monad.IO.Class (MonadIO, liftIO) 9 | import Control.Monad.Trans (MonadTrans, lift) 10 | import Control.Monad.Trans.Free.Church (FT, iterT, iterTM, liftF) 11 | import Control.Applicative ((<$>)) 12 | import Network.HTTP.Client.Free.Types (HttpF(HttpF), ResponseType) 13 | import Test.QuickCheck (Arbitrary, arbitrary, sample') 14 | 15 | ------------------------------------------------------------------------------- 16 | -- | Peel a layer of the 'HttpF' functor and generate a random Response. 17 | iterTHttp :: ( r ~ ResponseType client 18 | , Arbitrary r 19 | , Monad m 20 | , MonadIO m 21 | ) 22 | => HttpF client (m a) 23 | -> m a 24 | iterTHttp (HttpF _ _ next) = head <$> liftIO (sample' arbitrary) >>= next 25 | 26 | ------------------------------------------------------------------------------- 27 | -- | Peel a layer of the 'HttpF' functor and generate a random Response. This 28 | -- time the base monad is 't m'. 29 | iterTMHttp :: ( r ~ ResponseType client 30 | , Arbitrary r 31 | , Monad m 32 | , MonadIO m 33 | , MonadTrans t 34 | , Monad (t m) 35 | ) 36 | => HttpF client (t m a) 37 | -> t m a 38 | iterTMHttp (HttpF _ _ next) = head <$> (lift . liftIO) (sample' arbitrary) >>= next 39 | 40 | ------------------------------------------------------------------------------- 41 | -- | The main http-client interpreter. The client is free to specify the base 42 | -- effect monad so long as there is an instance of 'MonadIO' for it in scope. 43 | runHttp :: ( r ~ ResponseType client 44 | , Arbitrary r 45 | , Monad m 46 | , MonadIO m 47 | ) 48 | => ignore 49 | -- ^ a paramter that will be ignored. It is included so client's can 50 | -- hot-swap interpreters. 51 | -> FT (HttpF client) m a 52 | -> m a 53 | runHttp = const (iterT iterTHttp) 54 | 55 | ------------------------------------------------------------------------------- 56 | -- | The main http-client interpreter. The client is free to specify the base 57 | -- effect monad ('m'), and in thise case this the result can be lifted into a 58 | -- higher monad transformer stack ('t') 59 | runTHttp :: ( r ~ ResponseType client 60 | , Arbitrary r 61 | , Monad m 62 | , MonadIO m 63 | , MonadTrans t 64 | , Monad (t m) 65 | ) 66 | => ignore 67 | -- ^ a paramter that will be ignored. It is included so client's can 68 | -- hot-swap interpreters. 69 | -> FT (HttpF client) m a 70 | -> t m a 71 | runTHttp = const (iterTM iterTMHttp) 72 | -------------------------------------------------------------------------------- /src/Network/HTTP/Client/Free/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Network.HTTP.Client.Free.Examples ( 5 | ) where 6 | 7 | import Control.Applicative ((<$>), (<*>)) 8 | import Data.ByteString (ByteString) 9 | import Data.ByteString.Char8 (pack) 10 | import Data.Maybe (fromJust) 11 | import Data.Time (UTCTime(UTCTime), fromGregorian) 12 | import Network.HTTP.Types.Header 13 | import Network.HTTP.Types.Status 14 | import Network.HTTP.Types.Method (StdMethod (..)) 15 | import Network.HTTP.Types.Version (http09, http10, http11, HttpVersion) 16 | import Network.HTTP.Client (defaultManagerSettings, newManager, parseUrl, responseStatus, Request) 17 | import Network.HTTP.Client.Free (get) 18 | import qualified Network.HTTP.Client.Free.ArbitraryClient as ArbitraryClient 19 | import Network.HTTP.Client.Free.HttpClient (HttpClient) 20 | import qualified Network.HTTP.Client.Free.HttpClient as HttpClient 21 | import Network.HTTP.Client.Free.Types (FreeHttp, RequestType, ResponseType) 22 | import Network.HTTP.Client.Internal (Cookie(Cookie), CookieJar, createCookieJar, Response(Response), ResponseClose(ResponseClose)) 23 | import Test.QuickCheck (choose, Gen, Arbitrary(arbitrary), elements, listOf, sample', suchThat) 24 | 25 | -- | an arbitrary 'Status' 26 | arbStatus :: Gen Status 27 | arbStatus = elements [ status100 28 | , status101 29 | , status200 30 | , status201 31 | , status203 32 | , status204 33 | , status205 34 | , status206 35 | , status300 36 | , status301 37 | , status302 38 | , status303 39 | , status304 40 | , status305 41 | , status307 42 | , status400 43 | , status401 44 | , status402 45 | , status403 46 | , status404 47 | , status405 48 | , status406 49 | , status407 50 | , status408 51 | , status409 52 | , status410 53 | , status411 54 | , status412 55 | , status413 56 | , status414 57 | , status415 58 | , status416 59 | , status417 60 | , status418 61 | , status428 62 | , status429 63 | , status431 64 | , status500 65 | , status501 66 | , status502 67 | , status503 68 | , status504 69 | , status505 70 | , status511 71 | ] 72 | 73 | -- | an arbitrary 'HttpVersion' 74 | arbHttpVersion :: Gen HttpVersion 75 | arbHttpVersion = elements [ http09 76 | , http10 77 | , http11 78 | ] 79 | 80 | -- | an arbitrary 'HeaderName' 81 | arbHeaderName :: Gen HeaderName 82 | arbHeaderName = elements [ hAccept 83 | , hAcceptLanguage 84 | , hAuthorization 85 | , hCacheControl 86 | , hConnection 87 | , hContentEncoding 88 | , hContentLength 89 | , hContentMD5 90 | , hContentType 91 | , hCookie 92 | , hDate 93 | , hIfModifiedSince 94 | , hIfRange 95 | , hLastModified 96 | , hLocation 97 | , hRange 98 | , hReferer 99 | , hServer 100 | , hUserAgent 101 | ] 102 | 103 | -- | an arbitrary Header. This is not performant, but you shouldn't 104 | -- be using this client in production anyway. 105 | arbHeader :: Gen Header 106 | arbHeader = (,) <$> arbHeaderName <*> fmap pack arbitrary 107 | 108 | -- | an arbitrary UTCTime 109 | arbUtcTime :: Gen UTCTime 110 | arbUtcTime = do 111 | rDay <- choose (1,29) :: Gen Int 112 | rMonth <- choose (1,12) :: Gen Int 113 | rYear <- choose (1970, 2015) :: Gen Integer 114 | rTime <- choose (0,86401) :: Gen Int 115 | return $ UTCTime (fromGregorian rYear rMonth rDay) (fromIntegral rTime) 116 | 117 | -- | an arbtirary Cookie 118 | arbCookie :: Gen Cookie 119 | arbCookie = do 120 | cCreationTime <- arbUtcTime 121 | cLastAccessTime <- suchThat arbUtcTime (cCreationTime >=) 122 | cExpiryTime <- suchThat arbUtcTime (cLastAccessTime >=) 123 | cName <- fmap pack arbitrary 124 | cValue <- fmap pack arbitrary 125 | cDomain <- fmap pack arbitrary 126 | cPath <- fmap pack arbitrary 127 | cPersistent <- arbitrary 128 | cHostOnly <- arbitrary 129 | cSecureOnly <- arbitrary 130 | cHttpOnly <- arbitrary 131 | return $ Cookie cName 132 | cValue 133 | cExpiryTime 134 | cDomain 135 | cPath 136 | cCreationTime 137 | cLastAccessTime 138 | cPersistent 139 | cHostOnly 140 | cSecureOnly 141 | cHttpOnly 142 | 143 | -- | unexported instance for arbitrary responses 144 | instance Arbitrary (Response ByteString) where 145 | arbitrary = Response <$> arbStatus 146 | <*> arbHttpVersion 147 | <*> listOf arbHeader 148 | <*> (pack <$> arbitrary) 149 | <*> (createCookieJar <$> listOf arbCookie) 150 | <*> return (ResponseClose (return ())) 151 | 152 | -- | A sample request 153 | weirdReq :: Request 154 | weirdReq = fromJust (parseUrl "http://weirdcanada.com/api") 155 | 156 | -- | A program that checks to see if the weird canada api is up. 157 | checkWeird :: ( Request ~ RequestType client 158 | , Response b ~ ResponseType client 159 | , Monad m 160 | ) 161 | => FreeHttp client m Bool 162 | checkWeird = do 163 | resp <- get weirdReq 164 | (return . (== status200) . responseStatus) resp 165 | 166 | data ExampleClient 167 | type instance RequestType ExampleClient = Request 168 | type instance ResponseType ExampleClient = Response ByteString 169 | 170 | main :: IO () 171 | main = do 172 | -- a result using the arbitrary interpreter 173 | arbResult <- ArbitraryClient.runHttp () (checkWeird :: FreeHttp ExampleClient IO Bool) 174 | putStrLn ("Arbitrary client returned: " ++ show arbResult) 175 | 176 | -- a result using the actual http client 177 | mgr <- newManager defaultManagerSettings 178 | realResult <- HttpClient.runHttp mgr (checkWeird :: FreeHttp HttpClient IO Bool) 179 | 180 | putStrLn ("http-client returned: " ++ show realResult) 181 | 182 | 183 | 184 | -------------------------------------------------------------------------------- /src/Network/HTTP/Client/Free/HttpClient.hs: -------------------------------------------------------------------------------- 1 | {-| An Interpreter with http-client as the foundation 2 | -} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE EmptyDataDecls #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module Network.HTTP.Client.Free.HttpClient ( 8 | HttpClient 9 | , runHttp 10 | , runTHttp 11 | ) where 12 | 13 | import Control.Monad.IO.Class (MonadIO, liftIO) 14 | import Control.Monad.Trans (MonadTrans, lift) 15 | import Control.Monad.Trans.Free.Church (FT, iterT, iterTM, liftF) 16 | import Data.ByteString.Lazy (ByteString) 17 | import Network.HTTP.Client (Manager, Request, Response, 18 | httpLbs) 19 | import Network.HTTP.Client.Free.Types (HttpF (HttpF), RequestType, 20 | ResponseType) 21 | import Network.HTTP.Client.Free.Util (setMethod) 22 | import Network.HTTP.Types.Method (renderStdMethod) 23 | 24 | ------------------------------------------------------------------------------- 25 | -- | 'HttpClient' is an uninhabited type used to identify the http-client 26 | -- based interpreter 27 | data HttpClient 28 | 29 | ------------------------------------------------------------------------------- 30 | -- | HttpClient expects 'Request's and returns 'Response ByteString's 31 | type instance RequestType HttpClient = Request 32 | type instance ResponseType HttpClient = Response ByteString 33 | 34 | ------------------------------------------------------------------------------- 35 | -- | Peel a layer of the 'HttpF' functor and run an http request with the data 36 | -- provided. 37 | iterTHttp :: ( Request ~ RequestType client 38 | -- The foundational request must be of type 'Request' 39 | , Response ByteString ~ ResponseType client 40 | -- The foundational response must be of type 'Response ByteString' 41 | , Monad m 42 | , MonadIO m 43 | ) 44 | => Manager 45 | -> HttpF client (m a) 46 | -> m a 47 | iterTHttp manager (HttpF m r next) = 48 | let !req = setMethod m r in liftIO (httpLbs req manager) >>= next 49 | 50 | ------------------------------------------------------------------------------- 51 | -- | Peel a layer of the 'HttpF' functor and run an http request with the data. 52 | -- the base monad for this action is 't m'. 53 | iterTMHttp :: ( Request ~ RequestType client 54 | -- The foundational request must be of type 'Request' 55 | , Response ByteString ~ ResponseType client 56 | -- The foundational response must be of type 'Response ByteString' 57 | , Monad m 58 | , MonadTrans t 59 | , Monad (t m) 60 | , MonadIO m 61 | ) 62 | => Manager 63 | -> HttpF client (t m a) 64 | -> t m a 65 | iterTMHttp manager (HttpF m r next) = 66 | let !req = setMethod m r in (lift . liftIO $ httpLbs req manager) >>= next 67 | 68 | ------------------------------------------------------------------------------- 69 | -- | The main http-client interpreter. The client is free to specify the base 70 | -- effect monad so long as there is an instance of 'MonadIO' for it in scope. 71 | runHttp :: ( Request ~ RequestType client 72 | -- The foundational request must be of type 'Request' 73 | , Response ByteString ~ ResponseType client 74 | -- The foundational response must be of type 'Response ByteString' 75 | , Monad m 76 | , MonadIO m 77 | ) 78 | => Manager 79 | -> FT (HttpF client) m a 80 | -> m a 81 | runHttp manager = iterT (iterTHttp manager) 82 | 83 | ------------------------------------------------------------------------------- 84 | -- | The main http-client interpreter. The client is free to specify the base 85 | -- effect monad ('m'), and in thise case this the result can be lifted into a 86 | -- higher monad transformer stack ('t') 87 | runTHttp :: ( Request ~ RequestType client 88 | -- The foundational request must be of type 'Request' 89 | , Response ByteString ~ ResponseType client 90 | -- The foundational response must be of type 'Response ByteString' 91 | , Monad m 92 | , MonadIO m 93 | , MonadTrans t 94 | , Monad (t m) 95 | ) 96 | => Manager 97 | -> FT (HttpF client) m a 98 | -> t m a 99 | runTHttp manager = iterTM (iterTMHttp manager) 100 | -------------------------------------------------------------------------------- /src/Network/HTTP/Client/Free/PureClient.hs: -------------------------------------------------------------------------------- 1 | {-| A pure interepreter 2 | -} 3 | 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module Network.HTTP.Client.Free.PureClient ( 8 | runHttp 9 | , runTHttp 10 | ) where 11 | 12 | import Control.Monad.Trans (MonadTrans) 13 | import Control.Monad.Trans.Free.Church (FT, iterT, iterTM, liftF) 14 | import Network.HTTP.Client (Manager, Request, Response, 15 | httpLbs) 16 | import Network.HTTP.Client.Free.Types (HttpF (HttpF), RequestType, 17 | ResponseType) 18 | 19 | ------------------------------------------------------------------------------- 20 | -- | Peel a layer of the 'HttpF' functor and, given the pure, mock function 21 | -- that maps requests to responses, run the next method against the returned 22 | -- request. 23 | iterTHttp :: (Monad m) 24 | => (RequestType client -> ResponseType client) 25 | -- ^ a function to mock requests 26 | -> HttpF client (m a) 27 | -> m a 28 | iterTHttp mock (HttpF _ req next) = next (mock req) 29 | 30 | ------------------------------------------------------------------------------- 31 | -- | Peel a layer of the 'HttpF' functor and, given the pure, mock function 32 | -- that maps requests to responses, run the next method against the returned 33 | -- request. the base monad for this action is `t m a` 34 | iterTMHttp :: (Monad m, MonadTrans t, Monad (t m)) 35 | => (RequestType client -> ResponseType client) 36 | -> HttpF client (t m a) 37 | -> t m a 38 | iterTMHttp mock (HttpF _ req next) = next (mock req) 39 | 40 | ------------------------------------------------------------------------------- 41 | -- | A pure interpreter based on a client-supplied mocking function 42 | runHttp :: Monad m 43 | => (RequestType client -> ResponseType client) 44 | -> ignore 45 | -- ^ a parameter that will be ignored. It is included so client's can 46 | -- hot-swap interpreters (many will require a `Manager` type) 47 | -> FT (HttpF client) m a 48 | -> m a 49 | runHttp mock _ = iterT (iterTHttp mock) 50 | 51 | ------------------------------------------------------------------------------- 52 | -- | A pure interpreter based on a client-supplied mocking function. The under- 53 | -- lying monad is `t m`, so computations will be lifted into `t m`. 54 | runTHttp :: (Monad m, MonadTrans t, Monad (t m)) 55 | => (RequestType client -> ResponseType client) 56 | -> ignore 57 | -- ^ a paramter that will be ignored. It is included so client's can 58 | -- host-swap interpreters (many will require a 'Manager' type) 59 | -> FT (HttpF client) m a 60 | -> t m a 61 | runTHttp mock _ = iterTM (iterTMHttp mock) 62 | -------------------------------------------------------------------------------- /src/Network/HTTP/Client/Free/Types.hs: -------------------------------------------------------------------------------- 1 | {-| The primary Free Monad wrapping HTTP actions. 2 | -} 3 | 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module Network.HTTP.Client.Free.Types ( 8 | -- * Type Familes 9 | RequestType 10 | , ResponseType 11 | 12 | -- * The base functor of our library 13 | , HttpF(HttpF) 14 | 15 | -- * Type aliases 16 | , FreeHttp 17 | ) where 18 | 19 | import Control.Monad.Trans.Free.Church (FT) 20 | import Network.HTTP.Types.Method (StdMethod) 21 | 22 | -- | type family to represent the request type foundation 23 | type family RequestType client :: * 24 | 25 | -- | type family to represent the response type foundation 26 | type family ResponseType client :: * 27 | 28 | -- | Our functor from which the free-http free monad is generated from. 29 | data HttpF client a = HttpF StdMethod (RequestType client) (ResponseType client -> a) 30 | deriving Functor 31 | 32 | -- | a type alias for the free monad generated by 'HttpF' 33 | type FreeHttp client m a = FT (HttpF client) m a 34 | -------------------------------------------------------------------------------- /src/Network/HTTP/Client/Free/Util.hs: -------------------------------------------------------------------------------- 1 | {-| Utilities for working with networking types 2 | -} 3 | 4 | {-# LANGUAGE BangPatterns #-} 5 | 6 | module Network.HTTP.Client.Free.Util ( 7 | setMethod 8 | ) where 9 | 10 | import Network.HTTP.Client (Request (method)) 11 | import Network.HTTP.Types.Method (StdMethod, renderStdMethod) 12 | 13 | -- | set the method of a request, overriding the previous method. 14 | setMethod :: StdMethod -> Request -> Request 15 | setMethod m req = let !nMethod = renderStdMethod m in req { method = nMethod } 16 | --------------------------------------------------------------------------------