为什么我的haskell代码这么慢

Question

我创建了一个用于与 Iron.IO 消息队列服务通信的库。代码使用 Wreq，非常简单：

网络/IronMQ/Types.hs

{-# 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)

网络/IronMQ.hs

{-# 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 库运行基准测试：

bench/Benchmark.hs

{-# 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 代码相当的性能吗？

Answer 1

使用 Session 确保 Wreq 在您的请求中重复使用连接。示例见multiple requests。