Browse files

Add support for setting HTTP manager and proxy

This basically supercharges the library - performance goes way up when a
manager is specified.
  • Loading branch information...
1 parent cb2b2cf commit 38eee738822f8080bc170ea1269d0ed0978dfad8 @AaronFriel committed Dec 17, 2012
View
7 src/Network/TableStorage/API.hs
@@ -31,12 +31,13 @@ import Data.Time.Clock ( getCurrentTime )
import Data.Maybe ( fromMaybe )
import Control.Monad.Reader
import Control.Monad.Error
+import Control.Monad.Trans.Resource
-- |
-- Runs TableStorage actions given a configuration
--
withTableStorage :: TableConf -> TableStorage a -> IO (Either TableError a)
-withTableStorage conf f = runReaderT (runErrorT f) conf
+withTableStorage conf f = runResourceT (runReaderT (runErrorT f) conf)
-- |
-- Simple helper function to convert non-monadic parser results into the monadic result
@@ -135,7 +136,7 @@ updateOrMergeEntity :: Method -> String -> Entity -> TableStorage ()
updateOrMergeEntity method tableName entity = do
let resource = entityKeyResource tableName $ entityKey entity
let additionalHeaders = [ ("If-Match", "*") ]
- (TableConf _ acc) <- ask
+ acc <- fmap tableAccount ask
requestXml <- liftIO $ createInsertEntityXml entity (Just $
accountScheme acc ++ "://" ++ accountHost acc ++ resource)
response <- authenticatedRequest method additionalHeaders resource resource $ showTopElement requestXml
@@ -242,4 +243,4 @@ defaultAccount key name hostname = Account { accountScheme = "http:
accountResourcePrefix = "" }
defaultConf :: AccountKey -> String -> String -> TableConf
-defaultConf key name hostname = TableConf Nothing $ defaultAccount key name hostname
+defaultConf key name hostname = TableConf (defaultAccount key name hostname) Nothing Nothing
View
8 src/Network/TableStorage/Auth.hs
@@ -37,6 +37,7 @@ import Debug.Trace
import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource
authenticationType :: String
authenticationType = "SharedKey"
@@ -103,7 +104,7 @@ qualifyResource res acc =
authenticatedRequest :: Method -> [Header] -> String -> String -> String -> TableStorage QueryResponse
authenticatedRequest method hdrs resource canonicalizedResource body = do
time <- liftIO $ rfc1123Date
- (TableConf mgr acc) <- ask
+ (TableConf acc maybeMgr maybeProxy) <- ask
let contentMD5 = (Base64C.encode . hash . UTF8.fromString) body
let atomType = "application/atom+xml" :: B.ByteString
let auth = SharedKeyAuth { sharedKeyAuthVerb = method
@@ -126,7 +127,10 @@ authenticatedRequest method hdrs resource canonicalizedResource body = do
, requestBody = RequestBodyBS $ UTF8.fromString body
, redirectCount = 0
, checkStatus = \_ _ -> Nothing
+ , proxy = maybeProxy
}
request <- setUri defaultReq uri
- response <- withManager (httpLbs request)
+ response <- case maybeMgr of
+ Just mgr -> runResourceT $ httpLbs request mgr
+ Nothing -> withManager (httpLbs request)
return $ QueryResponse (responseStatus response) (UTF8L.toString $ responseBody response)
View
2 src/Network/TableStorage/Development.hs
@@ -21,4 +21,4 @@ developmentAccount = Account { accountScheme = "http:",
accountKey = AccountKey "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="}
developmentConf :: TableConf
-developmentConf = TableConf Nothing developmentAccount
+developmentConf = TableConf developmentAccount Nothing Nothing
View
8 src/Network/TableStorage/Types.hs
@@ -24,12 +24,14 @@ import Network.HTTP.Types
import Network.HTTP.Conduit
import Control.Monad.Reader
import Control.Monad.Error
+import Control.Monad.Trans.Resource
-type TableStorage = ErrorT TableError (ReaderT TableConf IO)
+type TableStorage = ErrorT TableError (ReaderT TableConf (ResourceT IO))
data TableConf = TableConf
- { manager :: Maybe Manager
- , account :: Account
+ { tableAccount :: Account
+ , httpManager :: Maybe Manager
+ , httpProxy :: Maybe Proxy
}
-- |
View
5 tablestorage.cabal
@@ -1,5 +1,5 @@
name: tablestorage
-version: 0.2.0.0
+version: 0.2.1.0
cabal-version: >= 1.2
build-type: Simple
author: Phil Freeman, Aaron Friel
@@ -39,7 +39,8 @@ library
transformers,
crypto-api,
cryptohash,
- HTTP
+ HTTP,
+ resourcet
ghc-options: -Wall
exposed-modules:
Network.TableStorage,

0 comments on commit 38eee73

Please sign in to comment.