diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2012, Mark Hibberd +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of apiengine nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ""AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/network-api-support.cabal b/network-api-support.cabal new file mode 100644 --- /dev/null +++ b/network-api-support.cabal @@ -0,0 +1,53 @@ +Name: network-api-support +Version: 0.0.1 +License: BSD3 +License-File: LICENSE +Author: Mark Hibberd +Maintainer: Mark Hibberd +Copyright: (c) 2012 Mark Hibberd +Synopsis: Toolkit for building http client libraries over Network.Http.Conduit +Category: Network APIs +Homepage: https://github.com/apiengine/network-api-support +Bug-reports: https://github.com/apiengine/network-api-support/issues +Cabal-Version: >= 1.8 +Build-Type: Simple +Description: + Toolkit for building http client libraries over Network.Http.Conduit. + . + /Note/: This library is under heavy development, currently + the library is functional but undocumented. Examples of use + can be found in the pin and postmark client libraries. + Basically expect improvements and change. + +Source-Repository head + Type: git + Location: https://github.com/apiengine/network-api-support.git + +Flag small_base + Description: Choose the new, split-up base package. + +Library + Build-Depends: + base >= 3 && < 5 + , bytestring >= 0.9 + , case-insensitive >= 0.4 + , certificate >= 1.2 + , failure >= 0.2 + , http-conduit >= 1.4 + , http-types >= 0.6 + , resourcet >= 0.3 + , text >= 0.11 + , tls >= 0.9 + , tls-extra >= 0.4 + , transformers >= 0.2 + + GHC-Options: + -Wall -fno-warn-orphans + + Hs-Source-Dirs: + src + + Exposed-Modules: + Network.Api.Support + Network.Api.Support.Core + diff --git a/src/Network/Api/Support.hs b/src/Network/Api/Support.hs new file mode 100644 --- /dev/null +++ b/src/Network/Api/Support.hs @@ -0,0 +1,14 @@ +-- | +-- Module: Network.Api.Support +-- Copyright: (c) 2012 Mark Hibberd +-- License: BSD3 +-- Maintainer: Mark Hibberd +-- Portability: portable +-- +-- Toolkit for building http client libraries over Network.Http.Conduit +-- +module Network.Api.Support (module X) where + +import Network.Api.Support.Core as X + + diff --git a/src/Network/Api/Support/Core.hs b/src/Network/Api/Support/Core.hs new file mode 100644 --- /dev/null +++ b/src/Network/Api/Support/Core.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +module Network.Api.Support.Core ( + (<&>) +, checkDomainOnly +, setApiKey +, setParams +, setMethod +, setPost +, setGet +, setDelete +, setPut +, setHeaders +, runRequest +, RequestTransformer +) where + +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 <&> + +(<&>) :: Monoid m => m -> m -> m +(<&>) = mappend + +checkDomainOnly :: B8.ByteString -> [X509] -> IO TLSCertificateUsage +checkDomainOnly host' certs = return $ certificateVerifyDomain (B8.unpack host') certs + +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 + })) +