diff --git a/http-dispatch.cabal b/http-dispatch.cabal --- a/http-dispatch.cabal +++ b/http-dispatch.cabal @@ -1,5 +1,5 @@ name: http-dispatch -version: 0.4.0.0 +version: 0.5.0.0 synopsis: High level HTTP client for Haskell description: Please see README.md homepage: http://github.com/owainlewis/http-dispatch#readme @@ -16,13 +16,13 @@ hs-source-dirs: src exposed-modules: Network.HTTP.Dispatch.Core , Network.HTTP.Dispatch.Types - , Network.HTTP.Dispatch.Request - , Network.HTTP.Dispatch.Extra - build-depends: base >= 4.7 && < 5 + , Network.HTTP.Dispatch.Internal.Request + build-depends: base >= 4.5 && < 5 , http-client , http-client-tls , http-types , bytestring + , base64-bytestring , case-insensitive default-language: Haskell2010 diff --git a/src/Network/HTTP/Dispatch/Core.hs b/src/Network/HTTP/Dispatch/Core.hs --- a/src/Network/HTTP/Dispatch/Core.hs +++ b/src/Network/HTTP/Dispatch/Core.hs @@ -3,6 +3,7 @@ ( HTTPRequest(..) , HTTPResponse(..) , HTTPRequestMethod(..) + -- Core request helpers , runRequest , get , getWithHeaders @@ -14,29 +15,42 @@ , patchWithHeaders , delete , deleteWithHeaders + -- Extra + , withQueryParams ) where -import qualified Data.ByteString.Lazy as LBS -import Network.HTTP.Dispatch.Request +import qualified Data.ByteString as S +import Data.Monoid (mconcat) +import Network.HTTP.Dispatch.Internal.Request import Network.HTTP.Dispatch.Types ------------------------------------------------------------------------------------ --- Request API ------------------------------------------------------------------------------------ - -type Url = String -type Headers = [Header] -type Body = LBS.ByteString +import Data.List (intersperse) +-- | Make a simple HTTP GET request +-- +-- @ +-- get "http://google.com" => +-- HTTPRequest {reqMethod = GET, reqUrl = "http://google.com", reqHeaders = [], reqBody = Nothing} +-- @ get :: Url -> HTTPRequest get url = HTTPRequest GET url [] Nothing +-- | Make a simple HTTP GET request with headers +-- +-- @ +-- getWithHeaders "http://google.com" [header "Content-Type" "application/json"] +-- HTTPRequest {reqMethod = GET, reqUrl = "http://google.com", reqHeaders = [("Content-Type","application/json")], reqBody = Nothing} +-- @ getWithHeaders :: String -> [Header] -> HTTPRequest getWithHeaders url headers = HTTPRequest GET url headers Nothing +-- | Make a simple HTTP POST request +-- post :: Url -> Body -> HTTPRequest post url body = postWithHeaders url [] body +-- | Make a HTTP POST request with headers +-- postWithHeaders :: Url -> Headers -> Body -> HTTPRequest postWithHeaders url headers body = HTTPRequest POST url headers (Just body) @@ -57,3 +71,17 @@ deleteWithHeaders :: Url -> Headers -> HTTPRequest deleteWithHeaders url headers = HTTPRequest DELETE url headers Nothing + +-- | Add query params to a request URL +-- +-- @ +-- withQueryParams (get "http://google.com") [("foo", "bar")] => +-- HTTPRequest {reqMethod = GET, reqUrl = "http://google.com?foo=bar", reqHeaders = [], reqBody = Nothing} +-- @ +withQueryParams :: HTTPRequest -> [(String, String)] -> HTTPRequest +withQueryParams req params = req { reqUrl = u ++ p } + where u = reqUrl req + p = compileParams params + compileParams params = "?" ++ kweryParams :: String + where parts = map (\(k,v) -> mconcat [k, "=", v]) params + kweryParams = mconcat (intersperse "&" parts) diff --git a/src/Network/HTTP/Dispatch/Extra.hs b/src/Network/HTTP/Dispatch/Extra.hs deleted file mode 100644 --- a/src/Network/HTTP/Dispatch/Extra.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module Network.HTTP.Dispatch.Extra - ( fromString - ) where - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBSC - ------------------------------------------------------------------------------------ --- Extra methods for friendly API (experimental) ------------------------------------------------------------------------------------ - --- Can be used to generate a HTTP request without needing to prepare Lazy ByteStrings. --- --- Example: --- HTTPRequest POST "http://api.mysite.com" [("Content-Type", "application/json")] (fromString "HELLO WORLD") -fromString :: String -> LBS.ByteString -fromString = LBSC.pack diff --git a/src/Network/HTTP/Dispatch/Internal/Request.hs b/src/Network/HTTP/Dispatch/Internal/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Dispatch/Internal/Request.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.HTTP.Dispatch.Internal.Request + ( toRequest + , runRequest + ) where + +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import Data.List (isPrefixOf) +import Network.HTTP.Client as Client +import Network.HTTP.Client.TLS +import Network.HTTP.Dispatch.Types (HTTPRequest (..), + HTTPRequestMethod (..), + HTTPResponse (..), Header (..)) +import Network.HTTP.Types (RequestHeaders, Status (..)) + +-- | Transforms a dispatch request into a low level http-client request +-- +toRequest :: HTTPRequest -> IO Client.Request +toRequest (HTTPRequest method url headers body) = do + initReq <- parseUrl url + let hdrs = map (\(k, v) -> (CI.mk k, v)) headers + req = initReq + { method = C.pack . show $ method + , requestHeaders = hdrs + -- Make sure no exceptions are thrown so that we can handle non 200 codes + , checkStatus = \_ _ _ -> Nothing + } + case body of + Just lbs -> + return $ req { requestBody = RequestBodyBS lbs } + Nothing -> + return req + +-- | Get the correct Manager depending on the URL (i.e https vs http) +-- +getManagerForUrl :: String -> IO Manager +getManagerForUrl url = + if ("https" `isPrefixOf` url) then newManager tlsManagerSettings + else newManager defaultManagerSettings + +-- | Transforms an http-client respones into a Dispatch Response +-- +toResponse :: Client.Response LBS.ByteString -> HTTPResponse +toResponse resp = + let rStatus = statusCode . responseStatus $ resp + rHdrs = responseHeaders resp + rBody = responseBody resp + in + HTTPResponse rStatus (map (\(k,v) -> + let hk = CI.original k + in + (hk, v)) rHdrs) rBody + +class Runnable a where + -- Run a HTTP request and return the response + runRequest :: a -> IO HTTPResponse + -- Run a HTTP request with custom settings (proxy, https etc) and return the response + runRequestWithSettings :: a -> ManagerSettings -> IO HTTPResponse + +instance Runnable HTTPRequest where + runRequest httpRequest = do + manager <- getManagerForUrl (reqUrl httpRequest) + request <- toRequest httpRequest + toResponse <$> httpLbs request manager + + runRequestWithSettings httpRequest settings = do + manager <- newManager settings + request <- toRequest httpRequest + httpLbs request manager >>= return . toResponse diff --git a/src/Network/HTTP/Dispatch/Request.hs b/src/Network/HTTP/Dispatch/Request.hs deleted file mode 100644 --- a/src/Network/HTTP/Dispatch/Request.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.HTTP.Dispatch.Request - ( toRequest - , runRequest - , compileParams - , withQueryParams - ) where - -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as LBS -import qualified Data.CaseInsensitive as CI -import Data.List (isPrefixOf) -import Data.List (intersperse) -import Data.String (fromString) -import Network.HTTP.Client as Client -import Network.HTTP.Client.TLS -import Network.HTTP.Dispatch.Types (HTTPRequest (..), - HTTPRequestMethod (..), - HTTPResponse (..), Header (..)) -import Network.HTTP.Types (RequestHeaders, Status (..)) - --- Transforms a dispatch request into a low level http-client request --- -toRequest :: HTTPRequest -> IO Client.Request -toRequest (HTTPRequest method url headers body) = do - initReq <- parseUrl url - let hdrs = map (\(k, v) -> (fromString k, fromString v)) headers - req = initReq - { method = C.pack . show $ method - , requestHeaders = hdrs - -- Make sure no exceptions are thrown so that we can handle non 200 codes - , checkStatus = \_ _ _ -> Nothing - } - case body of - Just lbs -> - return $ req { requestBody = RequestBodyLBS lbs } - Nothing -> - return req - -getManagerForUrl :: String -> IO Manager -getManagerForUrl url = - if ("https" `isPrefixOf` url) then newManager tlsManagerSettings - else newManager defaultManagerSettings - -toResponse :: Client.Response LBS.ByteString -> HTTPResponse -toResponse resp = - let rStatus = statusCode . responseStatus $ resp - rHdrs = responseHeaders resp - rBody = responseBody resp - in - HTTPResponse rStatus (map (\(k,v) -> - let hk = C.unpack . CI.original $ k - hv = C.unpack v in - (hk, hv)) rHdrs) rBody - -compileParams :: [(String, String)] -> String -compileParams params = "?" ++ kweryParams - where parts = map (\(k,v) -> mconcat [k, "=", v]) params - kweryParams = mconcat $ Data.List.intersperse "&" parts - -withQueryParams :: HTTPRequest -> [(String, String)] -> HTTPRequest -withQueryParams req params = req { reqUrl = - let x = reqUrl req - y = compileParams params - in x ++ y - } - -class Runnable a where - -- Run a HTTP request and return the response - runRequest :: a -> IO HTTPResponse - -- Run a HTTP request with custom settings (proxy, https etc) and return the response - runRequestWithSettings :: a -> ManagerSettings -> IO HTTPResponse - -instance Runnable HTTPRequest where - runRequest httpRequest = do - manager <- getManagerForUrl (reqUrl httpRequest) - request <- toRequest httpRequest - httpLbs request manager >>= return . toResponse - - runRequestWithSettings httpRequest settings = do - manager <- newManager settings - request <- toRequest httpRequest - httpLbs request manager >>= return . toResponse diff --git a/src/Network/HTTP/Dispatch/Types.hs b/src/Network/HTTP/Dispatch/Types.hs --- a/src/Network/HTTP/Dispatch/Types.hs +++ b/src/Network/HTTP/Dispatch/Types.hs @@ -1,10 +1,18 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} module Network.HTTP.Dispatch.Types where -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBSC +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as SC +import qualified Data.ByteString.Lazy as LBS +type Url = String + +type Headers = [Header] + +type Body = S.ByteString + data HTTPRequestMethod = GET | PUT @@ -12,13 +20,7 @@ | PATCH | DELETE deriving ( Eq, Show ) -type Header = (String, String) - -class Packable a where - pack :: a -> LBS.ByteString - -instance Packable String where - pack = LBSC.pack +type Header = (S.ByteString, S.ByteString) data HTTPRequest = HTTPRequest { -- A HTTP request method e.g GET POST etc @@ -28,7 +30,7 @@ -- Optional HTTP headers , reqHeaders :: [Header] -- An optional request body - , reqBody :: Maybe LBS.ByteString + , reqBody :: Maybe S.ByteString } deriving ( Eq, Show ) data HTTPResponse = HTTPResponse { @@ -40,8 +42,9 @@ , respBody :: LBS.ByteString } deriving ( Eq, Show ) --- Update requests (additive) ---------------------------------------------------------------------------------------------- +-- | Helper function that contstructs HTTP headers from string values +header :: String -> String -> Header +header k v = (SC.pack k , SC.pack v) withHeader :: HTTPRequest -> Header -> HTTPRequest withHeader req header = req { reqHeaders = header : (reqHeaders req) } @@ -49,15 +52,13 @@ withHeaders :: HTTPRequest -> [Header] -> HTTPRequest withHeaders req headers = req { reqHeaders = headers } -withBody :: HTTPRequest -> LBS.ByteString -> HTTPRequest -withBody req body = req { reqBody = pure body } +withBody :: HTTPRequest -> S.ByteString -> HTTPRequest +withBody req body = req { reqBody = Just body } withMethod :: HTTPRequest -> HTTPRequestMethod -> HTTPRequest withMethod req method = req { reqMethod = method } ---------------------------------------------------------------------------------------------- - -dropHeaderWithKey :: HTTPRequest -> String -> HTTPRequest +dropHeaderWithKey :: HTTPRequest -> S.ByteString -> HTTPRequest dropHeaderWithKey req@(HTTPRequest _ _ hdrs _) headerKey = let filteredHeaders = filter (\(k,v) -> k /= headerKey) hdrs in withHeaders req filteredHeaders