packages feed

network-api-support 0.0.1 → 0.0.2

raw patch · 6 files changed

+186/−66 lines, 6 filesdep +aesondep +attoparsec

Dependencies added: aeson, attoparsec

Files

network-api-support.cabal view
@@ -1,5 +1,5 @@ Name:               network-api-support-Version:            0.0.1+Version:            0.0.2 License:            BSD3 License-File:       LICENSE Author:             Mark Hibberd <mark@hibberd.id.au>@@ -29,6 +29,8 @@ Library   Build-Depends:                     base                            >= 3          && < 5+                    , aeson                         >= 0.5+                    , attoparsec                    >= 0.10                     , bytestring                    >= 0.9                     , case-insensitive              >= 0.4                     , certificate                   >= 1.2@@ -50,4 +52,6 @@   Exposed-Modules:                     Network.Api.Support                     Network.Api.Support.Core-+                    Network.Api.Support.Request+                    Network.Api.Support.Response+                    Network.Api.Support.Security
src/Network/Api/Support.hs view
@@ -10,5 +10,6 @@ module Network.Api.Support (module X) where  import Network.Api.Support.Core as X--+import Network.Api.Support.Request as X+import Network.Api.Support.Response as X+import Network.Api.Support.Security as X
src/Network/Api/Support/Core.hs view
@@ -1,82 +1,58 @@ {-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Network.Api.Support.Core (-  (<&>)-, checkDomainOnly-, setApiKey-, setParams-, setMethod-, setPost-, setGet-, setDelete-, setPut-, setHeaders-, runRequest-, RequestTransformer+  runRequest+, runRequest' ) where +import Network.Api.Support.Request+import Network.Api.Support.Response+ import Control.Failure import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource -import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy as BL-import Data.CaseInsensitive-import Data.Certificate.X509 (X509) import Data.Text import Data.Monoid  import Network.HTTP.Conduit import Network.HTTP.Types-import Network.TLS (TLSCertificateUsage)-import Network.TLS.Extra (certificateVerifyDomain) -infixr 5 <&>+-- * Request runners -(<&>) :: Monoid m => m -> m -> m-(<&>) = mappend+-- | Run a request using the specified settings, method, url and request transformer.+runRequest ::+  (MonadIO m, MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, Failure HttpException m) =>+  ManagerSettings+  -> StdMethod+  -> Text+  -> RequestTransformer m+  -> Responder b+  -> m b+runRequest settings stdmethod url transform  =+  runRequest' settings url (transform <> setMethod (renderStdMethod stdmethod)) -checkDomainOnly :: B8.ByteString -> [X509] -> IO TLSCertificateUsage-checkDomainOnly host' certs = return $ certificateVerifyDomain (B8.unpack host') certs+-- | Run a request using the specified settings, url and request transformer. The method+-- | can be set using the setMethod transformer. This is only useful if you require a+-- | custom http method. Prefer runRequest where possible.+runRequest' ::+  (MonadIO m, MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, Failure HttpException m) =>+  ManagerSettings+  -> Text+  -> RequestTransformer m+  -> Responder b+  -> m b+runRequest' settings url transform responder =+  do url' <- parseUrl $ unpack url+     let url'' = url' { checkStatus = const . const $ Nothing } -- handle all response codes.+     liftM responder . withCustomManager settings . httpLbs $ appEndo transform url'' -withCustomManager :: (MonadIO m, MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m) =>-  ManagerSettings -> (Manager -> ResourceT m a) -> m a+-- Build a custom connection manager and run ResourceT against that connection manager.+-- This function is responsible for ensuring manager is always closed.+withCustomManager ::+  (MonadIO m, MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m) =>+  ManagerSettings ->+  (Manager -> ResourceT m a) ->+  m a withCustomManager settings f = runResourceT $     allocate (newManager settings) closeManager >>= \(_, manager) -> f manager--type RequestTransformer m = Endo (Request (ResourceT m))--setApiKey :: B.ByteString -> RequestTransformer m-setApiKey key = Endo $ applyBasicAuth key ""--setParams :: (Monad m) => [(B.ByteString, B.ByteString)] -> RequestTransformer m-setParams params = Endo $ urlEncodedBody params--setMethod :: B.ByteString -> RequestTransformer m-setMethod m = Endo $ \r -> r { method = m }--setGet :: RequestTransformer m-setGet = setMethod "GET"--setPut :: RequestTransformer m-setPut = setMethod "PUT"--setPost :: RequestTransformer m-setPost = setMethod "POST"--setDelete :: RequestTransformer m-setDelete = setMethod "DELETE"--setHeaders :: [(CI Ascii, B.ByteString)] -> RequestTransformer m-setHeaders m = Endo $ \r -> r { requestHeaders = m }--runRequest ::-  (MonadIO m, MonadBaseControl IO m, MonadThrow m, MonadUnsafeIO m, Failure HttpException m) =>-  ManagerSettings -> Text -> RequestTransformer m -> (Response BL.ByteString -> b) -> m b-runRequest settings url transform responder =-  parseUrl (unpack url) >>= \url' ->-  (liftM responder . withCustomManager settings . httpLbs) ((appEndo transform $ url' {-      checkStatus = const . const $ Nothing-    }))-
+ src/Network/Api/Support/Request.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings, CPP #-}+module Network.Api.Support.Request (+  RequestTransformer+, setApiKey+, setParams+, setHeaders+, setMethod+, setBody+, setBodyLazy+, setJson+, (<>)+) where++import Control.Monad.Trans.Resource++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Aeson+import Data.CaseInsensitive+import Data.Monoid++import Network.HTTP.Conduit++-- * Request transformers++-- | A RequestTransformer allows you to build up attributes on the request.+-- | RequestTransformer is simply an Endo, and therefore has a Monoid, so+-- | can be combined with `<>`.+type RequestTransformer m = Endo (Request (ResourceT m))++-- | Set an api key for use with basic auth.+setApiKey :: B.ByteString -> RequestTransformer m+setApiKey key = Endo $ applyBasicAuth key ""++-- | Set request query parameters.+setParams :: Monad m => [(B.ByteString, B.ByteString)] -> RequestTransformer m+setParams params = Endo $ urlEncodedBody params++-- | Set request headers.+setHeaders :: [(CI B.ByteString, B.ByteString)] -> RequestTransformer m+setHeaders m = Endo $ \r -> r { requestHeaders = m }++-- | Set the request method to be the specified name.+setMethod :: B.ByteString -> RequestTransformer m+setMethod m = Endo $ \r -> r { method = m }++-- | Set the request body from the specified byte string.+setBody :: B.ByteString -> RequestTransformer m+setBody b = Endo $ \r -> r { requestBody = RequestBodyBS b }++-- | Set the request body from the specified lazy byte string.+setBodyLazy :: BL.ByteString -> RequestTransformer m+setBodyLazy b = Endo $ \r -> r { requestBody = RequestBodyLBS b }++-- | Set the request body from the value which can be converted to JSON.+setJson :: ToJSON a => a -> RequestTransformer m+setJson = setBodyLazy . encode . toJSON++-- * Compatability++#if __GLASGOW_HASKELL__ < 704+infixr 5 <>+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+#endif
+ src/Network/Api/Support/Response.hs view
@@ -0,0 +1,57 @@+module Network.Api.Support.Response (+  Responder+, JsonResult (..)+, parseBody+, parseBodyWith+, basicResponder+) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Attoparsec.Lazy+import Data.Aeson+import Data.Text++import Network.HTTP.Conduit+import Network.HTTP.Types++-- | Response handler.+type Responder a =+  Response BL.ByteString -> a++-- | Wrap up json parse and decode errors.+data JsonResult a =+  ParseError Text | DecodeError Text | JsonSuccess a deriving (Show, Eq)++instance Functor JsonResult where+  fmap _ (ParseError t) = ParseError t+  fmap _ (DecodeError t) = DecodeError t+  fmap f (JsonSuccess a) = JsonSuccess $ f a++instance Monad JsonResult where+  return = JsonSuccess+  (ParseError t) >>= _ = ParseError t+  (DecodeError t) >>= _ = DecodeError t+  (JsonSuccess a) >>= f = f a++-- | Parse and decode body handling error cases and success case.+parseBodyWith :: FromJSON a => BL.ByteString -> (Text -> b) -> (Text -> b) -> (a -> b) -> b+parseBodyWith body pHandler dHandler sHandler =+  case parseBody body of+    ParseError t -> pHandler t+    DecodeError t -> dHandler t+    JsonSuccess a -> sHandler a++-- | Parse and decode body.+parseBody :: FromJSON a => BL.ByteString -> JsonResult a+parseBody body =+  case parseOnly json (B.concat . BL.toChunks $ body) of+    Left msg -> ParseError . pack $ msg+    Right j -> case fromJSON j of+      (Error msg') -> DecodeError . pack $ msg'+      (Success a) -> JsonSuccess a++-- | Lift function handling status code and body into a responder.+basicResponder :: (Int -> BL.ByteString -> a) -> Responder a+basicResponder f (Response (Status code _) _ _ body) =+  f code body
+ src/Network/Api/Support/Security.hs view
@@ -0,0 +1,17 @@+module Network.Api.Support.Security (+  checkDomainOnly+) where++import qualified Data.ByteString.Char8 as B8+import Data.Certificate.X509 (X509)++import Network.TLS (TLSCertificateUsage)+import Network.TLS.Extra (certificateVerifyDomain)++-- | A TLS validator that checks the domain only. Note that this means the validator+-- | will not check the cert chain, and can be used on systems where Data.Certificate.X509+-- | falls over as it does not have access to local root certs.+-- |+-- | ! Use with caution !+checkDomainOnly :: B8.ByteString -> [X509] -> IO TLSCertificateUsage+checkDomainOnly host' certs = return $ certificateVerifyDomain (B8.unpack host') certs