diff --git a/src/Trasa/Client.hs b/src/Trasa/Client.hs --- a/src/Trasa/Client.hs +++ b/src/Trasa/Client.hs @@ -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 diff --git a/src/Trasa/Client/Implicit.hs b/src/Trasa/Client/Implicit.hs new file mode 100644 --- /dev/null +++ b/src/Trasa/Client/Implicit.hs @@ -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) + + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 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.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