diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,29 @@ +Copyright © 2014, Bryan O'Sullivan. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* 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. + +* Neither the name of nor the names of other contributors may be used + to endorse or promote products derived from this software without + specific prior written permission. + +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 +OWNER 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. diff --git a/Network/Wreq.hs b/Network/Wreq.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} + +-- | +-- Module : Network.Wreq +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- A library for client-side HTTP requests, focused on ease of use. +-- +-- When reading the examples in this module, you should assume the +-- following environment: +-- +-- @ +-- \-\- Make it easy to write literal 'S.ByteString' and 'Text' values. +-- \{\-\# LANGUAGE OverloadedStrings \#\-\} +-- +-- \-\- Our handy module. +-- import "Network.Wreq" +-- +-- \-\- Operators such as ('&') and ('.~'). +-- import "Control.Lens" +-- +-- \-\- Conversion of Haskell values to JSON. +-- import "Data.Aeson" ('Data.Aeson.toJSON') +-- +-- \-\- Easy traversal of JSON data. +-- import "Data.Aeson.Lens" ('Data.Aeson.Lens.key', 'Data.Aeson.Lens.nth') +-- @ +-- +-- There exist some less frequently used lenses that are not exported +-- from this module; these can be found in "Network.Wreq.Lens". + +module Network.Wreq + ( + -- * HTTP verbs + -- ** GET + get + , getWith + -- ** POST + -- $postable + , post + , postWith + -- ** HEAD + , head_ + , headWith + -- ** OPTIONS + , options + , optionsWith + -- ** PUT + , put + , putWith + -- ** DELETE + , delete + , deleteWith + -- * Incremental consumption of responses + -- ** GET + , foldGet + , foldGetWith + + -- * Configuration + , Options + , defaults + , Lens.manager + , Lens.header + , Lens.param + , Lens.redirects + , Lens.headers + , Lens.params + , Lens.cookie + , Lens.cookies + -- ** Authentication + -- $auth + , Auth + , Lens.auth + , basicAuth + , oauth2Bearer + , oauth2Token + -- ** Proxy settings + , Proxy(Proxy) + , Lens.proxy + , httpProxy + -- ** Using a manager with defaults + , withManager + + -- * Payloads for POST and PUT + , Payload(..) + -- ** URL-encoded form data + , FormParam(..) + , FormValue + -- ** Multipart form data + , Form.Part + , Lens.partName + , Lens.partFileName + , Lens.partContentType + , Lens.partGetBody + -- *** Smart constructors + , Form.partBS + , Form.partLBS + , partText + , partString + , Form.partFile + , Form.partFileSource + + -- * Responses + , Response + , Lens.responseBody + , Lens.responseHeader + , Lens.responseLink + , Lens.responseCookie + , Lens.responseHeaders + , Lens.responseCookieJar + , Lens.responseStatus + , Lens.Status + , Lens.statusCode + -- ** Link headers + , Lens.Link + , Lens.linkURL + , Lens.linkParams + -- ** Decoding responses + , JSONError(..) + , asJSON + , asValue + + -- * Cookies + -- $cookielenses + , Lens.Cookie + , Lens.cookieName + , Lens.cookieValue + , Lens.cookieExpiryTime + , Lens.cookieDomain + , Lens.cookiePath + + -- * Parsing responses + , Lens.atto + ) where + +import Control.Lens ((.~), (&)) +import Control.Monad (unless) +import Control.Monad.Catch (MonadThrow(throwM)) +import Data.Aeson (FromJSON) +import Data.ByteString.Char8 () +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Client.Internal (Proxy(..), Response) +import Network.Wreq.Internal +import Network.Wreq.Types (Options) +import Network.Wreq.Types hiding (Options(..)) +import Prelude hiding (head) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.MultipartFormData as Form +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wreq.Internal.Lens as Int +import qualified Network.Wreq.Lens as Lens +import qualified Network.Wreq.Types as Wreq + +-- | Issue a GET request. +-- +-- Example: +-- +-- @ +--'get' \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- >>> r <- get "http://httpbin.org/get" +-- >>> r ^. responseStatus . statusCode +-- 200 +get :: String -> IO (Response L.ByteString) +get url = getWith defaults url + +withManager :: (Options -> IO a) -> IO a +withManager act = HTTP.withManager defaultManagerSettings $ \mgr -> + act defaults { Wreq.manager = Right mgr } + +-- | Issue a GET request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"] +--'getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- >>> let opts = defaults & param "foo" .~ ["bar"] +-- >>> r <- getWith opts "http://httpbin.org/get" +-- >>> r ^? responseBody . key "url" +-- Just (String "http://httpbin.org/get?foo=bar") +getWith :: Options -> String -> IO (Response L.ByteString) +getWith opts url = request id opts url readResponse + +-- | Issue a POST request. +-- +-- Example: +-- +-- @ +--'post' \"http:\/\/httpbin.org\/post\" ('Aeson.toJSON' [1,2,3]) +-- @ +-- +-- >>> r <- post "http://httpbin.org/post" (toJSON [1,2,3]) +-- >>> r ^? responseBody . key "json" +-- Just (Array (fromList [Number 1.0,Number 2.0,Number 3.0])) +post :: Postable a => String -> a -> IO (Response L.ByteString) +post url payload = postWith defaults url payload + +-- | Issue a POST request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"] +--'postWith' opts \"http:\/\/httpbin.org\/post\" ('Aeson.toJSON' [1,2,3]) +-- @ +-- +-- >>> let opts = defaults & param "foo" .~ ["bar"] +-- >>> r <- postWith opts "http://httpbin.org/post" (toJSON [1,2,3]) +-- >>> r ^? responseBody . key "url" +-- Just (String "http://httpbin.org/post?foo=bar") +postWith :: Postable a => Options -> String -> a -> IO (Response L.ByteString) +postWith opts url payload = + requestIO (postPayload payload . (Int.method .~ HTTP.methodPost)) opts url + readResponse + +-- | Issue a HEAD request. +-- +-- Example: +-- +-- @ +--'head_' \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- >>> r <- head_ "http://httpbin.org/get" +-- >>> r ^? responseHeader "Content-Type" +-- Just "application/json" +head_ :: String -> IO (Response ()) +head_ = headWith (defaults & Lens.redirects .~ 0) + +-- | Issue a HEAD request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"] +--'headWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- >>> let opts = defaults & param "foo" .~ ["bar"] +-- >>> r <- headWith opts "http://httpbin.org/get" +-- >>> r ^? responseHeader "Connection" +-- Just "keep-alive" +headWith :: Options -> String -> IO (Response ()) +headWith = emptyMethodWith HTTP.methodHead + +-- | Issue a PUT request. +put :: Putable a => String -> a -> IO (Response L.ByteString) +put url payload = putWith defaults url payload + +-- | Issue a PUT request, using the supplied 'Options'. +putWith :: Putable a => Options -> String -> a -> IO (Response L.ByteString) +putWith opts url payload = + requestIO (putPayload payload . (Int.method .~ HTTP.methodPut)) opts url + readResponse + +-- | Issue an OPTIONS request. +-- +-- Example: +-- +-- @ +--'options' \"http:\/\/httpbin.org\/get\" +-- @ +-- +-- See 'Lens.atto' for a more complex worked example. +options :: String -> IO (Response ()) +options = optionsWith defaults + +-- | Issue an OPTIONS request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.param' \"foo\" '.~' [\"bar\"] +--'optionsWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +optionsWith :: Options -> String -> IO (Response ()) +optionsWith = emptyMethodWith HTTP.methodOptions + +-- | Issue a DELETE request. +-- +-- Example: +-- +-- @ +--'delete' \"http:\/\/httpbin.org\/delete\" +-- @ +-- +-- >>> r <- delete "http://httpbin.org/delete" +-- >>> r ^. responseStatus . statusCode +-- 200 +delete :: String -> IO (Response ()) +delete = deleteWith defaults + +-- | Issue a DELETE request, using the supplied 'Options'. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.redirects' '.~' 0 +--'deleteWith' opts \"http:\/\/httpbin.org\/delete\" +-- @ +-- +-- >>> let opts = defaults & redirects .~ 0 +-- >>> r <- deleteWith opts "http://httpbin.org/delete" +-- >>> r ^. responseStatus . statusCode +-- 200 +deleteWith :: Options -> String -> IO (Response ()) +deleteWith = emptyMethodWith HTTP.methodDelete + +foldGet :: (a -> S.ByteString -> IO a) -> a -> String -> IO a +foldGet f z url = foldGetWith defaults f z url + +foldGetWith :: Options -> (a -> S.ByteString -> IO a) -> a -> String -> IO a +foldGetWith opts f z0 url = request id opts url (foldResponseBody f z0) + +-- | Convert the body of an HTTP response from JSON to a suitable +-- Haskell type. +-- +-- In this example, we use 'asJSON' in the @IO@ monad, where it will +-- throw a 'JSONError' exception if conversion to the desired type +-- fails. +-- +-- @ +-- \{-\# LANGUAGE DeriveGeneric \#-\} +--import "GHC.Generics" ('GHC.Generics.Generic') +-- +-- \{- This Haskell type corresponds to the structure of a +-- response body from httpbin.org. -\} +-- +--data GetBody = GetBody { +-- headers :: 'Data.Map.Map' 'Data.Text.Text' 'Data.Text.Text' +-- , args :: 'Data.Map.Map' 'Data.Text.Text' 'Data.Text.Text' +-- , origin :: 'Data.Text.Text' +-- , url :: 'Data.Text.Text' +-- } deriving (Show, 'GHC.Generics.Generic') +-- +-- \-\- Get GHC to derive a 'FromJSON' instance for us. +--instance 'FromJSON' GetBody +-- +-- \{- The fact that we want a GetBody below will be inferred by our +-- use of the \"headers\" accessor function. -\} +-- +--foo = do +-- r <- 'asJSON' =<< 'get' \"http:\/\/httpbin.org\/get\" +-- print (headers (r 'Control.Lens.^.' 'responseBody')) +-- @ +-- +-- If we use 'asJSON' in the 'Either' monad, it will return 'Left' +-- with a 'JSONError' payload if conversion fails, and 'Right' with a +-- 'Response' whose 'responseBody' is the converted value on success. + +asJSON :: (MonadThrow m, FromJSON a) => + Response L.ByteString -> m (Response a) +{-# SPECIALIZE asJSON :: (FromJSON a) => + Response L.ByteString -> IO (Response a) #-} +{-# SPECIALIZE asJSON :: Response L.ByteString -> IO (Response Aeson.Value) #-} +asJSON resp = do + let contentType = fst . S.break (==59) . fromMaybe "unknown" . + lookup "Content-Type" . HTTP.responseHeaders $ resp + unless ("application/json" `S.isPrefixOf` contentType) $ + throwM . JSONError $ "content type of response is " ++ show contentType + case Aeson.eitherDecode' (HTTP.responseBody resp) of + Left err -> throwM (JSONError err) + Right val -> return (fmap (const val) resp) + + +-- | Convert the body of an HTTP response from JSON to a 'Value'. +-- +-- In this example, we use 'asValue' in the @IO@ monad, where it will +-- throw a 'JSONError' exception if the conversion to 'Value' fails. +-- +-- @ +--foo = do +-- r <- 'asValue' =<< 'get' \"http:\/\/httpbin.org\/get\" +-- print (r 'Control.Lens.^?' 'responseBody' . key \"headers\" . key \"User-Agent\") +-- @ +asValue :: (MonadThrow m) => Response L.ByteString -> m (Response Aeson.Value) +{-# SPECIALIZE asValue :: Response L.ByteString + -> IO (Response Aeson.Value) #-} +asValue = asJSON + +-- $auth +-- +-- Do not use HTTP authentication unless you are using TLS encryption. +-- These authentication tokens can easily be captured and reused by an +-- attacker if transmitted in the clear. + +-- | Basic authentication. This consists of a plain username and +-- password. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'defaults' '&' 'Lens.auth' '.~' 'basicAuth' \"user\" \"pass\" +--'getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\" +-- @ +-- +-- >>> let opts = defaults & auth .~ basicAuth "user" "pass" +-- >>> r <- getWith opts "https://httpbin.org/basic-auth/user/pass" +-- >>> r ^? responseBody . key "authenticated" +-- Just (Bool True) +basicAuth :: S.ByteString -- ^ Username. + -> S.ByteString -- ^ Password. + -> Maybe Auth +basicAuth user pass = Just (BasicAuth user pass) + +-- | An OAuth2 bearer token. This is treated by many services as the +-- equivalent of a username and password. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'defaults' '&' 'Lens.auth' '.~' 'oauth2Bearer' \"1234abcd\" +--'getWith' opts \"https:\/\/public-api.wordpress.com\/rest\/v1\/me\/\" +-- @ +oauth2Bearer :: S.ByteString -> Maybe Auth +oauth2Bearer token = Just (OAuth2Bearer token) + +-- | A not-quite-standard OAuth2 bearer token (that seems to be used +-- only by GitHub). This will be treated by whatever services accept +-- it as the equivalent of a username and password. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'defaults' '&' 'Lens.auth' '.~' 'oauth2Token' \"abcd1234\" +--'getWith' opts \"https:\/\/api.github.com\/user\" +-- @ +oauth2Token :: S.ByteString -> Maybe Auth +oauth2Token token = Just (OAuth2Token token) + +-- | Proxy configuration. +-- +-- Example: +-- +-- @ +--let opts = 'defaults' '&' 'Lens.proxy' '.~' 'httpProxy' \"localhost\" 8000 +--'getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +httpProxy :: S.ByteString -> Int -> Maybe Proxy +httpProxy host port = Just (Proxy host port) + +-- | Make a 'Part' whose content is a strict 'T.Text', encoded as +-- UTF-8. +-- +-- The 'Part' does not have a file name or content type associated +-- with it. +partText :: Text -- ^ Name of the corresponding \. + -> Text -- ^ The body for this 'Form.Part'. + -> Form.Part +partText name value = Form.partBS name (encodeUtf8 value) + +-- | Make a 'Part' whose content is a 'String', encoded as UTF-8. +-- +-- The 'Part' does not have a file name or content type associated +-- with it. +partString :: Text -- ^ Name of the corresponding \. + -> String -- ^ The body for this 'Form.Part'. + -> Form.Part +partString name value = Form.partBS name (encodeUtf8 (T.pack value)) + +-- $cookielenses +-- +-- These are only the most frequently-used cookie-related lenses. See +-- "Network.Wreq.Lens" for the full accounting of them all. + +-- $postable +-- +-- The 'Postable' class determines which Haskell types can be used as +-- POST payloads. +-- +-- 'Form.Part' and ['Form.Part'] give a request body with a +-- @Content-Type@ of @multipart/form-data@. Constructor functions +-- include 'partText' and 'Form.partFile'. +-- +-- >>> r <- post "http://httpbin.org/post" (partText "hello" "world") +-- >>> r ^? responseBody . key "form" . key "hello" +-- Just (String "world") +-- +-- ('S.ByteString', 'S.ByteString') and 'FormParam' (and lists of +-- each) give a request body with a @Content-Type@ of +-- @application/x-www-form-urlencoded@. The easiest way to use this is +-- via the (':=') constructor. +-- +-- >>> r <- post "http://httpbin.org/post" ["num" := 31337, "str" := "foo"] +-- >>> r ^? responseBody . key "form" . key "num" +-- Just (String "31337") +-- +-- The \"magical\" type conversion on the right-hand side of ':=' +-- above is due to the 'FormValue' class. This package provides +-- sensible instances for the standard string and number types. +-- +-- The 'Aeson.Value' type gives a JSON request body with a +-- @Content-Type@ of @application/json@. Any instance of +-- 'Aeson.ToJSON' can of course be converted to a 'Aeson.Value' using +-- 'Aeson.toJSON'. +-- +-- >>> r <- post "http://httpbin.org/post" (toJSON [1,2,3]) +-- >>> r ^? responseBody . key "json" . nth 0 +-- Just (Number 1.0) + +-- $setup +-- +-- >>> :set -XOverloadedStrings +-- >>> import Control.Lens +-- >>> import Data.Aeson (toJSON) +-- >>> import Data.Aeson.Lens (key, nth) +-- >>> import Network.Wreq diff --git a/Network/Wreq/Internal.hs b/Network/Wreq/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE CPP, GADTs, OverloadedStrings #-} + +module Network.Wreq.Internal + ( + defaults + , defaultManagerSettings + , emptyMethodWith + , foldResponseBody + , ignoreResponse + , readResponse + , request + , requestIO + ) where + +import Control.Applicative ((<$>)) +import Control.Arrow ((***)) +import Control.Lens ((&), (.~), (%~)) +import Data.Monoid ((<>)) +import Data.Text.Encoding (encodeUtf8) +import Data.Version (showVersion) +import Network.HTTP.Client (BodyReader) +import Network.HTTP.Client.Internal (Proxy(..), Request, Response(..), addProxy) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.Wreq.Internal.Lens (setHeader) +import Network.Wreq.Types (Auth(..), Options(..)) +import Prelude hiding (head) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wreq.Internal.Lens as Lens +import qualified Network.Wreq.Lens as Lens + +-- This mess allows this module to continue to load during interactive +-- development in ghci :-( +#if defined(VERSION_base) +import Paths_wreq (version) +#else +import Data.Version (Version(..)) +version = Version [0] ["wip"] +#endif + +defaultManagerSettings :: HTTP.ManagerSettings +defaultManagerSettings = tlsManagerSettings + +defaults :: Options +defaults = Options { + manager = Left defaultManagerSettings + , proxy = Nothing + , auth = Nothing + , headers = [("User-Agent", userAgent)] + , params = [] + , redirects = 10 + , cookies = HTTP.createCookieJar [] + } + where userAgent = "haskell wreq-" <> Char8.pack (showVersion version) + +setRedirects :: Options -> Request -> Request +setRedirects opts req + | redirects opts == HTTP.redirectCount req = req + | otherwise = req { HTTP.redirectCount = redirects opts } + +emptyMethodWith :: HTTP.Method -> Options -> String -> IO (Response ()) +emptyMethodWith method opts url = + request (Lens.method .~ method) opts url ignoreResponse + +ignoreResponse :: Response BodyReader -> IO (Response ()) +ignoreResponse resp = (Lens.responseBody .~ ()) <$> readResponse resp + +readResponse :: Response BodyReader -> IO (Response L.ByteString) +readResponse resp = do + chunks <- HTTP.brConsume (HTTP.responseBody resp) + return resp { responseBody = L.fromChunks chunks } + +foldResponseBody :: (a -> S.ByteString -> IO a) -> a + -> Response BodyReader -> IO a +foldResponseBody f z0 resp = go z0 + where go z = do + bs <- HTTP.brRead (HTTP.responseBody resp) + if S.null bs + then return z + else f z bs >>= go + +requestIO :: (Request -> IO Request) -> Options -> String + -> (Response BodyReader -> IO a) -> IO a +requestIO modify opts url body = + either (flip HTTP.withManager go) go (manager opts) + where + go mgr = do + let frob req = req + & Lens.requestHeaders %~ (headers opts ++) + & setQuery opts + & setAuth opts + & setProxy opts + & setRedirects opts + & Lens.cookieJar .~ Just (cookies opts) + req <- modify =<< (frob <$> HTTP.parseUrl url) + HTTP.withResponse req mgr body + +request :: (Request -> Request) -> Options -> String + -> (Response BodyReader -> IO a) -> IO a +request f = requestIO (return . f) + +setQuery :: Options -> Request -> Request +setQuery opts = + case params opts of + [] -> id + ps -> Lens.queryString %~ \qs -> + let n = S.length qs in + qs <> (if n > 1 then "&" else "") <> HTTP.renderSimpleQuery (n==0) + (map (encodeUtf8 *** encodeUtf8) ps) + +setAuth :: Options -> Request -> Request +setAuth = maybe id f . auth + where + f (BasicAuth user pass) = HTTP.applyBasicAuth user pass + f (OAuth2Bearer token) = setHeader "Authorization" ("Bearer " <> token) + f (OAuth2Token token) = setHeader "Authorization" ("token " <> token) + +setProxy :: Options -> Request -> Request +setProxy = maybe id f . proxy + where f (Proxy host port) = addProxy host port diff --git a/Network/Wreq/Internal/Lens.hs b/Network/Wreq/Internal/Lens.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/Lens.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE RankNTypes, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Network.Wreq.Internal.Lens + ( + HTTP.Request + , method + , secure + , host + , port + , path + , queryString + , requestHeaders + , requestBody + , proxy + , hostAddress + , rawBody + , decompress + , redirectCount + , responseTimeout + , checkStatus + , getConnectionWrapper + , cookieJar + -- * Useful functions + , assoc + , assoc2 + , setHeader + ) where + +import Control.Lens hiding (makeLenses) +import Data.List (partition) +import Network.HTTP.Client (Request) +import Network.HTTP.Types (HeaderName) +import Network.Wreq.Lens.Machinery (makeLenses) +import qualified Data.ByteString as S +import qualified Network.HTTP.Client as HTTP + +makeLenses ''HTTP.Request + +assoc :: (Eq k) => k -> IndexedTraversal' k [(k, a)] a +assoc i = traverse . itraversed . index i + +assoc2 :: Eq k => k -> Lens' [(k,a)] [a] +-- This is only a lens up to the ordering of the list (which changes +-- when we modify the list). +-- assoc2 :: (Eq b, Functor f) => b -> ([a] -> f [a]) -> [(b, a)] -> f [(b, a)] +assoc2 k f = fmap (uncurry ((++) . fmap ((,) k))) . + _1 (f . fmap snd) . partition ((==k) . fst) + +setHeader :: HeaderName -> S.ByteString -> Request -> Request +setHeader name value = requestHeaders %~ ((name,value) :) . + filter ((/= name) . fst) diff --git a/Network/Wreq/Internal/Link.hs b/Network/Wreq/Internal/Link.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/Link.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wreq.Internal.Link + ( + links + ) where + +import Control.Applicative ((<$>), (<*>), (*>), (<*), many) +import Data.Attoparsec.ByteString.Char8 as A8 +import Data.ByteString (ByteString) +import Network.Wreq.Types (Link(..)) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 + +links :: B.ByteString -> [Link] +links hdr = case parseOnly f hdr of + Left _ -> [] + Right xs -> xs + where f = sepBy1 (link <* skipSpace) (char8 ',' *> skipSpace) <* endOfInput + +link :: Parser Link +link = Link <$> url <*> many (char8 ';' *> skipSpace *> param) + where url = char8 '<' *> A8.takeTill (=='>') <* char8 '>' <* skipSpace + +param :: Parser (ByteString, ByteString) +param = do + name <- paramName + skipSpace *> "=" *> skipSpace + c <- peekChar' + let isTokenChar = A.inClass "!#$%&'()*+./0-9:<=>?@a-zA-Z[]^_`{|}~-" + val <- case c of + '"' -> quotedString + _ -> A.takeWhile isTokenChar + skipSpace + return (name, val) + +data Quot = Literal | Backslash + +quotedString :: Parser ByteString +quotedString = char '"' *> (fixup <$> body) <* char '"' + where body = A8.scan Literal $ \s c -> + case (s,c) of + (Literal, '\\') -> backslash + (Literal, '"') -> Nothing + _ -> literal + literal = Just Literal + backslash = Just Backslash + fixup = B8.pack . go . B8.unpack + where go ('\\' : x@'\\' : xs) = x : go xs + go ('\\' : x@'"' : xs) = x : go xs + go (x : xs) = x : go xs + go xs = xs + +paramName :: Parser ByteString +paramName = do + name <- A.takeWhile1 $ A.inClass "a-zA-Z0-9!#$&+-.^_`|~" + c <- peekChar + return $ case c of + Just '*' -> B8.snoc name '*' + _ -> name diff --git a/Network/Wreq/Internal/Types.hs b/Network/Wreq/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Internal/Types.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GADTs, RecordWildCards #-} + +-- | +-- Module : Network.Wreq.Internal.Types +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- HTTP client types. + +module Network.Wreq.Internal.Types + ( + -- * Client configuration + Options(..) + , Auth(..) + -- * Request payloads + , Payload(..) + , Postable(..) + , Putable(..) + -- ** URL-encoded forms + , FormParam(..) + , FormValue(..) + -- * Headers + , ContentType + , Link(..) + -- * Errors + , JSONError(..) + ) where + +import Control.Exception (Exception) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Network.HTTP.Client (CookieJar, Manager, ManagerSettings, Request, + RequestBody, destroyCookieJar) +import Network.HTTP.Client.Internal (Proxy) +import Network.HTTP.Types (Header) +import Prelude hiding (head) +import qualified Data.ByteString as S + +-- | A MIME content type, e.g. @\"application/octet-stream\"@. +type ContentType = S.ByteString + +-- | Options for configuring a client. +data Options = Options { + manager :: Either ManagerSettings Manager + -- ^ Either configuration for a 'Manager', or an actual 'Manager'. + -- + -- If only 'ManagerSettings' are provided, then by default a new + -- 'Manager' will be created for each request. + -- + -- /Note/: when issuing HTTP requests using 'Options'-based + -- functions from the the "Network.Wreq.Session" module + -- ('Network.Wreq.Session.getWith', 'Network.Wreq.Session.putWith', + -- etc.), this field will be ignored. + -- + -- An example of using a specific manager: + -- + -- @ + --import "Network.HTTP.Client" ('Network.HTTP.Client.withManager') + -- + --'Network.HTTP.Client.withManager' $ \\mgr -> do + -- let opts = 'Network.Wreq.defaults' { 'manager' = Right mgr } + -- 'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" + -- @ + -- + -- An example of changing settings (this will use a separate + -- 'Manager' for every request, so make sense only if you're issuing + -- a tiny handful of requets): + -- + -- @ + --import "Network.HTTP.Client" ('Network.HTTP.Client.defaultManagerSettings') + -- + --let settings = 'Network.HTTP.Client.defaultManagerSettings' { managerConnCount = 5 } + -- opts = 'Network.Wreq.defaults' { 'manager' = Left settings } + --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" + -- @ + , proxy :: Maybe Proxy + -- ^ Host name and port for a proxy to use, if any. + , auth :: Maybe Auth + -- ^ Authentication information. + -- + -- Example (note the use of TLS): + -- + -- @ + --let opts = 'Network.Wreq.defaults' { 'auth' = 'Network.Wreq.basicAuth' \"user\" \"pass\" } + --'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\" + -- @ + , headers :: [Header] + -- ^ Additional headers to send with each request. + -- + -- @ + --let opts = 'Network.Wreq.defaults' { 'headers' = [(\"Accept\", \"*\/*\")] } + --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" + -- @ + , params :: [(Text, Text)] + -- ^ Key-value pairs to assemble into a query string to add to the + -- end of a URL. + -- + -- For example, given: + -- + -- @ + --let opts = 'Network.Wreq.defaults' { params = [(\"sort\", \"ascending\"), (\"key\", \"name\")] } + --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" + -- @ + -- + -- This will generate a URL of the form: + -- + -- >http://httpbin.org/get?sort=ascending&key=name + , redirects :: Int + -- ^ The maximum number of HTTP redirects to follow before giving up + -- and throwing an exception. + -- + -- In this example, a 'Network.HTTP.Client.HttpException' will be + -- thrown with a 'Network.HTTP.Client.TooManyRedirects' constructor, + -- because the maximum number of redirects allowed will be exceeded: + -- + -- @ + --let opts = 'Network.Wreq.defaults' { 'redirects' = 3 } + --'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/redirect/5\" + -- @ + , cookies :: CookieJar + -- ^ Cookies to set when issuing requests. + -- + -- /Note/: when issuing HTTP requests using 'Options'-based + -- functions from the the "Network.Wreq.Session" module + -- ('Network.Wreq.Session.getWith', 'Network.Wreq.Session.putWith', + -- etc.), this field will be used only for the /first/ HTTP request + -- to be issued during a 'Network.Wreq.Session.Session'. Any changes + -- changes made for subsequent requests will be ignored. + } deriving (Typeable) + +-- | Supported authentication types. +-- +-- Do not use HTTP authentication unless you are using TLS encryption. +-- These authentication tokens can easily be captured and reused by an +-- attacker if transmitted in the clear. +data Auth = BasicAuth S.ByteString S.ByteString + -- ^ Basic authentication. This consists of a plain + -- username and password. + | OAuth2Bearer S.ByteString + -- ^ An OAuth2 bearer token. This is treated by many + -- services as the equivalent of a username and password. + | OAuth2Token S.ByteString + -- ^ A not-quite-standard OAuth2 bearer token (that seems + -- to be used only by GitHub). This is treated by whoever + -- accepts it as the equivalent of a username and + -- password. + deriving (Eq, Show, Typeable) + +instance Show Options where + show (Options{..}) = concat ["Options { " + , "manager = ", case manager of + Left _ -> "Left _" + Right _ -> "Right _" + , ", proxy = ", show proxy + , ", auth = ", show auth + , ", headers = ", show headers + , ", params = ", show params + , ", redirects = ", show redirects + , ", cookies = ", show (destroyCookieJar cookies) + , " }" + ] + +-- | A type that can be converted into a POST request payload. +class Postable a where + postPayload :: a -> Request -> IO Request + -- ^ Represent a value in the request body (and perhaps the + -- headers) of a POST request. + +-- | A type that can be converted into a PUT request payload. +class Putable a where + putPayload :: a -> Request -> IO Request + -- ^ Represent a value in the request body (and perhaps the + -- headers) of a PUT request. + +-- | A product type for representing more complex payload types. +data Payload where + Raw :: ContentType -> RequestBody -> Payload + deriving (Typeable) + +-- | A type that can be rendered as the value portion of a key\/value +-- pair for use in an @application\/x-www-form-urlencoded@ POST +-- body. Intended for use with the 'FormParam' type. +-- +-- The instances for 'String', strict 'Data.Text.Text', and lazy +-- 'Data.Text.Lazy.Text' are all encoded using UTF-8 before being +-- URL-encoded. +-- +-- The instance for 'Maybe' gives an empty string on 'Nothing', +-- and otherwise uses the contained type's instance. +class FormValue a where + renderFormValue :: a -> S.ByteString + -- ^ Render the given value. + +-- | A key\/value pair for an @application\/x-www-form-urlencoded@ +-- POST request body. +data FormParam where + (:=) :: (FormValue v) => S.ByteString -> v -> FormParam + +instance Show FormParam where + show (a := b) = show a ++ " := " ++ show (renderFormValue b) + +infixr 3 := + +-- | The error type used by 'Network.Wreq.asJSON' and +-- 'Network.Wreq.asValue' if a failure occurs when parsing a response +-- body as JSON. +data JSONError = JSONError String + deriving (Show, Typeable) + +instance Exception JSONError + +-- | An element of a @Link@ header. +data Link = Link { + linkURL :: S.ByteString + , linkParams :: [(S.ByteString, S.ByteString)] + } deriving (Eq, Show, Typeable) diff --git a/Network/Wreq/Lens.hs b/Network/Wreq/Lens.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Lens.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.Wreq.Lens +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- HTTP client lens machinery. +-- +-- When reading the examples in this module, you should assume the +-- following environment: +-- +-- @ +-- \-\- Make it easy to write literal 'S.ByteString' and 'Text' values. +-- \{\-\# LANGUAGE OverloadedStrings \#\-\} +-- +-- \-\- Our handy module. +-- import "Network.Wreq" +-- +-- \-\- Operators such as ('&') and ('.~'). +-- import "Control.Lens" +-- +-- \-\- Conversion of Haskell values to JSON. +-- import "Data.Aeson" ('Data.Aeson.toJSON') +-- +-- \-\- Easy traversal of JSON data. +-- import "Data.Aeson.Lens" ('Data.Aeson.Lens.key', 'Data.Aeson.Lens.nth') +-- @ + +module Network.Wreq.Lens + ( + -- * Configuration + Options + , manager + , proxy + , auth + , header + , param + , redirects + , headers + , params + , cookie + , cookies + + -- ** Proxy setup + , Proxy + , proxyHost + , proxyPort + + -- * Cookie + , Cookie + , cookieName + , cookieValue + , cookieExpiryTime + , cookieDomain + , cookiePath + , cookieCreationTime + , cookieLastAccessTime + , cookiePersistent + , cookieHostOnly + , cookieSecureOnly + , cookieHttpOnly + + -- * Response + , Response + , responseBody + , responseHeader + , responseLink + , responseCookie + , responseHeaders + , responseCookieJar + , responseStatus + , responseVersion + + -- ** Status + , Status + , statusCode + , statusMessage + + -- * Link header + , Link + , linkURL + , linkParams + + -- * POST body part + , Part + , partName + , partFileName + , partContentType + , partGetBody + + -- * Parsing + , atto + ) where + +import Control.Lens (Fold, Lens, Lens', Traversal', folding) +import Data.Attoparsec (Parser, parseOnly) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Network.HTTP.Client (Cookie, CookieJar, Manager, ManagerSettings, Proxy) +import Network.HTTP.Client (RequestBody, Response) +import Network.HTTP.Client.MultipartFormData (Part) +import Network.HTTP.Types.Header (Header, HeaderName, ResponseHeaders) +import Network.HTTP.Types.Status (Status) +import Network.HTTP.Types.Version (HttpVersion) +import Network.Mime (MimeType) +import Network.Wreq.Types (Auth, Link, Options) +import qualified Network.Wreq.Lens.TH as TH + +-- | A lens onto configuration of the connection manager provided by +-- the http-client package. +-- +-- In this example, we enable the use of OpenSSL for (hopefully) +-- secure connections: +-- +-- @ +--import "OpenSSL.Session" ('OpenSSL.Session.context') +--import "Network.HTTP.Client.OpenSSL" +-- +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'manager' 'Control.Lens..~' Left ('Network.HTTP.Client.OpenSSL.opensslManagerSettings' 'OpenSSL.Session.context') +--'Network.HTTP.Client.OpenSSL.withOpenSSL' $ +-- 'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/get\" +-- @ +manager :: Lens' Options (Either ManagerSettings Manager) +manager = TH.manager + +-- | A lens onto proxy configuration. +-- +-- Example: +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'proxy' 'Control.Lens..~' 'Network.Wreq.httpProxy' \"localhost\" 8000 +--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +proxy :: Lens' Options (Maybe Proxy) +proxy = TH.proxy + +-- | A lens onto request authentication. +-- +-- Example (note the use of TLS): +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'Lens.auth' 'Control.Lens..~' 'Network.Wreq.basicAuth' \"user\" \"pass\" +--'Network.Wreq.getWith' opts \"https:\/\/httpbin.org\/basic-auth\/user\/pass\" +-- @ +auth :: Lens' Options (Maybe Auth) +auth = TH.auth + +-- | A lens onto all headers with the given name (there can +-- legitimately be zero or more). +-- +-- Example: +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'header' \"Accept\" 'Control.Lens..~' [\"*\/*\"] +--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +header :: HeaderName -> Lens' Options [ByteString] +header = TH.header + +-- | A lens onto all headers (there can legitimately be zero or more). +-- +-- In this example, we print all the headers sent by default with +-- every request. +-- +-- @ +--print ('Network.Wreq.defaults' 'Control.Lens.^.' 'headers') +-- @ +headers :: Lens' Options [Header] +headers = TH.headers + +-- | A lens onto all query parameters with the given name (there can +-- legitimately be zero or more). +-- +-- In this example, we construct the query URL +-- \"@http:\/\/httpbin.org\/get?foo=bar&foo=quux@\". +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'param' \"foo\" 'Control.Lens..~' [\"bar\", \"quux\"] +--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/get\" +-- @ +param :: Text -> Lens' Options [Text] +param = TH.param + +-- | A lens onto all query parameters. +params :: Lens' Options [(Text, Text)] +params = TH.params + +-- | A lens onto the maximum number of redirects that will be followed +-- before an exception is thrown. +-- +-- In this example, a 'Network.HTTP.Client.HttpException' will be +-- thrown with a 'Network.HTTP.Client.TooManyRedirects' constructor, +-- because the maximum number of redirects allowed will be exceeded. +-- +-- @ +--let opts = 'Network.Wreq.defaults' 'Control.Lens.&' 'redirects' 'Control.Lens..~' 3 +--'Network.Wreq.getWith' opts \"http:\/\/httpbin.org\/redirect\/5\" +-- @ +redirects :: Lens' Options Int +redirects = TH.redirects + +-- | A traversal onto the cookie with the given name, if one exists. +cookie :: ByteString -> Traversal' Options Cookie +cookie = TH.cookie + +-- | A lens onto all cookies. +cookies :: Lens' Options CookieJar +cookies = TH.cookies + +-- | A lens onto the name of a cookie. +cookieName :: Lens' Cookie ByteString +cookieName = TH.cookieName + +-- | A lens onto the value of a cookie. +cookieValue :: Lens' Cookie ByteString +cookieValue = TH.cookieValue + +-- | A lens onto the expiry time of a cookie. +cookieExpiryTime :: Lens' Cookie UTCTime +cookieExpiryTime = TH.cookieExpiryTime + +-- | A lens onto the domain of a cookie. +cookieDomain :: Lens' Cookie ByteString +cookieDomain = TH.cookieDomain + +-- | A lens onto the path of a cookie. +cookiePath :: Lens' Cookie ByteString +cookiePath = TH.cookiePath + +-- | A lens onto the creation time of a cookie. +cookieCreationTime :: Lens' Cookie UTCTime +cookieCreationTime = TH.cookieCreationTime + +-- | A lens onto the last access time of a cookie. +cookieLastAccessTime :: Lens' Cookie UTCTime +cookieLastAccessTime = TH.cookieLastAccessTime + +-- | A lens onto whether a cookie is persistent across sessions (also +-- known as a \"tracking cookie\"). +cookiePersistent :: Lens' Cookie Bool +cookiePersistent = TH.cookiePersistent + +-- | A lens onto whether a cookie is host-only. +cookieHostOnly :: Lens' Cookie Bool +cookieHostOnly = TH.cookieHostOnly + +-- | A lens onto whether a cookie is secure-only, such that it will +-- only be used over TLS. +cookieSecureOnly :: Lens' Cookie Bool +cookieSecureOnly = TH.cookieSecureOnly + +-- | A lens onto whether a cookie is \"HTTP-only\". +-- +-- Such cookies should be used only by browsers when transmitting HTTP +-- requests. They must be unavailable in non-browser environments, +-- such as when executing JavaScript scripts. +cookieHttpOnly :: Lens' Cookie Bool +cookieHttpOnly = TH.cookieHttpOnly + +-- | A lens onto the hostname portion of a proxy configuration. +proxyHost :: Lens' Proxy ByteString +proxyHost = TH.proxyHost + +-- | A lens onto the TCP port number of a proxy configuration. +proxyPort :: Lens' Proxy Int +proxyPort = TH.proxyPort + +-- | A lens onto the status of an HTTP response. +responseStatus :: Lens' (Response body) Status +responseStatus = TH.responseStatus + +-- | A lens onto the version of an HTTP response. +responseVersion :: Lens' (Response body) HttpVersion +responseVersion = TH.responseVersion + +-- | A lens onto all matching named headers in an HTTP response. +-- +-- To access exactly one header (the result will be the empty string if +-- there is no match), use the ('Control.Lens.^.') operator. +-- +-- @ +--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\" +--print (r 'Control.Lens.^.' 'responseHeader' \"Content-Type\") +-- @ +-- +-- To access at most one header (the result will be 'Nothing' if there +-- is no match), use the ('Control.Lens.^?') operator. +-- +-- @ +--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\" +--print (r 'Control.Lens.^?' 'responseHeader' \"Content-Transfer-Encoding\") +-- @ +-- +-- To access all (zero or more) matching headers, use the +-- ('Control.Lens.^..') operator. +-- +-- @ +--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\" +--print (r 'Control.Lens.^..' 'responseHeader' \"Set-Cookie\") +-- @ +responseHeader :: HeaderName + -- ^ Header name to match. + -> Traversal' (Response body) ByteString +responseHeader = TH.responseHeader + +-- | A lens onto all headers in an HTTP response. +responseHeaders :: Lens' (Response body) ResponseHeaders +responseHeaders = TH.responseHeaders + +-- | A fold over @Link@ headers, matching on both parameter name +-- and value. +-- +-- For example, here is a @Link@ header returned by the GitHub search API. +-- +-- > Link: +-- > ; rel="next", +-- > ; rel="last" +-- +-- And here is an example of how we can retrieve the URL for the @next@ link +-- programatically. +-- +-- @ +--r <- 'Network.Wreq.get' \"https:\/\/api.github.com\/search\/code?q=addClass+user:mozilla\" +--print (r 'Control.Lens.^?' 'responseLink' \"rel\" \"next\" . 'linkURL') +-- @ +responseLink :: ByteString + -- ^ Parameter name to match. + -> ByteString + -- ^ Parameter value to match. + -> Fold (Response body) Link +responseLink = TH.responseLink + +-- | A lens onto the body of a response. +-- +-- @ +--r <- 'Network.Wreq.get' \"http:\/\/httpbin.org\/get\" +--print (r 'Control.Lens.^.' 'responseBody') +-- @ +responseBody :: Lens (Response body0) (Response body1) body0 body1 +responseBody = TH.responseBody + +-- | A fold over any cookies that match the given name. +-- +-- @ +--r <- 'Network.Wreq.get' \"http:\/\/www.nytimes.com\/\" +--print (r 'Control.Lens.^?' responseCookie \"RMID\") +-- @ +responseCookie :: ByteString + -- ^ Name of cookie to match. + -> Fold (Response body) Cookie +responseCookie = TH.responseCookie + +-- | A lens onto all cookies set in the response. +responseCookieJar :: Lens' (Response body) CookieJar +responseCookieJar = TH.responseCookieJar + +-- | A lens onto the numeric identifier of an HTTP status. +statusCode :: Lens' Status Int +statusCode = TH.statusCode + +-- | A lens onto the textual description of an HTTP status. +statusMessage :: Lens' Status ByteString +statusMessage = TH.statusMessage + +-- | A lens onto the URL portion of a @Link@ element. +linkURL :: Lens' Link ByteString +linkURL = TH.linkURL + +-- | A lens onto the parameters of a @Link@ element. +linkParams :: Lens' Link [(ByteString, ByteString)] +linkParams = TH.linkParams + +-- | A lens onto the name of the @@ element associated with +-- part of a multipart form upload. +partName :: Lens' Part Text +partName = TH.partName + +-- | A lens onto the filename associated with part of a multipart form +-- upload. +partFileName :: Lens' Part (Maybe String) +partFileName = TH.partFilename + +-- | A lens onto the content-type associated with part of a multipart +-- form upload. +partContentType :: Traversal' Part (Maybe MimeType) +partContentType = TH.partContentType + +-- | A lens onto the code that fetches the data associated with part +-- of a multipart form upload. +partGetBody :: Lens' Part (IO RequestBody) +partGetBody = TH.partGetBody + +-- | Turn an attoparsec 'Parser' into a 'Fold'. +-- +-- Both headers and bodies can contain complicated data that we may +-- need to parse. +-- +-- Example: when responding to an OPTIONS request, a server may return +-- the list of verbs it supports in any order, up to and including +-- changing the order on every request (which httpbin.org /actually +-- does/!). To deal with this possibility, we parse the list, then +-- sort it. +-- +-- >>> import Data.Attoparsec.ByteString.Char8 as A +-- >>> import Data.List (sort) +-- >>> +-- >>> let comma = skipSpace >> "," >> skipSpace +-- >>> let verbs = A.takeWhile isAlpha_ascii `sepBy` comma +-- >>> +-- >>> r <- options "http://httpbin.org/get" +-- >>> r ^. responseHeader "Allow" . atto verbs . to sort +-- ["GET","HEAD","OPTIONS"] +atto :: Parser a -> Fold ByteString a +atto = folding . parseOnly + +-- $setup +-- +-- >>> :set -XOverloadedStrings +-- >>> import Control.Lens +-- >>> import Data.Aeson (toJSON) +-- >>> import Data.Aeson.Lens (key, nth) +-- >>> import Network.Wreq diff --git a/Network/Wreq/Lens/Machinery.hs b/Network/Wreq/Lens/Machinery.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Lens/Machinery.hs @@ -0,0 +1,20 @@ +module Network.Wreq.Lens.Machinery + ( + makeLenses + , toCamelCase + ) where + +import Control.Lens ((&), (.~)) +import Control.Lens.TH (defaultRules, lensField, makeLensesWith) +import Data.Char (toUpper) +import Language.Haskell.TH.Syntax (Dec, Name, Q) + +makeLenses :: Name -> Q [Dec] +makeLenses = makeLensesWith (defaultRules & lensField .~ Just) + +toCamelCase :: String -> String +toCamelCase (x0:x0s) = x0 : go x0s + where go ('_':x:xs) = toUpper x : go xs + go (x:xs) = x : go xs + go [] = [] +toCamelCase [] = [] diff --git a/Network/Wreq/Lens/TH.hs b/Network/Wreq/Lens/TH.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Lens/TH.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, + TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Network.Wreq.Lens.TH + ( + Types.Options + , manager + , proxy + , auth + , header + , headers + , param + , params + , redirects + , cookie + , cookies + + , HTTP.Cookie + , cookieName + , cookieValue + , cookieExpiryTime + , cookieDomain + , cookiePath + , cookieCreationTime + , cookieLastAccessTime + , cookiePersistent + , cookieHostOnly + , cookieSecureOnly + , cookieHttpOnly + + , HTTP.Proxy + , proxyHost + , proxyPort + + , HTTP.Response + , responseStatus + , responseVersion + , responseHeader + , responseHeaders + , responseLink + , responseBody + , responseCookie + , responseCookieJar + , responseClose' + + , HTTP.Status + , statusCode + , statusMessage + + , Types.Link + , linkURL + , linkParams + + , Form.Part + , partName + , partFilename + , partContentType + , partGetBody + ) where + +import Control.Lens hiding (makeLenses) +import Control.Lens.TH (defaultRules, lensField, makeLensesWith) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Network.Wreq.Internal.Lens (assoc, assoc2) +import Network.Wreq.Lens.Machinery (makeLenses, toCamelCase) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.MultipartFormData as Form +import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.HTTP.Types.Status as HTTP +import qualified Network.Wreq.Types as Types +import Network.Wreq.Internal.Link + +makeLenses ''Types.Options +makeLensesWith (defaultRules & lensField .~ Just . toCamelCase) ''HTTP.Cookie +makeLenses ''HTTP.Proxy +makeLenses ''HTTP.Response +makeLenses ''HTTP.Status +makeLenses ''Types.Link +makeLenses ''Form.Part + +responseHeader :: HTTP.HeaderName -> Traversal' (HTTP.Response body) ByteString +responseHeader n = responseHeaders . assoc n + +param :: Text -> Lens' Types.Options [Text] +param n = params . assoc2 n + +header :: HTTP.HeaderName -> Lens' Types.Options [ByteString] +header n = headers . assoc2 n + +_CookieJar :: Iso' HTTP.CookieJar [HTTP.Cookie] +_CookieJar = iso HTTP.destroyCookieJar HTTP.createCookieJar + +-- N.B. This is an "illegal" traversal because we can change its cookie_name. +cookie :: ByteString -> Traversal' Types.Options HTTP.Cookie +cookie name = cookies . _CookieJar . traverse . filtered + (\c -> HTTP.cookie_name c == name) + +responseCookie :: ByteString -> Fold (HTTP.Response body) HTTP.Cookie +responseCookie name = + responseCookieJar . folding HTTP.destroyCookieJar . filtered + ((==name) . HTTP.cookie_name) + +responseLink :: ByteString -> ByteString -> Fold (HTTP.Response body) Types.Link +responseLink name val = + responseHeader "Link" . folding links . + filtered (has (linkParams . folded . filtered (== (name,val)))) diff --git a/Network/Wreq/Session.hs b/Network/Wreq/Session.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Session.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.Wreq.Session + ( + Session + , withSession + -- * HTTP verbs + , get + , post + , head_ + , options + , put + , delete + -- ** Configurable verbs + , getWith + , postWith + , headWith + , optionsWith + , putWith + , deleteWith + ) where + +import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) +import Control.Lens ((&), (.~), (^.)) +import Network.Wreq (Options, Response, defaults) +import Network.Wreq.Internal (defaultManagerSettings) +import Network.Wreq.Types (Postable, Putable) +import Prelude hiding (head) +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Client as HTTP +import qualified Network.Wreq as Wreq + +data Session = Session { + seshCookies :: MVar HTTP.CookieJar + , seshManager :: HTTP.Manager + } + +instance Show Session where + show _ = "Session" + +withSession :: (Session -> IO a) -> IO a +withSession act = do + mv <- newMVar $ HTTP.createCookieJar [] + HTTP.withManager defaultManagerSettings $ \mgr -> + act Session { seshCookies = mv, seshManager = mgr } + +get :: Session -> String -> IO (Response L.ByteString) +get = getWith defaults + +post :: Postable a => Session -> String -> a -> IO (Response L.ByteString) +post = postWith defaults + +head_ :: Session -> String -> IO (Response ()) +head_ = headWith defaults + +options :: Session -> String -> IO (Response ()) +options = optionsWith defaults + +put :: Putable a => Session -> String -> a -> IO (Response L.ByteString) +put = putWith defaults + +delete :: Session -> String -> IO (Response ()) +delete = deleteWith defaults + +getWith :: Options -> Session -> String -> IO (Response L.ByteString) +getWith opts sesh url = + override opts sesh $ \opts' -> Wreq.getWith opts' url + +postWith :: Postable a => Options -> Session -> String -> a + -> IO (Response L.ByteString) +postWith opts sesh url payload = + override opts sesh $ \opts' -> Wreq.postWith opts' url payload + +headWith :: Options -> Session -> String -> IO (Response ()) +headWith opts sesh url = + override opts sesh $ \opts' -> Wreq.headWith opts' url + +optionsWith :: Options -> Session -> String -> IO (Response ()) +optionsWith opts sesh url = + override opts sesh $ \opts' -> Wreq.optionsWith opts' url + +putWith :: Putable a => Options -> Session -> String -> a + -> IO (Response L.ByteString) +putWith opts sesh url payload = + override opts sesh $ \opts' -> Wreq.putWith opts' url payload + +deleteWith :: Options -> Session -> String -> IO (Response ()) +deleteWith opts sesh url = + override opts sesh $ \opts' -> Wreq.deleteWith opts' url + +override :: Options -> Session -> (Options -> IO (Response body)) + -> IO (Response body) +override opts Session{..} act = + modifyMVar seshCookies $ \cj -> do + resp <- act $ opts & Wreq.cookies .~ cj & + Wreq.manager .~ Right seshManager + return (resp ^. Wreq.responseCookieJar, resp) diff --git a/Network/Wreq/Types.hs b/Network/Wreq/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Wreq/Types.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Network.Wreq.Types +-- Copyright : (c) 2014 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- HTTP client types. + +module Network.Wreq.Types + ( + -- * Client configuration + Options(..) + , Auth(..) + -- * Request payloads + , Payload(..) + , Postable(..) + , Putable(..) + -- ** URL-encoded forms + , FormParam(..) + , FormValue(..) + -- * Headers + , ContentType + , Link(..) + -- * Errors + , JSONError(..) + ) where + +import Control.Lens ((&), (.~)) +import Data.Aeson (Value, encode) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Network.HTTP.Client (Request) +import Network.HTTP.Client.MultipartFormData (Part, formDataBody) +import Network.Wreq.Internal.Types +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TL +import qualified Network.HTTP.Client as HTTP +import qualified Network.Wreq.Internal.Lens as Lens + +instance Postable Part where + postPayload a = postPayload [a] + +instance Postable [Part] where + postPayload = formDataBody + +instance Postable [(S.ByteString, S.ByteString)] where + postPayload ps req = return $ HTTP.urlEncodedBody ps req + +instance Postable (S.ByteString, S.ByteString) where + postPayload p = postPayload [p] + +instance Postable [FormParam] where + postPayload ps = postPayload (map f ps) + where f (a := b) = (a, renderFormValue b) + +instance Postable FormParam where + postPayload p = postPayload [p] + +instance Postable Payload where + postPayload = putPayload + +instance Postable S.ByteString where + postPayload = putPayload + +instance Postable L.ByteString where + postPayload = putPayload + +instance Postable Value where + postPayload = putPayload + + +instance Putable Payload where + putPayload pl = + case pl of + Raw ct rb -> payload ct rb + +instance Putable S.ByteString where + putPayload = payload "application/octet-stream" . HTTP.RequestBodyBS + +instance Putable L.ByteString where + putPayload = payload "application/octet-stream" . HTTP.RequestBodyLBS + +instance Putable Value where + putPayload = payload "application/json" . HTTP.RequestBodyLBS . encode + + +instance FormValue T.Text where + renderFormValue = T.encodeUtf8 + +instance FormValue TL.Text where + renderFormValue = T.encodeUtf8 . TL.toStrict + +instance FormValue TL.Builder where + renderFormValue = T.encodeUtf8 . TL.toStrict . TL.toLazyText + +instance FormValue String where + renderFormValue = T.encodeUtf8 . T.pack + +instance FormValue S.ByteString where + renderFormValue = id + +instance FormValue L.ByteString where + renderFormValue = S.concat . L.toChunks + +instance FormValue Int where renderFormValue = renderFormValue . show +instance FormValue Int8 where renderFormValue = renderFormValue . show +instance FormValue Int16 where renderFormValue = renderFormValue . show +instance FormValue Int32 where renderFormValue = renderFormValue . show +instance FormValue Int64 where renderFormValue = renderFormValue . show +instance FormValue Integer where renderFormValue = renderFormValue . show + +instance FormValue Word where renderFormValue = renderFormValue . show +instance FormValue Word8 where renderFormValue = renderFormValue . show +instance FormValue Word16 where renderFormValue = renderFormValue . show +instance FormValue Word32 where renderFormValue = renderFormValue . show +instance FormValue Word64 where renderFormValue = renderFormValue . show + +instance FormValue Float where renderFormValue = renderFormValue . show +instance FormValue Double where renderFormValue = renderFormValue . show + +instance FormValue () where renderFormValue _ = "" + +instance (FormValue a) => FormValue (Maybe a) where + renderFormValue (Just a) = renderFormValue a + renderFormValue Nothing = "" + +payload :: ContentType -> HTTP.RequestBody -> Request -> IO Request +payload ct body req = return $ req & Lens.setHeader "Content-Type" ct & + Lens.requestBody .~ body diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +# wreq: a Haskell web client library + +`wreq` is a library that makes HTTP client programming in Haskell +easy. + + +# Features + +* Simple but powerful `lens`-based API + +* Over 100 tests, and built on reliable libraries like [`http-client`](http://hackage.haskell.org/package/http-client/) + and [`lens`](https://lens.github.io/) + +* Session handling includes connection keep-alive and pooling, and + cookie persistence + +* Automatic decompression + +* Powerful multipart form and file upload handling + +* Support for JSON requests and responses, including navigation of + schema-less responses + +* Basic and OAuth2 bearer authentication + + +# Is it done? + +No! See [`TODO.md`](TODO.md) for a rather long list of ideas. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,64 @@ +-- I don't know who originally wrote this, but I picked it up from +-- Edward Kmett's folds package. + +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List (nub) +import Data.Version (showVersion) +import Distribution.Package + (PackageName(PackageName), Package, PackageId, InstalledPackageId, + packageVersion, packageName) +import Distribution.PackageDescription (PackageDescription(), TestSuite(..)) +import Distribution.Simple + (defaultMainWithHooks, UserHooks(..), simpleUserHooks) +import Distribution.Simple.BuildPaths (autogenModulesDir) +import Distribution.Simple.LocalBuildInfo + (withLibLBI, withTestLBI, LocalBuildInfo(), + ComponentLocalBuildInfo(componentPackageDeps)) +import Distribution.Simple.Setup + (BuildFlags(buildVerbosity), Flag(..), fromFlag, + HaddockFlags(haddockDistPref)) +import Distribution.Simple.Utils + (rewriteFile, createDirectoryIfMissingVerbose, copyFiles) +import Distribution.Text (display) +import Distribution.Verbosity (Verbosity, normal) +import System.FilePath (()) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + , postHaddock = \args flags pkg lbi -> do + copyFiles normal (haddockOutputDir flags pkg) [] + postHaddock simpleUserHooks args flags pkg lbi + } + +haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath +haddockOutputDir flags pkg = destDir where + baseDir = case haddockDistPref flags of + NoFlag -> "." + Flag x -> x + destDir = baseDir "doc" "html" display (packageName pkg) + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo + -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo + -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -0,0 +1,19 @@ +# Work yet to be done + +* More advanced tutorial-style documentation + +* TLS server certificate verification + +* An example that spiders a Haddock package's docs to validate its + internal and external links + +* Integration with tagsoup (see + [the mess in `UploadPaste.hs`](https://github.com/bos/wreq/blob/master/examples/UploadPaste.hs#L137)) + +* International domain support? + +* Better authentication support, including session-long memory of + which URLs do and don't need authentication + +* Some poor sod needs to add digest authentication to `http-client` so + we can use it diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,1 @@ +. diff --git a/examples/JsonResponse.hs b/examples/JsonResponse.hs new file mode 100644 --- /dev/null +++ b/examples/JsonResponse.hs @@ -0,0 +1,122 @@ +-- Examples of handling for JSON responses +-- +-- This library provides several ways to handle JSON responses + +{-# LANGUAGE DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +import Control.Lens ((&), (^.), (^?), (.~)) +import Data.Aeson (FromJSON) +import Data.Aeson.Lens (key) +import Data.Map (Map) +import Data.Text (Text) +import GHC.Generics (Generic) +import qualified Control.Exception as E + +import Network.Wreq + + +-- This Haskell type corresponds to the structure of a response body +-- from httpbin.org. + +data GetBody = GetBody { + headers :: Map Text Text + , args :: Map Text Text + , origin :: Text + , url :: Text + } deriving (Show, Generic) + +-- Get GHC to derive a FromJSON instance for us. + +instance FromJSON GetBody + + + +-- We expect this to succeed. + +basic_asJSON :: IO () +basic_asJSON = do + let opts = defaults & param "foo" .~ ["bar"] + r <- asJSON =<< getWith opts "http://httpbin.org/get" + + -- The fact that we want a GetBody here will be inferred by our use + -- of the "headers" accessor function. + + putStrLn $ "args: " ++ show (args (r ^. responseBody)) + + + +-- The response we expect here is valid JSON, but cannot be converted +-- to an [Int], so this will throw a JSONError. + +failing_asJSON :: IO () +failing_asJSON = do + (r :: Response [Int]) <- asJSON =<< get "http://httpbin.org/get" + putStrLn $ "response: " ++ show (r ^. responseBody) + + + +-- This demonstrates how to catch a JSONError. + +failing_asJSON_catch :: IO () +failing_asJSON_catch = + failing_asJSON `E.catch` \(e :: JSONError) -> print e + + + +-- Because asJSON is parameterized over MonadThrow, we can use it with +-- other instances. +-- +-- Here, instead of throwing an exception in the IO monad, we instead +-- evaluate the result as an Either: +-- +-- * if the conversion fails, the Left constructor will contain +-- whatever exception describes the error +-- +-- * if the conversion succeeds, the Right constructor will contain +-- the converted response + +either_asJSON :: IO () +either_asJSON = do + r <- get "http://httpbin.org/get" + + -- This first conversion attempt will fail, but because we're using + -- Either, it will not throw an exception that kills execution. + let failing = asJSON r :: Either E.SomeException (Response [Int]) + print failing + + -- Our second conversion attempt will succeed. + let succeeding = asJSON r :: Either E.SomeException (Response GetBody) + print succeeding + + + +-- The lens package defines some handy combinators for use with the +-- aeson package, with which we can easily traverse parts of a JSON +-- response. + +lens_aeson :: IO () +lens_aeson = do + r <- get "http://httpbin.org/get" + print $ r ^? responseBody . key "headers" . key "User-Agent" + + -- If we maintain the ResponseBody as a ByteString, the lens + -- combinators will have to convert the body to a Value every time + -- we start a new traversal. + + -- When we need to poke at several parts of a response, it's more + -- efficient to use asValue to perform the conversion to a Value + -- once. + + let opts = defaults & param "baz" .~ ["quux"] + v <- asValue =<< getWith opts "http://httpbin.org/get" + print $ v ^? responseBody . key "args" . key "baz" + + + +main :: IO () +main = do + basic_asJSON + failing_asJSON_catch + either_asJSON + lens_aeson diff --git a/examples/UploadPaste.hs b/examples/UploadPaste.hs new file mode 100644 --- /dev/null +++ b/examples/UploadPaste.hs @@ -0,0 +1,166 @@ +-- upload a paste to lpaste.net +-- +-- This example is pretty beefy, as it does double duty. +-- +-- Perhaps the majority of it shows off some complex uses of the +-- optparse-applicative package. +-- +-- The POST portion is in the function named upload below. It uploads +-- an application/x-www-urlencoded form that creates a paste on the +-- Haskell community pastebin at . + +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} + +import Control.Applicative +import Control.Lens +import Data.Char (toLower) +import Data.Maybe (listToMaybe) +import Data.Monoid (mempty) +import Network.Wreq (FormParam((:=)), post, responseBody) +import Network.Wreq.Types (FormValue(..)) +import Options.Applicative as Opts hiding ((&), header) +import System.FilePath (takeExtension, takeFileName) +import Text.HTML.TagSoup +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L + +-- A post to lpaste.net can either be private or public (visible in an +-- index). +data Visibility = Private | Public + deriving (Show) + +-- Wreq supports uploading an application/x-www-urlencoded form (see +-- uses of the := operator in the upload function below), so we tell +-- it how to render a value of a custom datatype. +instance FormValue Visibility where + renderFormValue = renderFormValue . show + +-- The languages that lpaste.net supports. It just so happens that if +-- we convert one of these constructor names to a lower-case string, +-- it exactly matches what lpaste.net needs in its upload form. +data Language = + Haskell | Agda | Assembly | Bash | C | Coq | Cpp | Cs | Diff | Elm | ELisp | + Erlang | Go | Idris | Java | JavaScript | LiterateHaskell | Lisp | + Lua | OCaml | ObjectiveC | Perl | Prolog | Python | Ruby | SQL | Scala | + Scheme | Smalltalk | TeX + deriving (Eq, Show) + +instance FormValue Language where + renderFormValue = renderFormValue . fmap toLower . show + +-- An association between filename suffixes and our Language type. +languages :: [([String], Language)] +languages = [ + ([".hs"], Haskell), ([".agda"], Agda), ([".el"], ELisp), ([".ocaml"], OCaml), + ([".cl"], Lisp), ([".erl"], Erlang), ([".lhs"], LiterateHaskell), + ([".scala"], Scala), ([".go"], Go), ([".py"], Python), ([".rb"], Ruby), + ([".elm"], Elm), ([".idris"], Idris), ([".prl"], Prolog), ([".scm"], Scheme), + ([".coq"], Coq), ([".s", ".asm"], Assembly), ([".sh"], Bash), + ([".c", ".h"], C), ([".cs"], Cs), ([".tex"], TeX), ([".lua"], Lua), + ([".cxx", ".cpp", ".cc", ".hxx", ".hpp", ".hh"], Cpp), ([".pl", ".pm"], Perl), + ([".diff", ".patch"], Diff), ([".java"], Java), ([".js"], JavaScript), + ([".m"], ObjectiveC), ([".smalltalk"], Smalltalk), ([".sql"], SQL) + ] + +-- An IRC channel to which an announcement of a paste can be posted. +-- We wrap this in a newtype so we can control how it is rendered in a +-- form. +newtype Channel = Channel { fromChannel :: String } + deriving (Eq, Show) + +-- If a user forgot to supply a leading '#' for a channel name, we add +-- it here. +instance FormValue Channel where + renderFormValue = renderFormValue . checkHash . fromChannel + where checkHash cs@('#':_) = cs + checkHash cs@(_:_) = '#' : cs + checkHash cs = cs + +-- This type plays two roles. It describes the command line options +-- we accept, and also the contents of the form we'll upload to create +-- a new paste. +-- +-- We've parameterised the type so that the payload field can either +-- be a filename or the actual contents of the file. +data Paste a = Paste { + _private :: Visibility + , _title :: Maybe String + , _author :: Maybe String + , _channel :: Maybe Channel + , _language :: Maybe Language + , _payload :: a + , _email :: () -- used by lpaste.net for spam protection + } deriving (Show) + +makeLenses ''Paste + +-- Try to match a user-supplied name to a Language type, looking at +-- both full names and filename extensions. +readLanguage :: Monad m => String -> m Language +readLanguage l = do + let ll = toLower <$> l + ms = [lang | (suffixes, lang) <- languages, + ll == (toLower <$> show lang) || ll `elem` (tail <$> suffixes)] + case ms of + [m] -> return m + _ -> fail $ "unsupported language " ++ show l + +-- Figure out the language to specify for a file, either explicitly as +-- specified by the user, or implicitly from the filename extension. +guessLanguage :: FilePath -> Paste a -> Maybe Language +guessLanguage filename p = + (p ^. language) <|> + listToMaybe [lang | (suffixes, lang) <- languages, sfx `elem` suffixes] + where sfx = toLower <$> takeExtension filename + +upload :: Paste FilePath -> IO () +upload p0 = do + let path = p0 ^. payload + body <- B.readFile path + -- Transform command line options into form contents. + let p = p0 & payload .~ body + & title .~ (p0 ^. title <|> Just (takeFileName path)) + & language .~ guessLanguage path p0 + -- The := operator defines a key/value pair for a form. + resp <- post "http://lpaste.net/new" [ + "private" := p ^. private + , "title" := p ^. title + , "author" := p ^. author + , "channel" := p ^. channel + , "language" := p ^. language + , "paste" := p ^. payload + , "email" := p ^. email + ] + -- Since lpaste.net doesn't provide an API and just spits HTML back + -- at us, we use tagsoup to look through the tags for the permalink + -- of the paste we just uploaded. + let findURI (TagOpen "strong" [] : TagText "Paste:" : TagClose "strong" : + TagOpen "a" [("href",uri)] : _) = Just uri + findURI (_:xs) = findURI xs + findURI _ = Nothing + case findURI (parseTagsOptions parseOptionsFast (resp ^. responseBody)) of + Just uri -> L.putStrLn $ "http://lpaste.net" <> uri + Nothing -> putStrLn "no uri in response!?" + +main :: IO () +main = upload =<< execParser opts + where opts = info (helper <*> optionParser) mempty + optionParser = Paste <$> + (flag Private Public $ long "public" <> + help "display in index of pastes") <*> + (optional . strOption $ + long "title" <> short 't' <> metavar "TITLE" <> + help "title to use for paste") <*> + (optional . strOption $ + long "author" <> short 'a' <> metavar "AUTHOR" <> + help "author to display for paste") <*> + (optional . fmap Channel . strOption $ + long "channel" <> short 'c' <> metavar "CHANNEL" <> + help "name of IRC channel to announce") <*> + (optional . nullOption $ + long "language" <> short 'l' <> metavar "LANG" <> + help "language to use" <> reader readLanguage) <*> + (Opts.argument str $ metavar "PATH" <> + help "file to upload") <*> + (pure ()) diff --git a/examples/wreq-examples.cabal b/examples/wreq-examples.cabal new file mode 100644 --- /dev/null +++ b/examples/wreq-examples.cabal @@ -0,0 +1,51 @@ +name: wreq-examples +version: 0 +synopsis: wreq examples, not for installing +description: +homepage: https://github.com/bos/wreq +bug-reports: https://github.com/bos/wreq/issues +license: BSD3 +license-file: ../LICENSE.md +maintainer: bos@serpentine.com +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable wreq-example-json-response + main-is: JsonResponse.hs + ghc-options: -Wall -fwarn-tabs -threaded + default-language: Haskell98 + + build-depends: + aeson, + base >= 4.5 && < 5, + containers, + ghc-prim, + lens, + text, + wreq + +executable upload-paste + main-is: UploadPaste.hs + ghc-options: -Wall -fwarn-tabs -threaded + default-language: Haskell98 + + build-depends: + aeson >= 0.7.0.3, + ansi-wl-pprint >= 0.6.6, + base >= 4.5 && < 5, + bytestring, + filepath, + lens, + optparse-applicative, + tagsoup, + text, + wreq + +source-repository head + type: git + location: https://github.com/bos/wreq + +source-repository head + type: mercurial + location: https://bitbucket.org/bos/wreq diff --git a/httpbin/HttpBin.hs b/httpbin/HttpBin.hs new file mode 100644 --- /dev/null +++ b/httpbin/HttpBin.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +-- TBD: basic-auth, gzip + +module Main (main) where + +import Control.Applicative ((<$>)) +import Data.Aeson (Value(..), eitherDecode, object, toJSON) +import Data.Aeson.Encode.Pretty (Config(..), encodePretty') +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Char8 (pack) +import Data.CaseInsensitive (original) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Read (decimal) +import Snap.Core +import Snap.Http.Server +import Snap.Util.GZip (withCompression) +import qualified Data.ByteString.Char8 as B +import qualified Data.Map as Map +import qualified Data.Text.Lazy.Encoding as Lazy + +get = respond return + +post = respond $ \obj -> do + body <- readRequestBody 65536 + return $ obj <> [("data", toJSON (Lazy.decodeUtf8 body))] <> + case eitherDecode body of + Left _ -> [("json", Null)] + Right val -> [("json", val)] + +put = post + +delete = respond return + +status = do + val <- (fromMaybe 200 . rqIntParam "val") <$> getRequest + let code | val >= 200 && val <= 505 = val + | otherwise = 400 + modifyResponse $ setResponseCode code + +gzip = + localRequest (setHeader "Accept-Encoding" "gzip") . withCompression . + respond $ \obj -> return $ obj <> [("gzipped", Bool True)] + +setCookies = do + params <- rqQueryParams <$> getRequest + modifyResponse . foldr (.) id . map addResponseCookie $ + [Cookie k v Nothing Nothing (Just "/") False False + | (k,vs) <- Map.toList params, v <- vs] + redirect "/cookies" + +redirect_ = do + req <- getRequest + let n = fromMaybe (-1::Int) . rqIntParam "n" $ req + prefix = B.reverse . B.dropWhile (/='/') . B.reverse . rqURI $ req + case undefined of + _| n > 1 -> redirect $ prefix <> pack (show (n-1)) + | n == 1 -> redirect "/get" + | otherwise -> modifyResponse $ setResponseCode 400 + +basicAuth = do + req <- getRequest + let unauthorized = modifyResponse $ + setHeader "WWW-Authenticate" "Basic realm=\"Fake Realm\"" . + setResponseCode 401 + case (rqParam "user" req, rqParam "pass" req) of + (Just [user], Just [passwd]) | not (':' `B.elem` user) -> + case getHeader "Authorization" (headers req) of + Nothing -> unauthorized + Just auth -> do + let expected = "Basic " <> B64.encode (user <> ":" <> passwd) + if auth /= expected + then unauthorized + else writeJSON [ ("user", toJSON (B.unpack user)) + , ("authenticated", Bool True) ] + _ -> modifyResponse $ setResponseCode 400 + +rqIntParam name req = + case rqParam name req of + Just (str:_) -> case decimal (decodeUtf8 str) of + Right (n, "") -> Just n + _ -> Nothing + _ -> Nothing + +writeJSON obj = do + modifyResponse $ setContentType "application/json" + writeLBS . (<> "\n") . encodePretty' (Config 2 compare) . object $ obj + +respond act = do + req <- getRequest + let step m k v = Map.insert (decodeUtf8 k) (decodeUtf8 (head v)) m + params = Map.foldlWithKey' step Map.empty . + rqQueryParams $ req + wibble (k,v) = (decodeUtf8 (original k), decodeUtf8 v) + rqHeaders = headers req + hdrs = Map.fromList . map wibble . listHeaders $ rqHeaders + url = case getHeader "Host" rqHeaders of + Nothing -> [] + Just host -> [("url", toJSON . decodeUtf8 $ + "http://" <> host <> rqURI req)] + writeJSON =<< act ([ ("args", toJSON params) + , ("headers", toJSON hdrs) + , ("origin", toJSON . decodeUtf8 . rqRemoteAddr $ req) + ] <> url) + +main = do + cfg <- commandLineConfig + . setAccessLog ConfigNoLog + . setErrorLog ConfigNoLog + $ defaultConfig + httpServe cfg $ route [ + ("/get", methods [GET,HEAD] get) + , ("/post", method POST post) + , ("/put", method PUT put) + , ("/delete", method DELETE delete) + , ("/redirect/:n", redirect_) + , ("/status/:val", status) + , ("/gzip", methods [GET,HEAD] gzip) + , ("/cookies/set", methods [GET,HEAD] setCookies) + , ("/basic-auth/:user/:pass", methods [GET,HEAD] basicAuth) + ] diff --git a/tests/DocTests.hs b/tests/DocTests.hs new file mode 100644 --- /dev/null +++ b/tests/DocTests.hs @@ -0,0 +1,47 @@ +-- I don't know who originally wrote this, but I picked it up from +-- Edward Kmett's folds package, and subsequently modified it. + +module Main where + +import Build_doctest (deps) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (filterM) +import Data.List (isPrefixOf, isSuffixOf) +import System.Directory +-- import System.Environment (getArgs) +import System.FilePath (()) +import Test.DocTest (doctest) + +main :: IO () +main = do + -- doctest chokes on the command line args that cabal test passes in + -- args <- getArgs + let args = [] + srcs <- getSources + dist <- getDistDir + doctest $ args ++ [ "-i." + , "-i" ++ dist ++ "/build/autogen" + , "-optP-include" + , "-optP" ++ dist ++ "/build/autogen/cabal_macros.h" + , "-hide-all-packages" + ] ++ map ("-package="++) deps ++ srcs + +getSources :: IO [FilePath] +getSources = filter (isSuffixOf ".hs") <$> go "Network" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> + getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c + +getDistDir :: IO FilePath +getDistDir = do + names <- getDirectoryContents "dist" + return $ case filter ("dist-sandbox-" `isPrefixOf`) names of + (d:_) -> "dist/" ++ d + _ -> "dist" diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-missing-signatures + -fno-warn-unused-binds #-} + +module Main (main) where + +import Control.Applicative ((<$>)) +import Control.Exception (Exception) +import Control.Lens ((^.), (^?), (.~), (&)) +import Control.Monad (unless, void) +import Data.Aeson (Value(..), object) +import Data.Aeson.Lens (key) +import Data.ByteString (ByteString) +import Data.Char (toUpper) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import Data.Text (pack) +import Network.HTTP.Client (HttpException(..)) +import Network.HTTP.Types.Status (status200, status401) +import Network.HTTP.Types.Version (http11) +import Network.Wreq +import Network.Wreq.Lens +import qualified Network.Wreq.Session as Session +import System.IO (hClose, hPutStr) +import System.IO.Temp (withSystemTempFile) +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool, assertEqual, assertFailure) +import qualified Control.Exception as E +import qualified Data.Text as T + +basicGet site = do + r <- get (site "/get") + assertBool "GET request has User-Agent header" $ + isJust (r ^. responseBody ^? key "headers" . key "User-Agent") + -- test the various lenses + assertEqual "GET succeeds" status200 (r ^. responseStatus) + assertEqual "GET succeeds 200" 200 (r ^. responseStatus . statusCode) + assertEqual "GET succeeds OK" "OK" (r ^. responseStatus . statusMessage) + assertEqual "GET response has HTTP/1.1 version" http11 (r ^. responseVersion) + assertBool "GET response has Content-Type header" $ + isJust (r ^? responseHeader "Content-Type") + assertBool "GET response has Date header" $ + isJust (lookup "Date" <$> r ^? responseHeaders) + +basicPost site = do + r <- post (site "/post") ("wibble" :: ByteString) >>= asValue + let body = r ^. responseBody + assertEqual "POST succeeds" status200 (r ^. responseStatus) + assertEqual "POST echoes input" (Just "wibble") (body ^? key "data") + assertEqual "POST is binary" (Just "application/octet-stream") + (body ^? key "headers" . key "Content-Type") + +multipartPost site = + withSystemTempFile "foo.html" $ \name handle -> do + hPutStr handle " return () + _ -> assertFailure "unexpected exception thrown" + +getBasicAuth site = do + let opts = defaults & auth .~ basicAuth "user" "passwd" + r <- getWith opts (site "/basic-auth/user/passwd") + assertEqual "basic auth GET succeeds" status200 (r ^. responseStatus) + let inspect e = case e of + StatusCodeException status _ _ -> + assertEqual "failed basic auth failed GET gives 401" + status401 status + assertThrows "basic auth GET fails if password is bad" inspect $ + getWith opts (site "/basic-auth/user/asswd") + +getRedirect site = do + r <- get (site "/redirect/3") + let stripProto = T.dropWhile (/=':') + smap f (String s) = String (f s) + assertEqual "redirect goes to /get" + (Just . String . stripProto . pack . site $ "/get") + (smap stripProto <$> (r ^. responseBody ^? key "url")) + +getParams site = do + let opts1 = defaults & param "foo" .~ ["bar"] + r1 <- getWith opts1 (site "/get") + assertEqual "params set correctly 1" (Just (object [("foo","bar")])) + (r1 ^. responseBody ^? key "args") + let opts2 = defaults & params .~ [("quux","baz")] + r2 <- getWith opts2 (site "/get") + assertEqual "params set correctly 2" (Just (object [("quux","baz")])) + (r2 ^. responseBody ^? key "args") + r3 <- getWith opts2 (site "/get?whee=wat") + assertEqual "correctly handle mix of params from URI and Options" + (Just (object [("quux","baz"),("whee","wat")])) + (r3 ^. responseBody ^? key "args") + +getHeaders site = do + let opts = defaults & header "X-Wibble" .~ ["bar"] + r <- getWith opts (site "/get") + assertEqual "extra header set correctly" + (Just "bar") + (r ^. responseBody ^? key "headers" . key "X-Wibble") + +getGzip site = do + r <- get (site "/gzip") + assertEqual "gzip decoded for us" (Just (Bool True)) + (r ^. responseBody ^? key "gzipped") + +headRedirect site = + assertThrows "HEAD of redirect throws exception" inspect $ + head_ (site "/redirect/3") + where inspect e = case e of + StatusCodeException status _ _ -> + let code = status ^. statusCode + in assertBool "code is redirect" + (code >= 300 && code < 400) + +redirectOverflow site = + assertThrows "GET with too many redirects throws exception" inspect $ + getWith (defaults & redirects .~ 3) (site "/redirect/5") + where inspect e = case e of TooManyRedirects _ -> return () + +invalidURL _site = do + let noProto (InvalidUrlException _ _) = return () + assertThrows "exception if no protocol" noProto (get "wheeee") + let noHost (InvalidDestinationHost _) = return () + assertThrows "exception if no host" noHost (get "http://") + +funkyScheme site = do + -- schemes are case insensitive, per RFC 3986 section 3.1 + let (scheme, rest) = break (==':') $ site "/get" + void . get $ map toUpper scheme <> rest + +cookiesSet site = do + r <- get (site "/cookies/set?x=y") + assertEqual "cookies are set correctly" (Just "y") + (r ^? responseCookie "x" . cookieValue) + +cookieSession site = Session.withSession $ \s -> do + void $ Session.get s (site "/cookies/set?foo=bar") + r <- Session.get s (site "/cookies") + assertEqual "cookies are set correctly" (Just "bar") + (r ^? responseCookie "foo" . cookieValue) + assertEqual "whee" (Just "bar") + (r ^. responseBody ^? key "cookies" . key "foo") + +getWithManager site = withManager $ \opts -> do + void $ getWith opts (site "/get?a=b") + void $ getWith opts (site "/get?b=c") + +assertThrows :: (Show e, Exception e) => String -> (e -> IO ()) -> IO a -> IO () +assertThrows desc inspect act = do + let myInspect e = inspect e `E.catch` \(ee :: E.PatternMatchFail) -> + assertFailure (desc <> ": unexpected exception (" <> + show e <> "): " <> show ee) + caught <- (act >> return False) `E.catch` \e -> myInspect e >> return True + unless caught (assertFailure desc) + +testsWith site = [ + testGroup "basic" [ + testCase "get" $ basicGet site + , testCase "post" $ basicPost site + , testCase "head" $ basicHead site + , testCase "put" $ basicPut site + , testCase "delete" $ basicDelete site + , testCase "404" $ throwsStatusCode site + , testCase "headRedirect" $ headRedirect site + , testCase "redirectOverflow" $ redirectOverflow site + , testCase "invalidURL" $ invalidURL site + , testCase "funkyScheme" $ funkyScheme site + ] + , testGroup "fancy" [ + testCase "basic auth" $ getBasicAuth site + , testCase "redirect" $ getRedirect site + , testCase "params" $ getParams site + , testCase "headers" $ getHeaders site + , testCase "gzip" $ getGzip site + , testCase "cookiesSet" $ cookiesSet site + , testCase "cookieSession" $ cookieSession site + , testCase "getWithManager" $ getWithManager site + ] + ] + +tests = [ + testGroup "http" $ testsWith ("http://httpbin.org" <>) + , testGroup "https" $ testsWith ("https://httpbin.org" <>) + ] + +main = defaultMain tests + +localtest = defaultMain (testsWith ("http://localhost:8000" <>)) diff --git a/wreq.cabal b/wreq.cabal new file mode 100644 --- /dev/null +++ b/wreq.cabal @@ -0,0 +1,157 @@ +name: wreq +version: 0.1.0.0 +synopsis: An easy-to-use HTTP client library. +description: + . + A web client library that is designed for ease of use. + . + Tutorial: + . + Features include: + . + * Simple but powerful `lens`-based API + . + * A solid test suite, and built on reliable libraries like + http-client and lens + . + * Session handling includes connection keep-alive and pooling, and + cookie persistence + . + * Automatic response body decompression + . + * Powerful multipart form and file upload handling + . + * Support for JSON requests and responses, including navigation of + schema-less responses + . + * Basic and OAuth2 bearer authentication + . + * Early TLS support via the tls package +homepage: http://www.serpentine.com/wreq +bug-reports: https://github.com/bos/wreq/issues +license: BSD3 +license-file: LICENSE.md +author: Bryan O'Sullivan +maintainer: bos@serpentine.com +copyright: 2014 Bryan O'Sullivan +category: Web +build-type: Custom +cabal-version: >=1.10 +extra-source-files: + README.md + TODO.md + changelog + examples/*.cabal + examples/*.hs + www/*.css + www/*.md + www/Makefile + +-- disable doctests with -f-doctest +flag doctest + default: True + manual: True + +-- enable httpbin with -fhttpbin +flag httpbin + default: False + manual: True + +library + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + default-language: Haskell98 + + exposed-modules: + Network.Wreq + Network.Wreq.Lens + Network.Wreq.Session + Network.Wreq.Types + other-modules: + Network.Wreq.Internal + Network.Wreq.Internal.Lens + Network.Wreq.Internal.Link + Network.Wreq.Internal.Types + Network.Wreq.Lens.TH + Network.Wreq.Lens.Machinery + Paths_wreq + build-depends: + aeson >= 0.7.0.3, + attoparsec, + base >= 4.5 && < 5, + bytestring >= 0.9, + exceptions >= 0.5, + http-client >= 0.3.1.1, + http-client-tls >= 0.2, + http-types >= 0.8, + lens >= 4.1, + mime-types, + template-haskell, + text, + time + +-- A convenient server for testing locally, or if httpbin.org is down. +executable httpbin + hs-source-dirs: httpbin + main-is: HttpBin.hs + ghc-options: -Wall -fwarn-tabs -threaded + default-language: Haskell98 + + if !flag(httpbin) + buildable: False + else + build-depends: + aeson >= 0.7, + aeson-pretty >= 0.7.1, + base >= 4.5 && < 5, + base64-bytestring, + bytestring, + case-insensitive, + containers, + snap-core, + snap-server >= 0.9.4.2, + text + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tests.hs + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded + default-language: Haskell98 + + build-depends: + HUnit, + aeson, + base >= 4.5 && < 5, + bytestring, + http-client, + http-types, + lens >= 4.1, + temporary, + test-framework, + test-framework-hunit, + text, + wreq + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: DocTests.hs + ghc-options: -Wall -fwarn-tabs -threaded + default-language: Haskell98 + + if !flag(doctest) + buildable: False + else + build-depends: + base >= 4.5 && < 5, + directory, + doctest, + filepath + +source-repository head + type: git + location: https://github.com/bos/wreq + +source-repository head + type: mercurial + location: https://bitbucket.org/bos/wreq diff --git a/www/Makefile b/www/Makefile new file mode 100644 --- /dev/null +++ b/www/Makefile @@ -0,0 +1,21 @@ +bootstrap := bootstrap-3.1.1-dist + +files := index.html tutorial.html +deps = bootstrap-custom.css background.jpg +install := $(files) $(deps) + +all: $(files) + +install: $(files) + -mkdir -p $(HOME)/public_html/wreq + cp -a $(install) $(HOME)/public_html/wreq + cp -a $(bootstrap) $(HOME)/public_html/wreq + +%.html: %.md template.html $(deps) + pandoc $< -o $@ --smart --template template.html \ + --css $(bootstrap)/css/bootstrap.css \ + --css bootstrap-custom.css \ + --toc --toc-depth 2 + +clean: + -rm -f $(files) diff --git a/www/bootstrap-custom.css b/www/bootstrap-custom.css new file mode 100644 --- /dev/null +++ b/www/bootstrap-custom.css @@ -0,0 +1,59 @@ +html { + position: relative; + min-height: 100%; +} +body { + /* Margin bottom by footer height */ + margin-bottom: 80px; +} +#footer { + position: absolute; + bottom: 0; + width: 100%; + /* Set the fixed height of the footer here */ + height: 80px; + background-color: #f5f5f5; +} + +a > code { color: #02d; } +a > code:hover { color: #44f; } +div.nav.bs-docs-sidenav > ul { list-style-type: none; } +div.nav.bs-docs-sidenav > ul > li > ul { list-style-type: none; } + +h1, h2, h3, h4 { + font-family: 'Roboto', 'sans-serif'; + margin-top: 40px; +} +p, div { + font-family: 'Roboto Slab', 'sans-serif'; +} + +.container .text-muted { + margin: 10px 0; +} + +.jumboback > .navbar { + background: rgba(0,0,0,0.4); + margin-bottom: 0; + text-shadow: none; + border: 0; + border-radius: 0; +} + +.jumboback > .navbar > a, .jumboback > .navbar > ul > li > a { + color: white; +} + +.jumboback > .jumbotron { + background: transparent; +} + +.jumboback { + background-image: url(background.jpg); + margin-bottom: 20px; + background-position: -20% 25%; + background-size: cover; + background-repeat: no-repeat; + color: white; + text-shadow: black 0em 0em 0.8em; +} diff --git a/www/index.md b/www/index.md new file mode 100644 --- /dev/null +++ b/www/index.md @@ -0,0 +1,134 @@ +% wreq: a Haskell web client library +% HTTP made easy for Haskell. + Tutorial + + + +`wreq` is a library that makes HTTP client programming in Haskell +easy. + + +# Features + +* Simple but powerful `lens`-based API + +* Over 100 tests, and built on reliable libraries like [`http-client`](http://hackage.haskell.org/package/http-client/) + and [`lens`](https://lens.github.io/) + +* Session handling includes connection keep-alive and pooling, and + cookie persistence + +* Automatic decompression + +* Powerful multipart form and file upload handling + +* Support for JSON requests and responses, including navigation of + schema-less responses + +* Basic and OAuth2 bearer authentication + + +# Whirlwind tour + +~~~~ {.haskell} +ghci> import Network.Wreq +ghci> r <- get "http://httpbin.org/get" +~~~~ + +Its `lens`-based API is easy to learn (the tutorial walks you through +the [basics of lenses](tutorial.html#a-quick-lens-backgrounder) and +powerful to work with. + +~~~~ {.haskell} +ghci> import Control.Lens +ghci> r ^. responseHeader "Content-Type" +"application/json" +~~~~ + +Safely and sanely add query parameters to URLs. Let's find the most +popular implementations of Tetris in Haskell. + +~~~~ {.haskell} +ghci> let opts = defaults & param "q" .~ ["tetris"] + & param "language" .~ ["haskell"] +ghci> r <- getWith opts "https://api.github.com/search/code" +~~~~ + +Haskell-to-JSON interoperation is seamless. + +~~~~ {.haskell} +ghci> import GHC.Generics +ghci> import Data.Aeson +ghci> :set -XDeriveGeneric + +ghci> data Addr = Addr Int String deriving (Generic) +ghci> instance ToJSON Addr + +ghci> let addr = Addr 1600 "Pennsylvania" +ghci> post "http://httpbin.org/post" (toJSON addr) +~~~~ + + +Work easily with schemaless JSON APIs. This traverses the complex +JSON search result we just received from GitHub above, and pulls out +the authors of our popular Tetris clones. + +~~~~ {.haskell} +ghci> r ^.. responseBody . key "items" . values . + key "owner" . key "login" . _String +["steffi2392","rmies","Spacejoker","walpen",{-...-} +~~~~ + +Easily write +[`attoparsec`](http://hackage.haskell.org/package/attoparsec) parsers +on the spot, to safely and reliably deal with complicated headers and +bodies. + +~~~~ {.haskell} +ghci> import Data.Attoparsec.ByteString.Char8 as A +ghci> import Data.List (sort) + +ghci> let comma = skipSpace >> "," >> skipSpace +ghci> let verbs = A.takeWhile isAlpha_ascii `sepBy` comma + +ghci> r <- options "http://httpbin.org/get" +ghci> r ^. responseHeader "Allow" . atto verbs . to sort +ghci> ["GET","HEAD","OPTIONS"] +~~~~ + +There's a lot more, but why not jump in and start coding. In fact, if +you'd like to add new features, that would be great! We love pull +requests. + + +
+

