我创建了一个用于与Iron.IO消息排队服务交谈的库。代码使用Wreq并且非常简单：
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IronMQ.Types where
import Data.Aeson.TH
import Data.Aeson.Types (camelTo)
import Data.Text (Text)
import Data.Char (toLower)
data Client = Client {
token :: Text,
projectID :: Text,
server :: Text,
apiVersion :: Text
} deriving (Show)
data QueueSummary = QueueSummary {
qsId :: Text,
qsProjectId :: Text,
qsName :: Text
} deriving (Show)
$(deriveJSON defaultOptions{fieldLabelModifier = drop 3.camelTo '_', constructorTagModifier = map toLower, omitNothingFields = True} ''QueueSummary)
data Message = Message {
mId :: Maybe Text,
mBody :: Text,
mTimeout :: Maybe Int,
mReservedCount :: Maybe Int
} deriving (Show)
$(deriveJSON defaultOptions{fieldLabelModifier = drop 2.camelTo '_', constructorTagModifier = map toLower, omitNothingFields = True} ''Message)
{-# LANGUAGE OverloadedStrings #-}
module Network.IronMQ (
Client(..),
queue,
message,
queues,
getQueue,
getMessages',
getMessages,
getMessageById,
postMessages,
clear,
deleteQueue,
deleteMessage,
peek',
peek,
touch,
release,
update
) where
import Network.Wreq
import Network.Wreq.Types (Postable)
import Control.Lens
import Data.Aeson (FromJSON, toJSON)
import Data.Map (fromList, Map)
import Data.Text (Text, append, unpack, pack)
import Data.Text.Encoding (encodeUtf8)
import Network.IronMQ.Types
import Network.HTTP.Client (RequestBody(..))
-- * Some type synonyms to help keep track of things
type Endpoint = Text
type Param = (Text, Text)
type QueueName = Text
type ID = Text -- could be a message ID, subscriber ID or whatever
-- * Some functions to make HTTP requests easier
-- | Construct a base URL for HTTP requests from a client
baseurl :: Client -> Text
baseurl client = "https://" `append` server client `append` "/" `append` apiVersion client
`append` "/projects/" `append` projectID client
-- | An empty body for POST/PUT requests
emptyBody :: Payload
emptyBody = Raw "application/json" $ RequestBodyLBS ""
-- | Make a GET request to an endpoint using connection info from client and
-- query string set to parameters. Return the JSON results
getJSONWithOpts :: FromJSON a => Client -> Endpoint -> [Param] -> IO a
getJSONWithOpts client endpoint parameters = do
let url = baseurl client `append` endpoint
getOpts = defaults & header "Content-Type" .~ ["application/json"]
& params .~ ("oauth", token client) : parameters
response <- asJSON =<< getWith getOpts (unpack url)
return (response ^. responseBody)
-- | Make a GET request to an endpoint using the connection info from client.
-- Return the JSON results.
getJSON ::FromJSON a => Client -> Endpoint -> IO a
getJSON client s = getJSONWithOpts client s []
-- | Make a POST a request to an endpoint using connection info from client
-- and the body provided. Return the JSON response.
postJSONWithBody :: (Postable a, FromJSON b) => Client -> Endpoint -> a -> IO b
postJSONWithBody client endpoint body = do
let url = baseurl client `append` endpoint
postOpts = defaults
& header "Content-Type" .~ ["application/json"]
& header "Authorization" .~ [encodeUtf8 ("OAuth " `append` token client)]
response <- asJSON =<< postWith postOpts (unpack url) body
return (response ^. responseBody)
-- | Make a POST request to an endpoint using the connection into from client
-- and an empty body. Returb the JSON response.
postJSON :: (FromJSON b) => Client -> Endpoint -> IO b
postJSON client endpoint = postJSONWithBody client endpoint emptyBody
deleteJSON :: FromJSON a => Client ->Endpoint -> IO a
deleteJSON client endpoint = do
let url = baseurl client `append` endpoint
deleteOpts = defaults
& header "Content-Type" .~ ["application/json"]
& header "Authorization" .~ [encodeUtf8 ("OAuth " `append` token client)]
response <- asJSON =<< deleteWith deleteOpts (unpack url)
return (response ^. responseBody)
-- | Get a list of queues available to the client
queues :: Client -> IO [QueueSummary]
queues client = getJSON client "/queues"
-- | Get a queue from the client
getQueue :: Client -> QueueName -> IO Queue
getQueue client queueName = getJSON client ("/queues/" `append` queueName)
-- | Get a list of messages on the queue (allowing specification of number of messages and delay)
getMessages' :: Client -> QueueName -> Maybe Int -> Maybe Int -> IO MessageList
getMessages' client queueName max_ timeout = getJSONWithOpts client endpoint params' where
endpoint = "/queues/" `append` queueName `append` "/messages"
params' = case (max_, timeout) of
(Nothing, Nothing) -> []
(Just x, Nothing) -> [("n", pack (show x))]
(Nothing, Just y) -> [("wait", pack (show y))]
(Just x, Just y) -> [("n", pack (show x)), ("wait", pack (show y))]
-- | Get a list of messages on a queue
getMessages :: Client -> QueueName -> IO MessageList
getMessages client queueName = getMessages' client queueName Nothing Nothing
-- | Get a message by ID
getMessageById :: Client -> QueueName -> ID -> IO Message
getMessageById client queueName messageID = getJSON client
("/queues/" `append` queueName `append` "/messages/" `append` messageID)
-- | Post messages to a queue
postMessages :: Client -> QueueName -> [Message] -> IO IronResponse
postMessages client queueName messages_ = postJSONWithBody client endpoint body where
endpoint = "/queues/" `append` queueName `append` "/messages"
body = toJSON MessageList {mlMessages = messages_}
-- | Delete a message from a queue
deleteMessage :: Client -> QueueName -> ID -> IO IronResponse
deleteMessage client queueName messageID = deleteJSON client endpoint where
endpoint = "/queues/" `append` queueName `append` "/messages/" `append` messageID
我使用Wreq库运行基准测试：
{-# LANGUAGE OverloadedStrings #-}
import Criterion.Main
import Network.IronMQ
import Network.IronMQ.Types
main :: IO ()
main = defaultMain [bench "get queue info, post a message, get messages, delete message" $ nfIO (doStuff)]
testClient :: Client
testClient = Client {
token = "secret token",
projectID = "secret project id",
server = "mq-aws-us-east-1.iron.io",
apiVersion = "1"
}
doStuff :: IO ()
doStuff = do
_ <- queues testClient
postMessages testClient "default" [message{mBody = "This is message number "}]
messageList <- getMessages testClient "default"
let messageID = mId (head (mlMessages messageList))
case messageID of
Just x -> deleteMessage testClient "default" x
return ()
现在基准测试工具告诉我代码平均需要1.4秒才能运行。我写了一个相应的python程序，平均花费0.10秒（最多10次重复0.24秒）来执行相同的任务。
我是初学者Haskell程序员，所以我知道这段代码可能还有很大的改进空间。有人能指出我如何能够获得与Haskell的python代码相当的性能吗？