rest-client (empty) → 0.2.3.1
raw patch · 5 files changed
+358/−0 lines, 5 filesdep +aesondep +aeson-utilsdep +basesetup-changed
Dependencies added: aeson, aeson-utils, base, bytestring, case-insensitive, exception-transformers, http-conduit, http-types, hxt, hxt-pickle-utils, monad-control, mtl, resourcet, rest-types, tostring, transformers-base, uri-encode, utf8-string
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- rest-client.cabal +40/−0
- src/Rest/Client/Base.hs +157/−0
- src/Rest/Client/Internal.hs +129/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Silk++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Silk nor the names of other+ 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+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rest-client.cabal view
@@ -0,0 +1,40 @@+Name: rest-client+Version: 0.2.3.1+Description: Utility library for use in generated API client libraries.+Synopsis: Utility library for use in generated API client libraries.+Maintainer: code@silk.co+Category: Web+Build-Type: Simple+Cabal-Version: >= 1.8+License: BSD3+License-file: LICENSE++Library+ GHC-Options: -Wall+ Hs-Source-Dirs: src+ Build-Depends:+ base == 4.*+ , aeson >= 0.7 && < 0.8+ , aeson-utils == 0.2.1+ , bytestring >= 0.9 && < 0.11+ , case-insensitive >= 0.4 && < 1.2+ , exception-transformers == 0.3.*+ , http-conduit >= 1.9.2.1 && < 1.10+ , http-types >= 0.7 && < 0.9+ , hxt >= 9.2 && < 9.4+ , monad-control == 0.3.*+ , mtl >= 2.0 && < 2.2+ , hxt-pickle-utils == 0.1.*+ , resourcet >= 0.4 && < 0.5+ , rest-types == 1.9.0.1+ , tostring == 0.2.*+ , transformers-base == 0.4.*+ , uri-encode == 1.5.*+ , utf8-string == 0.3.*++ Exposed-Modules: Rest.Client.Base+ Rest.Client.Internal++Source-repository head+ Type: Git+ Location: https://github.com/silkapp/rest.git
+ src/Rest/Client/Base.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE+ CPP+ , FlexibleContexts+ , FlexibleInstances+ , GeneralizedNewtypeDeriving+ , MultiParamTypeClasses+ , TypeFamilies+ , UndecidableInstances+ #-}+module Rest.Client.Base+ ( ApiInfo(..)+ , ApiState(..)+ , ApiT(..)+ , Api+ , ApiStateC(..)+ , runT+ , run+ , runWithPort+ , ApiResponse(..)+ , responseToMaybe+ ) where++#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import Control.Applicative+import Control.Monad+import Control.Monad.Base+import Control.Monad.Cont hiding (mapM)+import Control.Monad.Error hiding (mapM)+import Control.Monad.Exception+import Control.Monad.List hiding (mapM)+import Control.Monad.RWS hiding (mapM)+import Control.Monad.Reader hiding (mapM)+import Control.Monad.State hiding (mapM)+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Control.Monad.Writer hiding (mapM)+import Data.ByteString+import Data.CaseInsensitive+import Network.HTTP.Conduit hiding (method, responseBody)++import Rest.Types.Error++data ApiInfo =+ ApiInfo+ { manager :: Manager+ , apiHost :: String+ , apiPort :: Int+ , headers :: [(String, String)]+ }++data ApiState = ApiState { cookies :: CookieJar }++newtype ApiT m a = ApiT { unApiT :: StateT ApiState (ReaderT ApiInfo (ResourceT m)) a }+ deriving ( Functor, Applicative+ , Monad+ , MonadIO+ )++type Api = ApiT IO++class (MonadResource m, MonadBaseControl IO m, Monad m, Functor m, MonadUnsafeIO m) => ApiStateC m where+ getApiState :: m ApiState+ putApiState :: ApiState -> m ()+ askApiInfo :: m ApiInfo++instance (MonadBaseControl IO m, Monad m, Functor m, MonadUnsafeIO m, MonadIO m, MonadThrow m) => ApiStateC (ApiT m) where+ getApiState = ApiT get+ putApiState = ApiT . put+ askApiInfo = ApiT (lift ask)++instance MonadTrans ApiT where+ lift = ApiT . lift . lift . lift++instance MonadBase b m => MonadBase b (ApiT m) where+ liftBase = liftBaseDefault++instance MonadTransControl ApiT where+ newtype StT ApiT a = StTApiT { unStTApiT :: StT ResourceT (StT (ReaderT ApiInfo) (StT (StateT ApiState) a)) }+ liftWith f = ApiT (liftWith (\runs -> liftWith (\runrr -> liftWith (\runrs -> f (liftM StTApiT . runrs . runrr . runs . unApiT)))))+ restoreT = ApiT . restoreT . restoreT . restoreT . liftM unStTApiT++instance MonadBaseControl v m => MonadBaseControl v (ApiT m) where+ newtype StM (ApiT m) a = StMApiT { unStMApiT :: ComposeSt ApiT m a }+ liftBaseWith = defaultLiftBaseWith StMApiT+ restoreM = defaultRestoreM unStMApiT++instance (MonadException m, MonadBaseControl IO m) => MonadException (ResourceT m) where+ throw = lift . throw+ catch c f = lift (runResourceT c `catch` (runResourceT . f))++instance (MonadException m, MonadBaseControl IO m) => MonadException (ApiT m) where+ throw = lift . throw+ catch c f = ApiT (unApiT c `catch` (unApiT . f))++instance MonadThrow m => MonadThrow (ApiT m) where monadThrow = ApiT . lift . lift . lift . monadThrow++instance (MonadIO m, MonadThrow m, MonadUnsafeIO m, Functor m, Applicative m) => MonadResource (ApiT m) where+ liftResourceT = ApiT . lift . lift . transResourceT liftIO++instance (Error e, ApiStateC m) => ApiStateC (ErrorT e m) where+ getApiState = lift getApiState+ askApiInfo = lift askApiInfo+ putApiState = lift . putApiState++instance (Monoid w, ApiStateC m) => ApiStateC (RWST r w s m) where+ getApiState = lift getApiState+ askApiInfo = lift askApiInfo+ putApiState = lift . putApiState++instance (Monoid w, ApiStateC m) => ApiStateC (WriterT w m) where+ getApiState = lift getApiState+ askApiInfo = lift askApiInfo+ putApiState = lift . putApiState++instance ApiStateC m => ApiStateC (ListT m) where+ getApiState = lift getApiState+ askApiInfo = lift askApiInfo+ putApiState = lift . putApiState++instance ApiStateC m => ApiStateC (ReaderT r m) where+ getApiState = lift getApiState+ askApiInfo = lift askApiInfo+ putApiState = lift . putApiState++instance ApiStateC m => ApiStateC (StateT s m) where+ getApiState = lift getApiState+ askApiInfo = lift askApiInfo+ putApiState = lift . putApiState++runT :: (MonadBaseControl IO m, Monad m) => ApiInfo -> ApiState -> ApiT m a -> m a+runT inf st api = runResourceT (runReaderT (evalStateT (unApiT api) st) inf)++run :: String -> ApiT IO a -> IO a+run = flip runWithPort 80++runWithPort :: String -> Int -> ApiT IO a -> IO a+runWithPort hst prt api =+ do m <- newManager def+ v <- runT (ApiInfo m hst prt []) (ApiState (createCookieJar [])) api+ closeManager m+ return v++data ApiResponse e a =+ ApiResponse+ { statusCode :: Int+ , statusMessage :: ByteString+ , httpVersion :: (Int, Int)+ , responseHeaders :: [(CI ByteString , ByteString)]+ , responseBody :: Either (Reason e) a+ } deriving Show++responseToMaybe :: ApiResponse e a -> Maybe a+responseToMaybe = either (const Nothing) Just . responseBody
+ src/Rest/Client/Internal.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-}+module Rest.Client.Internal+ ( module Control.Monad+ , module Data.String+ , module Data.String.ToString+ , MonadIO (..)+ , L.ByteString+ , intercalate+ , URI.encode++ , module Rest.Client.Base+ , ShowUrl (..)+ , hAccept+ , hContentType++ , ApiRequest(..)+ , doRequest+ , parseResult+ , fromJSON+ , toJSON+ , fromXML+ , toXML+ ) where++import Control.Arrow+import Control.Monad+import Control.Monad.Cont+import Data.Aeson.Utils (FromJSON, ToJSON, decodeV, encode)+import Data.List+import Data.Maybe+import Data.Monoid+import Data.String+import Data.String.ToString+import Network.HTTP.Conduit hiding (method, responseBody, responseHeaders)+import Network.HTTP.Types hiding (statusCode, statusMessage)+import Text.XML.HXT.Arrow.Pickle++import qualified Data.ByteString.Char8 as CH+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.UTF8 as L+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types as HTTP++import Rest.Types.Error+import Rest.Types.ShowUrl++import qualified Network.URI.Encode as URI+import qualified Text.Xml.Pickle as P++import Rest.Client.Base++data ApiRequest = ApiRequest+ { method :: String+ , uri :: String+ , params :: [(String, String)]+ , requestHeaders :: RequestHeaders+ , requestBody :: L.ByteString+ }++convertResponse :: Response (Either (Reason e) a) -> ApiResponse e a+convertResponse r =+ ApiResponse+ { statusCode = HTTP.statusCode (responseStatus r)+ , statusMessage = HTTP.statusMessage (responseStatus r)+ , httpVersion = (\v -> (httpMajor v, httpMinor v)) (responseVersion r)+ , responseHeaders = HTTP.responseHeaders r+ , responseBody = HTTP.responseBody r+ }++defaultTimeout :: Maybe Int+defaultTimeout = Just (1000 * 1000 * 60 * 5)++splitHost :: String -> (String, String)+splitHost hst = break (== '/') hst++doRequest :: (ApiStateC m, MonadIO m) => ApiRequest -> m (Response L.ByteString)+doRequest (ApiRequest m ur ps rhds bd) =+ do mn <- fmap manager askApiInfo+ hst <- fmap apiHost askApiInfo+ prt <- fmap apiPort askApiInfo+ hds <- fmap headers askApiInfo+ jar <- fmap cookies getApiState+ let (h, p) = splitHost hst+ req = def+ { HTTP.method = CH.pack m+ , host = CH.pack h+ , port = prt+ , path = CH.pack (p ++ "/" ++ ur)+ , queryString = (renderQuery False . simpleQueryToQuery . Prelude.map (CH.pack *** CH.pack)) ps+ , HTTP.requestHeaders = rhds ++ Prelude.map (fromString *** CH.pack) hds+ , HTTP.requestBody = RequestBodyLBS bd+ , checkStatus = (\_ _ _ -> Nothing)+ , redirectCount = 0+ , responseTimeout = defaultTimeout+ , cookieJar = Just jar+ }+ res <- httpLbs req mn+ putApiState (ApiState (jar `mappend` responseCookieJar res))+ return res++parseResult :: (L.ByteString -> Reason e) -> (L.ByteString -> a) -> Response L.ByteString -> ApiResponse e a+parseResult e c res = convertResponse $+ case HTTP.statusCode (HTTP.responseStatus res) of+ 200 -> fmap (Right . c) res+ _ -> fmap (Left . e) res++fromJSON :: FromJSON a => L.ByteString -> a+fromJSON v = (fromMaybe err . decodeV) v+ where err = error ("Error parsing JSON in api binding, this should not happen: " ++ L.toString v)++toJSON :: ToJSON a => a -> L.ByteString+toJSON = encode++class XmlStringToType a where+ fromXML :: L.ByteString -> a+ toXML :: a -> L.ByteString++instance XmlStringToType String where+ fromXML = L.toString+ toXML = L.fromString++instance XmlPickler a => XmlStringToType a where+ fromXML v = ( either err id+ . P.eitherFromXML+ . L.toString+ ) v+ where err = error ("Error parsing XML in api binding, this should not happen: " ++ L.toString v)+ toXML = L.fromString . P.toXML+