Ready to jump in?

+ +We've worked hard to make `wreq` quick to learn. + +Tutorial + +We're proud of the example-filled docs. + +Documentation + +If you run into problems, let us know. + +Issues + +
+ + +# Acknowledgments + +I'd like to thank Edward Kmett and Shachaf Ben-Kiki for tirelessly +answering my never-ending stream of +[lens](https://lens.github.io/)-related questions in `#haskell-lens#`. + +I also want to thank Michael Snoyman for being so quick with helpful +responses to bug reports and pull requests against his excellent +[http-client](http://hackage.haskell.org/package/http-client) package. + +Finally, thanks to Kenneth Reitz for building the indispensable +[httpbin.org](http://httpbin.org/) HTTP testing service, and of course +for his [requests library](http://docs.python-requests.org/en/latest/). diff --git a/www/tutorial.md b/www/tutorial.md new file mode 100644 --- /dev/null +++ b/www/tutorial.md @@ -0,0 +1,490 @@ +% A wreq tutorial +% Learn how to write web clients. We start easy, then ramp up the power. + +# Installation + +To use the `wreq` package, simply use `cabal`, the standard Haskell +package management command. + +~~~~ +cabal update +cabal install -j --disable-tests wreq +~~~~ + +Depending on how many prerequisites you already have installed, and +what your Cabal configuration looks like, the build may take a few +minutes: a few seconds for `wreq`, and the rest for its dependencies. + + +# Interactive usage + +We'll run our examples interactively via the `ghci` shell. + +~~~~ +$ ghci +~~~~ + +To start using `wreq`, we import the +[`Network.Wreq`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html) +module. + +~~~~ {.haskell} +ghci> import Network.Wreq +ghci> r <- get "http://httpbin.org/get" +ghci> :type r +r :: Response ByteString +~~~~ + +The variable `r` above is the +[`Response`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Response) +from the server. + + +## Working with string-like types + +Complex Haskell libraries and applications have to deal fluently with +Haskell's three main string types: `String` ("legacy"), `Text`, and +`ByteString` (mostly used for binary data, sometimes ASCII). + +To write string literals without having to always provide a conversion +function, we use the `OverloadedStrings` language extension. + +Throughout the rest of this tutorial, we'll assume that you have +enabled `OverloadedStrings` in `ghci`: + +~~~~ {.haskell} +ghci> :set -XOverloadedStrings +~~~~ + +If you're using `wreq` from a Haskell source file, put a pragma at the +top of your file: + +~~~~ {.haskell} +{-# LANGUAGE OverloadedStrings #-} +~~~~ + + +# A quick lens backgrounder + +The `wreq` package makes heavy use of Edward Kmett's +[`lens`](https://lens.github.io/) package to provide a clean, +consistent API. + +~~~~ {.haskell} +ghci> import Control.Lens +~~~~ + +While `lens` has a vast surface area, the portion that you must +understand in order to productively use `wreq` is tiny. + +A lens provides a way to focus on a portion of a Haskell value. For +example, the `Response` type has a +[`responseStatus`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:responseStatus) +lens, which focuses on the status information returned by the server. + +~~~~ {.haskell} +ghci> r ^. responseStatus +Status {statusCode = 200, statusMessage = "OK"} +~~~~ + +The +[`^.`](http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#v:-94-.) +operator takes a value as its first argument, a lens as its second, +and returns the portion of the value focused on by the lens. + +We compose lenses using function composition, which allows us to +easily focus on part of a deeply nested structure. + +~~~~ {.haskell} +ghci> r ^. responseStatus . statusCode +200 +~~~~ + +We'll have more to say about lenses as this tutorial proceeds. + + +# Changing default behaviours + +While +[`get`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:get) + is convenient and easy to use, there's a lot more power +available to us. + +For example, if we want to add parameters to the query string of a +URL, we will use the +[`getWith`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:getWith) +function. The `*With` family of functions all accept an +[`Options`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Options) +parameter that allow changes from the library's default behaviours. + +~~~~ {.haskell} +ghci> import Data.Aeson.Lens (_String, key) +ghci> let opts = defaults & param "foo" .~ ["bar", "quux"] +ghci> r <- getWith opts "http://httpbin.org" +ghci> r ^. responseBody . key "url" . _String +"http://httpbin.org/get?foo=bar&foo=quux" +~~~~ + +(We'll talk more about `key` and `_String` below.) + +The default parameters for all queries is represented by the variable +[`defaults`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:defaults). +(In fact, `get` is defined simply as `getWith defaults`.) + +Here's where we get to learn a little more about lenses. + +In addition to *getting* a value from a nested structure, we can also +*set* (edit) a value within a nested structure, which makes an +identical copy of the structure except for the portion we want to +modify. + +The `&` operator is just function application with its operands +reversed, so the function is on the right and its parameter is on the +left. + +~~~~ {.haskell} +parameter & functionToApply +~~~~ + +The +[`.~`](http://hackage.haskell.org/package/lens/docs/Control-Lens-Setter.html#v:.-126-) + operator turns a lens into a setter function, with the lens +on the left and the new value on the right. + +~~~~ {.haskell} +param "foo" .~ ["bar", "quux"] +~~~~ + +The +[`param`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:param) +lens focuses on the values associated with the given key in the +query string. + +~~~~ {.haskell} +param :: Text -> Lens' Options [Text] +~~~~ + +The reason we allow for a list of values instead of just a single +value is simply that this is completely legitimate. For instance, in +our example above we generate the query string `foo=bar&foo=quux`. + +If you use non-ASCII characters in a `param` key or value, they will +be encoded as UTF-8 before being URL-encoded, so that they can be +safely transmitted over the wire. + + +# Accessing the body of a response + +The +[`responseBody`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:responseBody) +lens gives us access to the body of a response. + +~~~~ {.haskell} +ghci> r <- get "http://httpbin.org/get" +ghci> r ^. responseBody +"{\n \"headers\": {\n \"Accept-Encoding\": \"gzip"{-...-} +~~~~ + +The response body is a raw lazy +[`ByteString`](http://hackage.haskell.org/package/bytestring/docs/Data-ByteString-Lazy.html#t:ByteString). + + +## JSON responses + +We can use the +[`asJSON`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:asJSON) +function to convert a response body to a Haskell value that implements +the +[`FromJSON`](http://hackage.haskell.org/package/aeson/docs/Data-Aeson-Types.html#t:FromJSON) +class. + +~~~~ {.haskell} +ghci> import Data.Map as Map +ghci> import Data.Aeson (Value) +ghci> type Resp = Response (Map String Value) +ghci> r <- asJSON =<< get "http://httpbin.org/get" :: IO Resp +ghci> Map.size (r ^. responseBody) +4 +~~~~ + +
+In this example, we have to tell `ghci` exactly what target type we +are expecting. In a real Haskell program, the correct return type will +usually be inferred automatically, making an explicit type signature +unnecessary in most cases. +
+ +If the response is not `application/json`, or we try to convert to an +incompatible Haskell type, a +[`JSONError`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:JSONError) +exception will be thrown. + +~~~~ {.haskell} +ghci> type Resp = Response [Int] +ghci> r <- asJSON =<< get "http://httpbin.org/get" :: IO Resp +*** Exception: JSONError "when expecting a [a], encountered Object instead" +~~~~ + + +## Convenient JSON traversal + +The `lens` package provides some extremely useful functions for +traversing JSON structures without having to either build a +corresponding Haskell type or traverse a `Value` by hand. + +The first of these is +[`key`](http://hackage.haskell.org/package/lens/docs/Data-Aeson-Lens.html#v:key), +which traverses to the named key in a JSON object. + +~~~~ {.haskell} +ghci> import Data.Aeson.Lens (key) +ghci> r <- get "http://httpbin.org/get" +ghci> r ^? responseBody . key "url" +Just (String "http://httpbin.org/get") +~~~~ + +
+Notice our use of the +[`^?`](http://hackage.haskell.org/package/lens-4.1.2/docs/Control-Lens-Fold.html#v:-94--63-) +operator here. This is like `^.`, but it allows for the possibility +that an access might fail---and of course there may not be a key named +`"url"` in our object. +
+ +That said, our result above has the type `Maybe Value`, so it's quite +annoying to work with. This is where the `_String` lens comes in. + +~~~~ {.haskell} +ghci> import Data.Aeson.Lens (_String, key) +ghci> r <- get "http://httpbin.org/get" +ghci> r ^. responseBody . key "url" . _String +"http://httpbin.org/get" +~~~~ + +If the key exists, and is a `Value` with a `String` constructor, +`_String` gives us back a regular `Text` value with all the wrappers +removed; otherwise it gives an empty value. Notice what happens as we +switch between `^?` and `^.` in these examples. + +~~~~ {.haskell} +ghci> r ^. responseBody . key "fnord" . _String +"" +ghci> r ^? responseBody . key "fnord" . _String +Nothing +ghci> r ^? responseBody . key "url" . _String +Just "http://httpbin.org/get" +~~~~ + + +# Working with headers + +To add headers to a request, we use the +[`header`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:header) +lens. + +~~~~ {.haskell} +ghci> let opts = defaults & header "Accept" .~ ["application/json"] +ghci> getWith opts "http://httpbin.org/get" +~~~~ + +As with the [`param`](#param) lens, if we provide more than one value to go +with a single key, this will expand to several headers. + +~~~~ {.haskell} +header :: HeaderName -> Lens' Options [ByteString] +~~~~ + +When we want to inspect the headers of a response, we use the +[`responseHeader`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:responseHeader) +lens. + +~~~~ {.haskell} +ghci> r <- get "http://httpbin.org/get" +ghci> r ^. responseHeader "content-type" +"application/json" +~~~~ + +
+Header names are case insensitive. +
+ +If a header is not present in a response, then `^.` will give an empty +string, while `^?` will give `Nothing`. + +~~~~ {.haskell} +ghci> r ^. responseHeader "X-Nonesuch" +"" +ghci> r ^? responseHeader "X-Nonesuch" +Nothing +~~~~ + + +# Uploading data via POST + +We use the [`post`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:post) + and + [`postWith`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:postWith) + functions to issue POST requests. + +~~~~ {.haskell} +ghci> r <- post "http://httpbin.org/post" ["num" := 3, "str" := "wat"] +ghci> r ^? responseBody . key "form" +Just (Object fromList [("num",String "3"),("str",String "wat")]) +~~~~ + +The [httpbin.org](http://httpbin.org/) server conveniently echoes our +request headers back at us, so we can see what kind of body we POSTed. + +~~~~ {.haskell} +ghci> r ^. responseBody . key "headers" . key "Content-Type" . _String +"application/x-www-form-urlencoded" +~~~~ + +The +[`:=`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v::-61-) +operator is the constructor for the +[`FormParam`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:FormParam) +type, which `wreq` uses as a key/value pair to generate an +`application/x-www-form-urlencoded` form body to upload. + +A class named +[`FormValue`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:FormValue) +determines how the operand on the right-hand side of `:=` is encoded, +with sensible default behaviours for strings and numbers. + +The slightly more modern way to upload POST data is via a +`multipart/form-data` payload, for which `wreq` provides the +[`Part`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:Part) +type. + +~~~~ {.haskell} +ghci> r <- post "http://httpbin.org/post" [partText "button" "o hai"] +ghci> r ^. responseBody . key "headers" . key "Content-Type" . _String +"multipart/form-data; boundary=----WebKitFormBoundaryJsEZfuj89uj" +~~~~ + +The first argument to these `part*` functions is the label of the +`` element in the form being uploaded. + +Let's inspect httpbin.org's response to see what we uploaded. When we +think there could be more than one value associated with a lens, we +use the +[`^..`](http://hackage.haskell.org/package/lens-4.1.2/docs/Control-Lens-Fold.html#v:-94-..) +operator, which returns a list. + +~~~~ {.haskell} +ghci> r ^.. responseBody . key "form" +[Object fromList [("button",String "o hai")]] +~~~~ + + +## Uploading file contents + +To upload a file as part of a `multipart/form-data` POST, we use +[`partFile`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:partFile), +or if the file is large enough that we want to stream its contents, +[`partFileSource`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#t:partFileSource). + +~~~~ {.haskell} +ghci> r <- post "http://httpbin.org/post" (partFile "file" "hello.hs") +ghci> r ^.. responseBody . key "files" . members . _String +["main = putStrLn \"hello\"\n"] +~~~~ + +Both `partFile` and `partFileSource` will set the filename of a part +to whatever name they are given (including any leading path components +such as `/tmp/confidential`), and guess its content-type based on the +file name extension. Here's an example of how we can upload a file +without revealing its name. + +~~~~ {.haskell} +ghci> partFile "label" "foo.hs" & partFileName .~ Nothing +Part "label" Nothing (Just "text/plain") +~~~~ + + +# Cookies + +To see how easily we can work with cookies, let's can ask the +ever-valuable httpbin.org to set a cookie in a response. + +~~~~ {.haskell} +ghci> r <- get "http://httpbin.org/cookies/set?foo=bar" +ghci> r ^. responseCookie "foo" . cookieValue +"bar" +~~~~ + + +# Authentication + +The `wreq` library supports both basic authentication and OAuth2 +bearer authentication. + +
+**Note:** the security of these mechanisms is _absolutely dependent on +your use of TLS_, as the credentials can easily be stolen and reused +if transmitted unencrypted. +
+ +If we try to access a service that requires authentication, `wreq` +will throw a +[`HttpException`](http://hackage.haskell.org/package/http-client/docs/Network-HTTP-Client.html#t:HttpException). + +~~~~ {.haskell} +ghci> r <- get "http://httpbin.org/basic-auth/user/pass +*** Exception: StatusCodeException (Status {statusCode = 401, {-...-} +~~~~ + +If we then supply a username and password, our request will succeed. +(Notice that we follow our own advice: we switch to `https` for our +retry.) + +~~~~ {.haskell} +ghci> let opts = defaults & auth .~ basicAuth "user" "pass" +ghci> r <- getWith opts "https://httpbin.org/basic-auth/user/pass" +ghci> r ^. responseBody +"{\n \"authenticated\": true,\n \"user\": \"user\"\n}" +~~~~ + +For OAuth2 bearer authentication, `wreq` supports two flavours: +[`oauth2Bearer`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:oauth2Bearer) +is the standard bearer token, while +[`oauth2Token`](http://hackage.haskell.org/package/wreq/docs/Network-Wreq.html#v:oauth2Token) +is GitHub's variant. These tokens are equivalent in value to a +username and password. + + +# Error handling + +Most of the time when an error occurs or a request fails, `wreq` will +throw a `HttpException`. + +~~~~ {.haskell} +h> r <- get "http://httpbin.org/wibblesticks" +*** Exception: StatusCodeException (Status {statusCode = 404, {-...-} +~~~~ + +Here's a simple example of how we can respond to one kind of error: a +`get`-like function that retries with authentication if an +unauthenticated request fails. + +~~~~ {.haskell} +import Control.Exception as E +import Control.Lens +import Network.HTTP.Client +import Network.Wreq + +getAuth url myauth = get url `E.catch` handler + where + handler e@(StatusCodeException s _ _) + | s ^. statusCode == 401 = getWith authopts authurl + | otherwise = throwIO e + where authopts = defaults & auth .~ myauth + -- switch to TLS when we use auth + authurl = "https" ++ dropWhile (/=':') url +~~~~ + +(A "real world" version would remember which URLs required +authentication during a session, to avoid the need for an +unauthenticated failure followed by an authenticated success if we +visit the same endpoint repeatedly.)