trasa-client 0.2 → 0.3
raw patch · 4 files changed
+79/−63 lines, 4 filesdep +case-insensitivedep +containersdep ~aesondep ~basedep ~http-clientnew-uploader
Dependencies added: case-insensitive, containers
Dependency ranges changed: aeson, base, http-client, http-media, http-types, ip, text, trasa, unordered-containers
Files
- src/Trasa/Client.hs +23/−19
- src/Trasa/Client/Implicit.hs +24/−0
- test/Main.hs +17/−32
- trasa-client.cabal +15/−12
src/Trasa/Client.hs view
@@ -23,6 +23,8 @@ import qualified Data.Text.Lazy as LT hiding (singleton) import qualified Data.Text.Lazy.Builder as LT import qualified Data.Text.Lazy.Builder.Int as LT+import qualified Data.Map.Strict as M+import Data.CaseInsensitive (CI) import qualified Network.HTTP.Types.URI as N import qualified Network.HTTP.Types.Header as N import qualified Network.HTTP.Types.Status as N@@ -47,7 +49,7 @@ data Authority = Authority { authorityScheme :: !Scheme , authorityHost :: !T.Text- , authorityPort :: Maybe Word16+ , authorityPort :: !(Maybe Word16) } encodeAuthority :: T.Text -> Maybe Word16 -> BS.ByteString@@ -68,28 +70,32 @@ encodeAcceptBS :: NE.NonEmpty N.MediaType -> BS.ByteString encodeAcceptBS = BS.intercalate "; " . fmap N.renderHeader . NE.toList +encodeHeaders+ :: NE.NonEmpty N.MediaType+ -> Maybe Content+ -> M.Map (CI BS.ByteString) T.Text+ -> [(CI BS.ByteString,BS.ByteString)]+encodeHeaders accepts mcontent =+ M.toList .+ M.insert N.hAccept (encodeAcceptBS accepts) .+ maybe id (M.insert N.hContentType . N.renderHeader . contentType) mcontent .+ fmap TE.encodeUtf8+ data Config = Config- { configAuthority :: Authority+ { configAuthority :: !Authority+ , configHeaders :: !(M.Map (CI BS.ByteString) T.Text) , configManager :: !N.Manager } -clientWith :: forall route response.- (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- -> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureEncoding) qrys)- -- ^ Get a way to encode query params from a route- -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyEncoding) req)- -- ^ Get a way to encode request bodies from a route- -> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyDecoding) resp)- -- ^ Get a way to encode response bodies from a route+clientWith+ :: forall route response+ . (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) -> Config -> Prepared route response -- ^ Which endpoint to request -> IO (Either TrasaErr response)-clientWith toMethod toCapEnc toQuerys toReqBody toRespBody config =- requestWith toMethod toCapEnc toQuerys toReqBody toRespBody run+clientWith toMeta config =+ requestWith toMeta run where run :: Method -> Url -> Maybe Content -> NE.NonEmpty N.MediaType -> IO (Either TrasaErr Content) run method (Url path query) mcontent accepts = do@@ -104,7 +110,7 @@ Just typ -> Right (Content typ body) False -> Left (TrasaErr status body) where- Config (Authority scheme host port) manager = config+ Config (Authority scheme host port) headers manager = config req = N.defaultRequest { N.method = TE.encodeUtf8 $ encodeMethod method , N.secure = schemeToSecure scheme@@ -112,9 +118,7 @@ , N.port = maybe (schemeToPort scheme) fromIntegral port , N.path = encodePathBS path , N.queryString = encodeQueryBS query- , N.requestHeaders = [(N.hAccept,encodeAcceptBS accepts)] ++ case mcontent of- Nothing -> []- Just (Content typ _) -> [(N.hContentType,N.renderHeader typ)]+ , N.requestHeaders = encodeHeaders accepts mcontent headers , N.requestBody = case mcontent of Nothing -> N.RequestBodyLBS "" Just (Content _ reqBody) -> N.RequestBodyLBS reqBody
+ src/Trasa/Client/Implicit.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module Trasa.Client.Implicit where++import Trasa.Core+import Trasa.Core.Implicit+import Trasa.Client++client+ :: ( HasMeta route+ , HasCaptureEncoding (CaptureStrategy route)+ , HasCaptureEncoding (QueryStrategy route)+ , RequestBodyStrategy route ~ Many requestBodyStrat+ , HasBodyEncoding requestBodyStrat+ , ResponseBodyStrategy route ~ Many responseBodyStrat+ , HasBodyDecoding responseBodyStrat+ )+ => Config+ -> Prepared route response+ -> IO (Either TrasaErr response)+client = clientWith (transformMeta . meta)+ where transformMeta = mapMeta captureEncoding captureEncoding (mapMany bodyEncoding) (mapMany bodyDecoding)++
test/Main.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}@@ -6,6 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror -Wno-unticked-promoted-constructors #-} module Main where @@ -18,21 +20,22 @@ (Value(..),FromJSON(..),ToJSON(..),encode,eitherDecode' ,object,withObject,(.:),(.=)) import Net.Types (IPv4)-import qualified Net.IPv4.String as IPv4 import Control.Exception (catch,SomeException) import System.Exit (exitFailure) import qualified Network.HTTP.Types.Status as N import qualified Network.HTTP.Client as N import Trasa.Core+import Trasa.Core.Implicit import qualified Trasa.Method as M import Trasa.Client+import Trasa.Client.Implicit data Ip = Ip { origin :: IPv4 } deriving (Generic,FromJSON,ToJSON) instance Show Ip where- show (Ip ipv4) = "{ origin: " ++ IPv4.encode ipv4 ++ " }"+ show (Ip ipv4) = "{ origin: " ++ show ipv4 ++ " }" data Args = Args { args :: H.HashMap T.Text Value@@ -59,35 +62,17 @@ RouteStatus :: Route '[Int] '[] Bodyless () RouteQuery :: Route '[] '[Optional Int] Bodyless Args -data Meta caps qrys req resp = Meta- { metaPath :: Path CaptureCodec caps- , metaQuery :: Rec (Query CaptureCodec) qrys- , metaRequestBody :: RequestBody BodyCodec req- , metaResponseBody :: ResponseBody BodyCodec resp- , metaMethod :: Method }--meta :: Route caps qrys req resp -> Meta caps qrys req resp-meta = \case- 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)--link :: Prepared Route resp -> Url-link = linkWith- (mapPath captureCodecToCaptureEncoding . metaPath . meta)- (mapQuery captureCodecToCaptureEncoding . metaQuery . meta)--client :: Config -> Prepared Route resp -> IO (Either TrasaErr resp)-client = clientWith- (metaMethod . meta)- (mapPath captureCodecToCaptureEncoding . metaPath . meta)- (mapQuery captureCodecToCaptureEncoding . metaQuery . meta)- (mapRequestBody (Many . pure . bodyCodecToBodyEncoding) . metaRequestBody . meta)- (mapResponseBody (Many . pure . bodyCodecToBodyDecoding) . metaResponseBody . meta)+instance HasMeta Route where+ type CaptureStrategy Route = CaptureCodec+ type QueryStrategy Route = CaptureCodec+ type RequestBodyStrategy Route = Many BodyCodec+ type ResponseBodyStrategy Route = Many BodyCodec+ meta :: Route caps qrys req resp -> MetaCodec caps qrys req resp+ meta route = metaBuilderToMetaCodec $ case route of+ 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 shouldRight :: Show resp => Config -> Prepared Route resp -> IO () shouldRight conf route = do@@ -101,7 +86,7 @@ main :: IO () main = do manager <- N.newManager N.defaultManagerSettings- let conf = Config (Authority Http "httpbin.org" Nothing) manager+ let conf = Config (Authority Http "httpbin.org" Nothing) mempty manager res <- catch (client conf (prepare RouteHome)) $ \(_ :: SomeException) -> return (Left (status N.status400)) case res of Left err -> do
trasa-client.cabal view
@@ -1,5 +1,5 @@ name: trasa-client-version: 0.2+version: 0.3 synopsis: Type safe http requests license: MIT license-file: LICENSE@@ -13,14 +13,17 @@ library exposed-modules: Trasa.Client- build-depends: base >= 4.9 && < 4.10+ , Trasa.Client.Implicit+ build-depends: base >= 4.9 && < 5 , bytestring == 0.10.* , binary == 0.8.* , text == 1.2.*- , http-types == 0.9.*- , http-media == 0.6.*+ , containers >= 0.5+ , case-insensitive == 1.2.*+ , http-types >= 0.9+ , http-media >= 0.6 && < 0.8 , http-client == 0.5.*- , trasa == 0.2.*+ , trasa == 0.3.* hs-source-dirs: src default-language: Haskell2010 @@ -28,15 +31,15 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs- build-depends: base >= 4.9 && < 4.10+ build-depends: base >= 4.9 && < 5 , trasa , trasa-client- , http-types == 0.9.*- , http-client == 0.5.*- , unordered-containers == 0.2.*- , text == 1.2.*- , ip == 0.9.*- , aeson == 1.0.*+ , http-types+ , http-client+ , unordered-containers+ , text+ , ip+ , aeson ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010