diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 Kyle McKean + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Trasa/Client.hs b/src/Trasa/Client.hs new file mode 100644 --- /dev/null +++ b/src/Trasa/Client.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall -Werror #-} +module Trasa.Client + ( + -- * Types + Scheme(..) + , Authority(..) + , Config(..) + -- * Requests + , clientWith + )where + +import Data.Semigroup ((<>)) +import Data.Word (Word16) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Binary.Builder as LBS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +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 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.Client as N + +import Trasa.Core hiding (status,body) + +-- | If you select Https you need to pass in a tls manager in config or tls wont actually happen +data Scheme = Http | Https + +schemeToSecure :: Scheme -> Bool +schemeToSecure = \case + Http -> False + Https -> True + +schemeToPort :: Scheme -> Int +schemeToPort = \case + Http -> 80 + Https -> 443 + +data Authority = Authority + { authorityScheme :: !Scheme + , authorityHost :: !T.Text + , authorityPort :: Maybe Word16 + } + +encodeAuthority :: T.Text -> Maybe Word16 -> BS.ByteString +encodeAuthority host port = + (TE.encodeUtf8 . LT.toStrict . LT.toLazyText) + (LT.fromText host <> maybe "" (\p -> LT.singleton ':' <> LT.decimal p) port) + +encodePathBS :: [T.Text] -> BS.ByteString +encodePathBS = LBS.toStrict . LBS.toLazyByteString . (LBS.putCharUtf8 '/' <>) . N.encodePathSegmentsRelative + +encodeQueryBS :: QueryString -> BS.ByteString +encodeQueryBS = + LBS.toStrict . + LBS.toLazyByteString . + N.renderQueryBuilder True . + encodeQuery + +encodeAcceptBS :: [T.Text] -> BS.ByteString +encodeAcceptBS = TE.encodeUtf8 . T.intercalate ", " + +data Config = Config + { configAuthority :: Authority + , configManager :: !N.Manager + } + +clientWith :: forall route response. + (forall caps qrys req resp. route caps qrys req resp -> T.Text) + -- ^ 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 + -> 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 + where + run :: T.Text -> Url -> Maybe Content -> [T.Text] -> IO (Either TrasaErr Content) + run method (Url path query) mcontent accepts = do + response <- N.httpLbs req manager + let status = N.responseStatus response + body = N.responseBody response + 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) + False -> Left (TrasaErr status body) + where + Config (Authority scheme host port) manager = config + req = N.defaultRequest + { N.method = TE.encodeUtf8 method + , N.secure = schemeToSecure scheme + , N.host = encodeAuthority host port + , 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,TE.encodeUtf8 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 new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-unticked-promoted-constructors #-} +module Main where + +import Data.Kind (Type) +import GHC.Generics hiding (Meta) +import Data.Bifunctor (Bifunctor(..)) +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import Data.Aeson + (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.Client + +data Ip = Ip + { origin :: IPv4 + } deriving (Generic,FromJSON,ToJSON) + +instance Show Ip where + show (Ip ipv4) = "{ origin: " ++ IPv4.encode ipv4 ++ " }" + +data Args = Args + { args :: H.HashMap T.Text Value + } deriving Show + +instance FromJSON Args where + parseJSON = withObject "Args" $ \o -> Args <$> o .: "args" + +instance ToJSON Args where + toJSON (Args as) = object [ "args" .= as ] + +bodyAeson :: (FromJSON a, ToJSON a) => BodyCodec a +bodyAeson = BodyCodec (pure "application/json") encode (first T.pack . eitherDecode') + +int :: CaptureCodec Int +int = showReadCaptureCodec + +bodyUnit :: BodyCodec () +bodyUnit = BodyCodec (pure "text/html; charset=utf-8") (const "") (const (Right ())) + +data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where + RouteHome :: Route '[] '[] Bodyless () + RouteIp :: Route '[] '[] Bodyless Ip + 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 :: T.Text } + +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" + +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) + +shouldRight :: Show resp => Config -> Prepared Route resp -> IO () +shouldRight conf route = do + putStr $ show (link route) ++ ": " + client conf route >>= \case + Left err -> do + print err + exitFailure + Right val -> print val + +main :: IO () +main = do + manager <- N.newManager N.defaultManagerSettings + 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" + Right _ -> do + putStrLn "Connected to httpbin.org, actually testing routes now..." + shouldRight conf (prepare RouteIp) + shouldRight conf (prepare RouteStatus 200) + shouldRight conf (prepare RouteQuery (Just 1)) diff --git a/trasa-client.cabal b/trasa-client.cabal new file mode 100644 --- /dev/null +++ b/trasa-client.cabal @@ -0,0 +1,44 @@ +name: trasa-client +version: 0.1.0.0 +synopsis: Type safe http requests +license: MIT +license-file: LICENSE +author: Kyle McKean +maintainer: mckean.kylej@gmail.com +copyright: @2017 Kyle McKean +category: Web +build-type: Simple +cabal-version: >=1.10 +description: Http client integration for trasa + +library + exposed-modules: Trasa.Client + build-depends: base >= 4.9 && < 4.10 + , bytestring == 0.10.* + , binary == 0.8.* + , text == 1.2.* + , http-types == 0.9.* + , http-client == 0.5.* + , trasa == 0.1.* + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.9 && < 4.10 + , trasa + , trasa-client + , http-types == 0.9.* + , http-client == 0.5.* + , unordered-containers == 0.2.* + , text == 1.2.* + , ip == 0.9.* + , aeson == 1.0.* + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/haskell-trasa/trasa