diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -26,11 +26,11 @@ import qualified Data.ByteString as BS -- Using shortcuts -resp <- get "https://api.leancloud.cn/1.1/date" +resp <- get "https://httpbin.org/uuid" :: IO (Response String) print resp.status -- 200 -- Or construct a Request manually -let req = Request { method = GET, url = "https://api.leancloud.cn/1.1/date", headers = [], body = () } +let req = Request { method = GET, url = "https://httpbin.org/uuid", headers = [], body = () } -- Response with ByteString body responseBS <- send req :: IO (Response BS.ByteString) @@ -64,6 +64,7 @@ - `()` → empty body, no Content-Type - `ByteString` / lazy `ByteString` / `Text` / `String` → `text/plain; charset=utf-8` - Any type with a `ToJSON` instance → auto JSON encoding + `application/json` +- `Form a` (where `a` has a `ToForm` instance) → URL-encoded + `application/x-www-form-urlencoded` The `Content-Type` is automatically inferred from the body type. You can override it by setting the header manually: @@ -110,18 +111,17 @@ import Data.Aeson (FromJSON) import GHC.Generics (Generic) -data Date = Date - { __type :: String - , iso :: String +data UUID = UUID + { uuid :: String } deriving (Show, Generic) -instance FromJSON Date +instance FromJSON UUID main :: IO () main = do - response <- get "https://api.leancloud.cn/1.1/date" :: IO (Response Date) + response <- get "https://httpbin.org/uuid" :: IO (Response UUID) print response.status -- 200 - print response.body -- Date { __type = "Date", iso = "..." } + print response.body -- UUID { uuid = "550e8400-e29b-41d4-a716-446655440000" } ``` If JSON decoding fails, an `AesonException` will be thrown, which can be caught with `Control.Exception.catch` or `try`. @@ -147,6 +147,70 @@ print response.status -- 200 ``` +## Form Support + +For `application/x-www-form-urlencoded` requests (login forms, OAuth token endpoints, classic web APIs), wrap your body in the `Form` newtype. The `Content-Type` is set automatically and values are percent-encoded. + +### From a list of pairs + +```haskell +import Network.HTTP.Request + +main :: IO () +main = do + response <- post "https://httpbin.org/post" + (Form [("username", "alice"), ("password", "s3cret")]) + :: IO (Response String) + print response.status -- 200 + -- Body sent: username=alice&password=s3cret +``` + +Values are `ByteString` keys and values. Special characters (spaces, Unicode, reserved chars) are percent-encoded for you: + +```haskell +post "https://api.example.com/search" + (Form [("q", "hello world"), ("lang", "zh-CN")]) +-- Body sent: q=hello%20world&lang=zh-CN +``` + +### From a custom type + +For your own record types, define a `ToForm` instance. This mirrors the `ToJSON` pattern: + +```haskell +import Network.HTTP.Request +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +data Login = Login + { username :: T.Text + , password :: T.Text + } + +instance ToForm Login where + toForm l = [ ("username", T.encodeUtf8 l.username) + , ("password", T.encodeUtf8 l.password) + ] + +main :: IO () +main = do + response <- post "https://api.example.com/login" + (Form (Login "alice" "s3cret")) + :: IO (Response String) + print response.status +``` + +### The two new pieces of API + +```haskell +class ToForm a where + toForm :: a -> [(ByteString, ByteString)] + +newtype Form a = Form a +``` + +The `Form` newtype is required to disambiguate the form-encoding path from JSON. Without it, a type that has both `ToJSON` and `ToForm` instances would be ambiguous; with it, `post url x` always means JSON and `post url (Form x)` always means form. + ## Shortcuts As you expected, there are some shortcuts for the most used scenarios. @@ -161,6 +225,20 @@ These shortcuts' definitions are simple and direct. You are encouraged to add your own if the built-in does not match your use cases, like add custom headers in every request. +## Authentication + +Use `basicAuth` or `bearerAuth` to add an `Authorization` header to a request: + +```haskell +let basicReq = basicAuth "username" "password" (Request GET url [] ()) +basicResponse <- send basicReq :: IO (Response String) + +let bearerReq = bearerAuth "token" (Request GET url [] ()) +bearerResponse <- send bearerReq :: IO (Response String) +``` + +Both helpers replace an existing `Authorization` header, regardless of the header name's casing. + ## Without Language Extensions If you prefer not to use the language extensions, you can still use the library with the traditional syntax: @@ -170,12 +248,11 @@ ```haskell import Network.HTTP.Request -import qualified Data.ByteString as BS -- Construct a Request using positional arguments -let req = Request GET "https://api.leancloud.cn/1.1/date" [] () +let req = Request GET "https://httpbin.org/uuid" [] () -- Send it -res <- send req +res <- send req :: IO (Response String) -- Access the fields using prefixed accessor functions print $ responseStatus res ``` diff --git a/request.cabal b/request.cabal --- a/request.cabal +++ b/request.cabal @@ -1,5 +1,5 @@ name: request -version: 0.4.1.0 +version: 0.4.2.0 -- synopsis: description: "HTTP client for haskell, inpired by requests and http-dispatch." homepage: https://github.com/aisk/request#readme @@ -16,8 +16,14 @@ library hs-source-dirs: src exposed-modules: Network.HTTP.Request + other-modules: Network.HTTP.Request.Internal.Auth + , Network.HTTP.Request.Internal.Body + , Network.HTTP.Request.Internal.Client + , Network.HTTP.Request.Internal.Sse + , Network.HTTP.Request.Internal.Types build-depends: base >= 4.7 && < 5 , aeson >= 2.0 && < 2.3 + , base64-bytestring >= 1.2 && < 1.3 , bytestring >= 0.10.12 && < 0.13 , case-insensitive >= 1.2.1 && < 1.3 , http-client >= 0.6.4 && < 0.8 diff --git a/src/Network/HTTP/Request.hs b/src/Network/HTTP/Request.hs --- a/src/Network/HTTP/Request.hs +++ b/src/Network/HTTP/Request.hs @@ -1,22 +1,21 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} module Network.HTTP.Request ( Header, Headers, FromResponseBody (..), ToRequestBody (..), + ToForm (..), + Form (..), Manager, Method (..), Request (..), Response (..), + ResponseBodyException (..), StreamBody (..), SseEvent (..), + basicAuth, + bearerAuth, get, delete, patch, @@ -35,301 +34,38 @@ ) where -import Control.Exception (throwIO) -import Data.Aeson (AesonException (..), FromJSON, ToJSON, eitherDecode, encode) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as LBS -import qualified Data.CaseInsensitive as CI -import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) -import Data.Maybe (listToMaybe, mapMaybe) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.HTTP.Client (Manager) -import qualified Network.HTTP.Client as LowLevelClient -import qualified Network.HTTP.Client.TLS as LowLevelTLSClient -import qualified Network.HTTP.Types.Status as LowLevelStatus - -type Header = (BS.ByteString, BS.ByteString) - -type Headers = [Header] - -class FromResponseBody a where - fromResponseBody :: LBS.ByteString -> Either String a - - buildResponse :: LowLevelClient.Request -> LowLevelClient.Manager -> IO (Response a) - buildResponse llreq manager = do - llres <- LowLevelClient.httpLbs llreq manager - case fromLowLevelResponse llres of - Right res -> return res - Left err -> throwIO (AesonException err) - -instance FromResponseBody BS.ByteString where - fromResponseBody = Right . LBS.toStrict - -instance FromResponseBody LBS.ByteString where - fromResponseBody = Right - -instance FromResponseBody T.Text where - fromResponseBody = Right . T.decodeUtf8Lenient . LBS.toStrict - -instance FromResponseBody String where - fromResponseBody = Right . T.unpack . T.decodeUtf8Lenient . LBS.toStrict - -instance {-# OVERLAPPABLE #-} (FromJSON a) => FromResponseBody a where - fromResponseBody = eitherDecode - -data StreamBody a = StreamBody - { readNext :: IO (Maybe a), - closeStream :: IO () - } - -data SseEvent = SseEvent - { sseData :: T.Text, - sseType :: Maybe T.Text, - sseId :: Maybe T.Text - } - deriving (Show) - -findEventSep :: BS.ByteString -> Maybe (Int, Int) -findEventSep bs = - foldr - earlier - Nothing - [ tryFind "\r\n\r\n" 4, - tryFind "\n\n" 2, - tryFind "\r\r" 2 - ] - where - tryFind pat sepLen = - let (h, t) = BS.breakSubstring pat bs - in if BS.null t then Nothing else Just (BS.length h, BS.length h + sepLen) - earlier a Nothing = a - earlier Nothing b = b - earlier a@(Just (s1, _)) b@(Just (s2, _)) = if s1 <= s2 then a else b - -parseSseField :: T.Text -> Maybe (T.Text, T.Text) -parseSseField line - | T.null line = Nothing - | T.head line == ':' = Nothing - | otherwise = - let (name, rest) = T.breakOn ":" line - value - | T.null rest = "" - | otherwise = case T.stripPrefix " " (T.drop 1 rest) of - Just v -> v - Nothing -> T.drop 1 rest - in Just (name, value) - -parseSseBlock :: BS.ByteString -> SseEvent -parseSseBlock block = - let txt = T.replace "\r" "\n" . T.replace "\r\n" "\n" $ T.decodeUtf8Lenient block - ls = T.lines txt - fields = mapMaybe parseSseField ls - dataVal = T.intercalate "\n" [v | (k, v) <- fields, k == "data"] - typeVal = listToMaybe [v | (k, v) <- fields, k == "event"] - idVal = listToMaybe [v | (k, v) <- fields, k == "id"] - in SseEvent dataVal typeVal idVal - -instance FromResponseBody (StreamBody BS.ByteString) where - fromResponseBody _ = Left "StreamBody must be built via buildResponse" - - buildResponse llreq manager = do - llres <- LowLevelClient.responseOpen llreq manager - let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ llres - hdrs = map (\(k, v) -> (CI.original k, v)) (LowLevelClient.responseHeaders llres) - readNext = do - chunk <- LowLevelClient.brRead (LowLevelClient.responseBody llres) - return $ if BS.null chunk then Nothing else Just chunk - return $ Response status hdrs (StreamBody readNext (LowLevelClient.responseClose llres)) - -instance FromResponseBody (StreamBody SseEvent) where - fromResponseBody _ = Left "StreamBody must be built via buildResponse" - - buildResponse llreq manager = do - llres <- LowLevelClient.responseOpen llreq manager - bufRef <- newIORef BS.empty - let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ llres - hdrs = map (\(k, v) -> (CI.original k, v)) (LowLevelClient.responseHeaders llres) - readNext = do - buf <- readIORef bufRef - case findEventSep buf of - Just (blockEnd, afterSep) -> do - writeIORef bufRef (BS.drop afterSep buf) - return $ Just (parseSseBlock (BS.take blockEnd buf)) - Nothing -> do - chunk <- LowLevelClient.brRead (LowLevelClient.responseBody llres) - if BS.null chunk - then - if BS.null buf - then return Nothing - else do - writeIORef bufRef BS.empty - return $ Just (parseSseBlock buf) - else do - modifyIORef bufRef (<> chunk) - readNext - return $ Response status hdrs (StreamBody readNext (LowLevelClient.responseClose llres)) - -class ToRequestBody a where - toRequestBody :: a -> BS.ByteString - requestContentType :: a -> Maybe BS.ByteString - requestContentType _ = Nothing - -instance ToRequestBody BS.ByteString where - toRequestBody = id - requestContentType _ = Just "text/plain; charset=utf-8" - -instance ToRequestBody LBS.ByteString where - toRequestBody = LBS.toStrict - requestContentType _ = Just "text/plain; charset=utf-8" - -instance ToRequestBody T.Text where - toRequestBody = T.encodeUtf8 - requestContentType _ = Just "text/plain; charset=utf-8" - -instance ToRequestBody String where - toRequestBody = T.encodeUtf8 . T.pack - requestContentType _ = Just "text/plain; charset=utf-8" - -instance {-# OVERLAPPABLE #-} (ToJSON a) => ToRequestBody a where - toRequestBody = LBS.toStrict . encode - requestContentType _ = Just "application/json" - -instance ToRequestBody () where - toRequestBody () = BS.empty - requestContentType () = Nothing - -data Method - = DELETE - | GET - | HEAD - | OPTIONS - | PATCH - | POST - | PUT - | TRACE - | Method String - deriving (Show, Eq) - -methodToByteString :: Method -> BS.ByteString -methodToByteString DELETE = "DELETE" -methodToByteString GET = "GET" -methodToByteString HEAD = "HEAD" -methodToByteString OPTIONS = "OPTIONS" -methodToByteString PATCH = "PATCH" -methodToByteString POST = "POST" -methodToByteString PUT = "PUT" -methodToByteString TRACE = "TRACE" -methodToByteString (Method m) = C.pack m - -data Request a = Request - { method :: Method, - url :: String, - headers :: Headers, - body :: a - } - deriving (Show) - --- Compatibility accessor functions -requestMethod :: Request a -> Method -requestMethod req = req.method - -requestUrl :: Request a -> String -requestUrl req = req.url - -requestHeaders :: Request a -> Headers -requestHeaders req = req.headers - -requestBody :: Request a -> a -requestBody req = req.body - -toLowlevelRequest :: (ToRequestBody a) => Request a -> IO LowLevelClient.Request -toLowlevelRequest req = do - initReq <- LowLevelClient.parseRequest req.url - let autoContentType = requestContentType req.body - hasContentType = any (\(k, _) -> k == "Content-Type") req.headers - hasUserAgent = any (\(k, _) -> CI.mk k == CI.mk ("User-Agent" :: BS.ByteString)) req.headers - defaultUserAgent = C.pack $ "haskell-request/" <> VERSION_request - extraContentType = - maybe [] (\c -> [("Content-Type", c)]) $ - if hasContentType then Nothing else autoContentType - extraUserAgent = - if hasUserAgent - then [] - else [("User-Agent", defaultUserAgent)] - return $ - initReq - { LowLevelClient.method = methodToByteString req.method, - LowLevelClient.requestHeaders = map (\(k, v) -> (CI.mk k, v)) (req.headers ++ extraContentType ++ extraUserAgent), - LowLevelClient.requestBody = LowLevelClient.RequestBodyBS (toRequestBody req.body) - } - -data Response a = Response - { status :: Int, - headers :: Headers, - body :: a - } - deriving (Show) - --- Compatibility accessor functions for Response -responseStatus :: Response a -> Int -responseStatus res = res.status - -responseHeaders :: Response a -> Headers -responseHeaders res = res.headers - -responseBody :: Response a -> a -responseBody res = res.body - -fromLowLevelResponse :: (FromResponseBody a) => LowLevelClient.Response LBS.ByteString -> Either String (Response a) -fromLowLevelResponse res = - let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ res - headers = LowLevelClient.responseHeaders res - in case fromResponseBody $ LowLevelClient.responseBody res of - Right body -> - Right $ - Response - status - ( map - ( \(k, v) -> - let hk = CI.original k - in (hk, v) - ) - headers - ) - body - Left err -> Left err - -newManager :: IO Manager -newManager = LowLevelTLSClient.newTlsManager - -sendWith :: (ToRequestBody a, FromResponseBody b) => Manager -> Request a -> IO (Response b) -sendWith manager req = do - llreq <- toLowlevelRequest req - buildResponse llreq manager - -send :: (ToRequestBody a, FromResponseBody b) => Request a -> IO (Response b) -send req = do - manager <- LowLevelTLSClient.getGlobalManager - sendWith manager req - -get :: (FromResponseBody a) => String -> IO (Response a) -get url = - send $ Request GET url [] () - -delete :: (FromResponseBody a) => String -> IO (Response a) -delete url = - send $ Request DELETE url [] () - -post :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b) -post url body = - send $ Request POST url [] body - -put :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b) -put url body = - send $ Request PUT url [] body - -patch :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b) -patch url body = - send $ Request PATCH url [] body +import Network.HTTP.Request.Internal.Auth (basicAuth, bearerAuth) +import Network.HTTP.Request.Internal.Body + ( Form (..), + FromResponseBody (..), + ResponseBodyException (..), + ToForm (..), + ToRequestBody (..), + ) +import Network.HTTP.Request.Internal.Client + ( Manager, + delete, + get, + newManager, + patch, + post, + put, + send, + sendWith, + ) +import Network.HTTP.Request.Internal.Types + ( Header, + Headers, + Method (..), + Request (..), + Response (..), + SseEvent (..), + StreamBody (..), + requestBody, + requestHeaders, + requestMethod, + requestUrl, + responseBody, + responseHeaders, + responseStatus, + ) diff --git a/src/Network/HTTP/Request/Internal/Auth.hs b/src/Network/HTTP/Request/Internal/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Request/Internal/Auth.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP.Request.Internal.Auth + ( basicAuth, + bearerAuth, + ) +where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.CaseInsensitive as CI +import Network.HTTP.Request.Internal.Types + ( Request (..), + requestBody, + requestHeaders, + requestMethod, + requestUrl, + ) + +basicAuth :: BS.ByteString -> BS.ByteString -> Request a -> Request a +basicAuth username password = + setAuthorizationHeader ("Basic " <> Base64.encode (username <> ":" <> password)) + +bearerAuth :: BS.ByteString -> Request a -> Request a +bearerAuth token = setAuthorizationHeader ("Bearer " <> token) + +setAuthorizationHeader :: BS.ByteString -> Request a -> Request a +setAuthorizationHeader value req = + Request + (requestMethod req) + (requestUrl req) + ( ("Authorization", value) + : filter (\(name, _) -> CI.mk name /= CI.mk ("Authorization" :: BS.ByteString)) (requestHeaders req) + ) + (requestBody req) diff --git a/src/Network/HTTP/Request/Internal/Body.hs b/src/Network/HTTP/Request/Internal/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Request/Internal/Body.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Network.HTTP.Request.Internal.Body + ( FromResponseBody (..), + ToRequestBody (..), + ToForm (..), + Form (..), + ResponseBodyException (..), + ) +where + +import Control.Exception (Exception, SomeException, throwIO, toException) +import Data.Aeson (AesonException (..), FromJSON, ToJSON, eitherDecode, encode) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) +import Data.Proxy (Proxy (..)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Client as LowLevelClient +import Network.HTTP.Request.Internal.Sse (findEventSep, parseSseBlock) +import Network.HTTP.Request.Internal.Types (Response (..), SseEvent, StreamBody (..)) +import qualified Network.HTTP.Types.Status as LowLevelStatus +import Network.HTTP.Types.URI (renderSimpleQuery) + +newtype ResponseBodyException = ResponseBodyException String + deriving (Show) + +instance Exception ResponseBodyException + +class FromResponseBody a where + fromResponseBody :: LBS.ByteString -> Either String a + + responseBodyException :: proxy a -> String -> SomeException + responseBodyException _ = toException . ResponseBodyException + + buildResponse :: LowLevelClient.Request -> LowLevelClient.Manager -> IO (Response a) + buildResponse llreq manager = do + llres <- LowLevelClient.httpLbs llreq manager + case fromLowLevelResponse llres of + Right res -> return res + Left err -> throwIO (responseBodyException (Proxy :: Proxy a) err) + +instance FromResponseBody BS.ByteString where + fromResponseBody = Right . LBS.toStrict + +instance FromResponseBody LBS.ByteString where + fromResponseBody = Right + +instance FromResponseBody T.Text where + fromResponseBody = Right . T.decodeUtf8Lenient . LBS.toStrict + +instance FromResponseBody String where + fromResponseBody = Right . T.unpack . T.decodeUtf8Lenient . LBS.toStrict + +instance {-# OVERLAPPABLE #-} (FromJSON a) => FromResponseBody a where + fromResponseBody = eitherDecode + responseBodyException _ = toException . AesonException + +instance FromResponseBody (StreamBody BS.ByteString) where + fromResponseBody _ = Left "StreamBody must be built via buildResponse" + + buildResponse llreq manager = do + llres <- LowLevelClient.responseOpen llreq manager + let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ llres + hdrs = map (\(k, v) -> (CI.original k, v)) (LowLevelClient.responseHeaders llres) + readNext = do + chunk <- LowLevelClient.brRead (LowLevelClient.responseBody llres) + return $ if BS.null chunk then Nothing else Just chunk + return $ Response status hdrs (StreamBody readNext (LowLevelClient.responseClose llres)) + +instance FromResponseBody (StreamBody SseEvent) where + fromResponseBody _ = Left "StreamBody must be built via buildResponse" + + buildResponse llreq manager = do + llres <- LowLevelClient.responseOpen llreq manager + bufRef <- newIORef BS.empty + let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ llres + hdrs = map (\(k, v) -> (CI.original k, v)) (LowLevelClient.responseHeaders llres) + readNext = do + buf <- readIORef bufRef + case findEventSep buf of + Just (blockEnd, afterSep) -> do + writeIORef bufRef (BS.drop afterSep buf) + case parseSseBlock (BS.take blockEnd buf) of + Just event -> return (Just event) + Nothing -> readNext + Nothing -> do + chunk <- LowLevelClient.brRead (LowLevelClient.responseBody llres) + if BS.null chunk + then + if BS.null buf + then return Nothing + else do + writeIORef bufRef BS.empty + return (parseSseBlock buf) + else do + modifyIORef bufRef (<> chunk) + readNext + return $ Response status hdrs (StreamBody readNext (LowLevelClient.responseClose llres)) + +class ToRequestBody a where + toRequestBody :: a -> BS.ByteString + requestContentType :: a -> Maybe BS.ByteString + requestContentType _ = Nothing + +instance ToRequestBody BS.ByteString where + toRequestBody = id + requestContentType _ = Just "text/plain; charset=utf-8" + +instance ToRequestBody LBS.ByteString where + toRequestBody = LBS.toStrict + requestContentType _ = Just "text/plain; charset=utf-8" + +instance ToRequestBody T.Text where + toRequestBody = T.encodeUtf8 + requestContentType _ = Just "text/plain; charset=utf-8" + +instance ToRequestBody String where + toRequestBody = T.encodeUtf8 . T.pack + requestContentType _ = Just "text/plain; charset=utf-8" + +instance {-# OVERLAPPABLE #-} (ToJSON a) => ToRequestBody a where + toRequestBody = LBS.toStrict . encode + requestContentType _ = Just "application/json" + +instance ToRequestBody () where + toRequestBody () = BS.empty + requestContentType () = Nothing + +class ToForm a where + toForm :: a -> [(BS.ByteString, BS.ByteString)] + +instance (k ~ BS.ByteString, v ~ BS.ByteString) => ToForm [(k, v)] where + toForm = id + +newtype Form a = Form a + +instance (ToForm a) => ToRequestBody (Form a) where + toRequestBody (Form a) = renderSimpleQuery False (toForm a) + requestContentType _ = Just "application/x-www-form-urlencoded" + +fromLowLevelResponse :: (FromResponseBody a) => LowLevelClient.Response LBS.ByteString -> Either String (Response a) +fromLowLevelResponse res = + let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ res + headers = LowLevelClient.responseHeaders res + in case fromResponseBody $ LowLevelClient.responseBody res of + Right body -> + Right $ + Response + status + (map (\(k, v) -> (CI.original k, v)) headers) + body + Left err -> Left err diff --git a/src/Network/HTTP/Request/Internal/Client.hs b/src/Network/HTTP/Request/Internal/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Request/Internal/Client.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP.Request.Internal.Client + ( Manager, + newManager, + send, + sendWith, + get, + delete, + patch, + post, + put, + ) +where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import qualified Data.CaseInsensitive as CI +import Network.HTTP.Client (Manager) +import qualified Network.HTTP.Client as LowLevelClient +import qualified Network.HTTP.Client.TLS as LowLevelTLSClient +import Network.HTTP.Request.Internal.Body (FromResponseBody (..), ToRequestBody (..)) +import Network.HTTP.Request.Internal.Types + ( Method (..), + Request (..), + Response, + requestBody, + requestHeaders, + requestMethod, + requestUrl, + ) + +methodToByteString :: Method -> BS.ByteString +methodToByteString DELETE = "DELETE" +methodToByteString GET = "GET" +methodToByteString HEAD = "HEAD" +methodToByteString OPTIONS = "OPTIONS" +methodToByteString PATCH = "PATCH" +methodToByteString POST = "POST" +methodToByteString PUT = "PUT" +methodToByteString TRACE = "TRACE" +methodToByteString (Method m) = C.pack m + +toLowlevelRequest :: (ToRequestBody a) => Request a -> IO LowLevelClient.Request +toLowlevelRequest req = do + initReq <- LowLevelClient.parseRequest (requestUrl req) + let body = requestBody req + headers = requestHeaders req + autoContentType = requestContentType body + hasContentType = any (\(k, _) -> CI.mk k == CI.mk ("Content-Type" :: BS.ByteString)) headers + hasUserAgent = any (\(k, _) -> CI.mk k == CI.mk ("User-Agent" :: BS.ByteString)) headers + defaultUserAgent = C.pack $ "haskell-request/" <> VERSION_request + extraContentType = + maybe [] (\c -> [("Content-Type", c)]) $ + if hasContentType then Nothing else autoContentType + extraUserAgent = + if hasUserAgent + then [] + else [("User-Agent", defaultUserAgent)] + return $ + initReq + { LowLevelClient.method = methodToByteString (requestMethod req), + LowLevelClient.requestHeaders = map (\(k, v) -> (CI.mk k, v)) (headers ++ extraContentType ++ extraUserAgent), + LowLevelClient.requestBody = LowLevelClient.RequestBodyBS (toRequestBody body) + } + +newManager :: IO Manager +newManager = LowLevelTLSClient.newTlsManager + +sendWith :: (ToRequestBody a, FromResponseBody b) => Manager -> Request a -> IO (Response b) +sendWith manager req = do + llreq <- toLowlevelRequest req + buildResponse llreq manager + +send :: (ToRequestBody a, FromResponseBody b) => Request a -> IO (Response b) +send req = do + manager <- LowLevelTLSClient.getGlobalManager + sendWith manager req + +get :: (FromResponseBody a) => String -> IO (Response a) +get url = send $ Request GET url [] () + +delete :: (FromResponseBody a) => String -> IO (Response a) +delete url = send $ Request DELETE url [] () + +post :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b) +post url body = send $ Request POST url [] body + +put :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b) +put url body = send $ Request PUT url [] body + +patch :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b) +patch url body = send $ Request PATCH url [] body diff --git a/src/Network/HTTP/Request/Internal/Sse.hs b/src/Network/HTTP/Request/Internal/Sse.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Request/Internal/Sse.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP.Request.Internal.Sse + ( findEventSep, + parseSseBlock, + ) +where + +import qualified Data.ByteString as BS +import Data.List (foldl') +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Request.Internal.Types (SseEvent (..)) + +findEventSep :: BS.ByteString -> Maybe (Int, Int) +findEventSep bs = + foldr + earlier + Nothing + [ tryFind "\r\n\r\n", + tryFind "\r\n\n", + tryFind "\r\n\r", + tryFind "\n\r\n", + tryFind "\n\n", + tryFind "\n\r", + tryFind "\r\r\n", + tryFind "\r\r" + ] + where + tryFind pat = + let (h, t) = BS.breakSubstring pat bs + in if BS.null t then Nothing else Just (BS.length h, BS.length h + BS.length pat) + earlier a Nothing = a + earlier Nothing b = b + earlier a@(Just (s1, e1)) b@(Just (s2, e2)) + | s1 < s2 = a + | s1 > s2 = b + | e1 >= e2 = a + | otherwise = b + +parseSseField :: T.Text -> Maybe (T.Text, T.Text) +parseSseField line + | T.null line = Nothing + | T.head line == ':' = Nothing + | otherwise = + let (name, rest) = T.breakOn ":" line + value + | T.null rest = "" + | otherwise = case T.stripPrefix " " (T.drop 1 rest) of + Just v -> v + Nothing -> T.drop 1 rest + in Just (name, value) + +parseSseBlock :: BS.ByteString -> Maybe SseEvent +parseSseBlock block = + let txt = T.replace "\r" "\n" . T.replace "\r\n" "\n" $ T.decodeUtf8Lenient block + ls = T.lines txt + fields = mapMaybe parseSseField ls + dataFields = [v | (k, v) <- fields, k == "data"] + dataVal = T.intercalate "\n" dataFields + lastField name = foldl' (\current (k, v) -> if k == name then Just v else current) Nothing fields + typeVal = lastField "event" + idVal = lastField "id" + in if null dataFields then Nothing else Just (SseEvent dataVal typeVal idVal) diff --git a/src/Network/HTTP/Request/Internal/Types.hs b/src/Network/HTTP/Request/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Request/Internal/Types.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Network.HTTP.Request.Internal.Types + ( Header, + Headers, + Method (..), + Request (..), + Response (..), + StreamBody (..), + SseEvent (..), + requestMethod, + requestUrl, + requestHeaders, + requestBody, + responseStatus, + responseHeaders, + responseBody, + ) +where + +import qualified Data.ByteString as BS +import qualified Data.Text as T + +type Header = (BS.ByteString, BS.ByteString) + +type Headers = [Header] + +data Method + = DELETE + | GET + | HEAD + | OPTIONS + | PATCH + | POST + | PUT + | TRACE + | Method String + deriving (Show, Eq) + +data Request a = Request + { method :: Method, + url :: String, + headers :: Headers, + body :: a + } + deriving (Show) + +data Response a = Response + { status :: Int, + headers :: Headers, + body :: a + } + deriving (Show) + +data StreamBody a = StreamBody + { readNext :: IO (Maybe a), + closeStream :: IO () + } + +data SseEvent = SseEvent + { sseData :: T.Text, + sseType :: Maybe T.Text, + sseId :: Maybe T.Text + } + deriving (Show) + +requestMethod :: Request a -> Method +requestMethod (Request value _ _ _) = value + +requestUrl :: Request a -> String +requestUrl (Request _ value _ _) = value + +requestHeaders :: Request a -> Headers +requestHeaders (Request _ _ value _) = value + +requestBody :: Request a -> a +requestBody (Request _ _ _ value) = value + +responseStatus :: Response a -> Int +responseStatus (Response value _ _) = value + +responseHeaders :: Response a -> Headers +responseHeaders (Response _ value _) = value + +responseBody :: Response a -> a +responseBody (Response _ _ value) = value diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,12 +16,11 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T -data Date = Date - { __type :: String - , iso :: String +data UUID = UUID + { uuid :: String } deriving (Show, Generic) -instance FromJSON Date +instance FromJSON UUID data Greeting = Greeting { message :: String @@ -29,6 +28,16 @@ instance ToJSON Greeting +data Login = Login + { username :: T.Text + , password :: T.Text + } deriving (Show) + +instance ToForm Login where + toForm l = [ ("username", T.encodeUtf8 l.username) + , ("password", T.encodeUtf8 l.password) + ] + main :: IO () main = hspec $ do describe "Network.HTTP.Request" $ do @@ -96,16 +105,34 @@ responseBody response `shouldSatisfy` isInfixOf "🌍" it "should parse JSON response with aeson" $ do - response <- get "https://api.leancloud.cn/1.1/date" :: IO (Response Date) + response <- get "https://httpbin.org/uuid" :: IO (Response UUID) responseStatus response `shouldBe` 200 - __type (responseBody response) `shouldBe` "Date" - iso (responseBody response) `shouldSatisfy` not . null + uuid (responseBody response) `shouldSatisfy` not . null it "should post JSON body with automatic Content-Type" $ do response <- post "https://postman-echo.com/post" (Greeting "Hello!") :: IO (Response String) responseStatus response `shouldBe` 200 responseBody response `shouldSatisfy` isInfixOf "application/json" + it "should post url-encoded form from a list" $ do + response <- post "https://postman-echo.com/post" (Form [("foo", "bar"), ("baz", "qux")]) :: IO (Response String) + responseStatus response `shouldBe` 200 + responseBody response `shouldSatisfy` isInfixOf "application/x-www-form-urlencoded" + responseBody response `shouldSatisfy` isInfixOf "\"foo\":\"bar\"" + responseBody response `shouldSatisfy` isInfixOf "\"baz\":\"qux\"" + + it "should post url-encoded form from a ToForm instance" $ do + response <- post "https://postman-echo.com/post" (Form (Login "alice" "s3cret")) :: IO (Response String) + responseStatus response `shouldBe` 200 + responseBody response `shouldSatisfy` isInfixOf "application/x-www-form-urlencoded" + responseBody response `shouldSatisfy` isInfixOf "\"username\":\"alice\"" + responseBody response `shouldSatisfy` isInfixOf "\"password\":\"s3cret\"" + + it "should percent-encode form values with special characters" $ do + response <- post "https://postman-echo.com/post" (Form [("q", "hello world"), ("lang", "zh-CN")]) :: IO (Response String) + responseStatus response `shouldBe` 200 + responseBody response `shouldSatisfy` isInfixOf "\"q\":\"hello world\"" + it "should add default User-Agent when request header is missing" $ do response <- send (Request GET "https://postman-echo.com/get" [] ()) :: IO (Response String) responseStatus response `shouldBe` 200 @@ -119,6 +146,14 @@ responseBody response `shouldSatisfy` isInfixOf customUserAgent responseBody response `shouldSatisfy` not . isInfixOf defaultUserAgent + it "should add a Basic Authorization header" $ do + let req = basicAuth "alice" "s3cret" (Request GET "http://example.com" [] ()) + requestHeaders req `shouldBe` [("Authorization", "Basic YWxpY2U6czNjcmV0")] + + it "should replace an existing Authorization header with a bearer token" $ do + let req = bearerAuth "new-token" (Request GET "http://example.com" [("authorization", "old-token")] ()) + requestHeaders req `shouldBe` [("Authorization", "Bearer new-token")] + it "should send with a user-provided manager" $ do mgr <- newManager response <- sendWith mgr (Request GET "http://example.com" [] ()) :: IO (Response String) @@ -133,7 +168,7 @@ mChunk `shouldSatisfy` (/= Nothing) it "should parse and stream SSE events" $ do - let req = Request GET "https://sse.dev/test" [] () + let req = Request GET "https://stream.wikimedia.org/v2/stream/recentchange" [] () resp <- send req :: IO (Response (StreamBody SseEvent)) resp.status `shouldBe` 200 mEvent <- resp.body.readNext