diff --git a/src/Trasa/Client.hs b/src/Trasa/Client.hs --- a/src/Trasa/Client.hs +++ b/src/Trasa/Client.hs @@ -10,10 +10,11 @@ , Config(..) -- * Requests , clientWith - )where + ) where -import Data.Semigroup ((<>)) import Data.Word (Word16) +import Data.Semigroup ((<>)) +import qualified Data.List.NonEmpty as NE import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Binary.Builder as LBS @@ -25,6 +26,7 @@ import qualified Network.HTTP.Types.URI as N import qualified Network.HTTP.Types.Header as N import qualified Network.HTTP.Types.Status as N +import qualified Network.HTTP.Media as N import qualified Network.HTTP.Client as N import Trasa.Core hiding (status,body) @@ -63,8 +65,8 @@ N.renderQueryBuilder True . encodeQuery -encodeAcceptBS :: [T.Text] -> BS.ByteString -encodeAcceptBS = TE.encodeUtf8 . T.intercalate ", " +encodeAcceptBS :: NE.NonEmpty N.MediaType -> BS.ByteString +encodeAcceptBS = BS.intercalate "; " . fmap N.renderHeader . NE.toList data Config = Config { configAuthority :: Authority @@ -72,7 +74,7 @@ } clientWith :: forall route response. - (forall caps qrys req resp. route caps qrys req resp -> T.Text) + (forall caps qrys req resp. route caps qrys req resp -> Method) -- ^ Get the method out of the route -> (forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps) -- ^ Get a way to encode paths from a route @@ -89,7 +91,7 @@ clientWith toMethod toCapEnc toQuerys toReqBody toRespBody config = requestWith toMethod toCapEnc toQuerys toReqBody toRespBody run where - run :: T.Text -> Url -> Maybe Content -> [T.Text] -> IO (Either TrasaErr Content) + run :: Method -> Url -> Maybe Content -> NE.NonEmpty N.MediaType -> IO (Either TrasaErr Content) run method (Url path query) mcontent accepts = do response <- N.httpLbs req manager let status = N.responseStatus response @@ -97,14 +99,14 @@ return $ case status < N.status400 of True -> case lookup N.hContentType (N.responseHeaders response) of Nothing -> Left (TrasaErr N.status415 "No content type found") - Just bs -> case TE.decodeUtf8' bs of - Left _ -> Left (TrasaErr N.status415 "Could note utf8 decode content type") - Right typ -> Right (Content typ body) + Just bs -> case N.parseAccept bs of + Nothing -> Left (TrasaErr N.status415 "Could not decode content type") + Just typ -> Right (Content typ body) False -> Left (TrasaErr status body) where Config (Authority scheme host port) manager = config req = N.defaultRequest - { N.method = TE.encodeUtf8 method + { N.method = TE.encodeUtf8 $ encodeMethod method , N.secure = schemeToSecure scheme , N.host = encodeAuthority host port , N.port = maybe (schemeToPort scheme) fromIntegral port @@ -112,7 +114,7 @@ , N.queryString = encodeQueryBS query , N.requestHeaders = [(N.hAccept,encodeAcceptBS accepts)] ++ case mcontent of Nothing -> [] - Just (Content typ _) -> [(N.hContentType,TE.encodeUtf8 typ)] + Just (Content typ _) -> [(N.hContentType,N.renderHeader typ)] , N.requestBody = case mcontent of Nothing -> N.RequestBodyLBS "" Just (Content _ reqBody) -> N.RequestBodyLBS reqBody diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -24,6 +24,7 @@ import qualified Network.HTTP.Types.Status as N import qualified Network.HTTP.Client as N import Trasa.Core +import qualified Trasa.Method as M import Trasa.Client data Ip = Ip @@ -50,7 +51,7 @@ int = showReadCaptureCodec bodyUnit :: BodyCodec () -bodyUnit = BodyCodec (pure "text/html; charset=utf-8") (const "") (const (Right ())) +bodyUnit = BodyCodec (pure "text/html") (const "") (const (Right ())) data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where RouteHome :: Route '[] '[] Bodyless () @@ -63,14 +64,14 @@ , metaQuery :: Rec (Query CaptureCodec) qrys , metaRequestBody :: RequestBody BodyCodec req , metaResponseBody :: ResponseBody BodyCodec resp - , metaMethod :: T.Text } + , metaMethod :: Method } meta :: Route caps qrys req resp -> Meta caps qrys req resp meta = \case - RouteHome -> Meta end qend bodyless (resp bodyUnit) "GET" - RouteIp -> Meta (match "ip" ./ end) qend bodyless (resp bodyAeson) "GET" - RouteStatus -> Meta (match "status" ./ capture int ./ end) qend bodyless (resp bodyUnit) "GET" - RouteQuery -> Meta (match "anything" ./ end) (optional "int" int .& qend) bodyless (resp bodyAeson) "GET" + RouteHome -> Meta end qend bodyless (resp bodyUnit) M.get + RouteIp -> Meta (match "ip" ./ end) qend bodyless (resp bodyAeson) M.get + RouteStatus -> Meta (match "status" ./ capture int ./ end) qend bodyless (resp bodyUnit) M.get + RouteQuery -> Meta (match "anything" ./ end) (optional "int" int .& qend) bodyless (resp bodyAeson) M.get prepare :: Route caps qrys req resp -> Arguments caps qrys req (Prepared Route resp) prepare = prepareWith (metaPath . meta) (metaQuery . meta) (metaRequestBody . meta) @@ -103,7 +104,9 @@ let conf = Config (Authority Http "httpbin.org" Nothing) manager res <- catch (client conf (prepare RouteHome)) $ \(_ :: SomeException) -> return (Left (status N.status400)) case res of - Left _ -> putStrLn "Could not connect to httpbin.org, not running test suite" + Left err -> do + putStrLn "Could not connect to httpbin.org, not running test suite" + putStrLn ("Could not connect because: " ++ show err) Right _ -> do putStrLn "Connected to httpbin.org, actually testing routes now..." shouldRight conf (prepare RouteIp) diff --git a/trasa-client.cabal b/trasa-client.cabal --- a/trasa-client.cabal +++ b/trasa-client.cabal @@ -1,5 +1,5 @@ name: trasa-client -version: 0.1.0.0 +version: 0.2 synopsis: Type safe http requests license: MIT license-file: LICENSE @@ -18,8 +18,9 @@ , binary == 0.8.* , text == 1.2.* , http-types == 0.9.* + , http-media == 0.6.* , http-client == 0.5.* - , trasa == 0.1.* + , trasa == 0.2.* hs-source-dirs: src default-language: Haskell2010