packages feed

trasa-client (empty) → 0.1.0.0

raw patch · 5 files changed

+296/−0 lines, 5 filesdep +aesondep +basedep +binarysetup-changed

Dependencies added: aeson, base, binary, bytestring, http-client, http-types, ip, text, trasa, trasa-client, unordered-containers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Trasa/Client.hs view
@@ -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+          }
+ test/Main.hs view
@@ -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))
+ trasa-client.cabal view
@@ -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