Skip to content

Instantly share code, notes, and snippets.

@hyone
Created October 25, 2012 04:49
Show Gist options
  • Save hyone/3950460 to your computer and use it in GitHub Desktop.
Save hyone/3950460 to your computer and use it in GitHub Desktop.
Multiple async HTTP requests by Haskell
{-# LANGUAGE FlexibleContexts #-}
import Data.Conduit
import qualified Data.Conduit.List as CL
import Network.HTTP.Conduit
import Control.Concurrent.Async (mapConcurrently)
import Control.Concurrent.MVar
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.ByteString (ByteString)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Network.HTTP.Types.Status (statusCode)
import Text.Printf (printf)
genUrl :: String -> String
genUrl = ("http://www.google.com/search?q="++)
urls = map genUrl ["Clojure", "Haskell", "OCaml", "Scala", "F#"]
++ ["http://127.0.0.1:3000/"]
++ map genUrl ["Ruby", "Python", "Perl", "PHP", "JavaScript"]
curl :: (MonadResource m, MonadBaseControl IO m) =>
String -> m (Response (ResumableSource m ByteString))
curl url = do
request <- liftIO $ parseUrl url
manager <- liftIO $ newManager def
http (request { checkStatus = \_ _ -> Nothing,
responseTimeout = Just 10000000 }) manager
operation :: MVar a -> Int -> String -> IO ()
operation lock i url = runResourceT $ do
start <- liftIO getCurrentTime
Response status _ _ body <- curl url
body $$+- CL.consume
end <- liftIO getCurrentTime
liftIO $ withMVar lock $ \_ ->
printf "%8.3f: %2d: %s => %d\n"
(realToFrac (diffUTCTime end start) :: Double)
i url (statusCode status)
main :: IO ()
main = do
lock <- newMVar ()
mapConcurrently (uncurry (operation lock)) $ zip [1..] urls
return ()
-- To check async process, prepare a long time request:
-- $ plackup -p 3000 -e 'sub { sleep 5; return [200, ["Content-Type" => "text/plain"], ["Hello World."]] }'
-- ghci> main
-- 0.219: 4: http://www.google.com/search?q=Scala => 200
-- 0.230: 1: http://www.google.com/search?q=Clojure => 200
-- 0.228: 8: http://www.google.com/search?q=Python => 200
-- 0.249: 2: http://www.google.com/search?q=Haskell => 200
-- 0.257: 9: http://www.google.com/search?q=Perl => 200
-- 0.257: 10: http://www.google.com/search?q=PHP => 200
-- 0.264: 5: http://www.google.com/search?q=F# => 200
-- 0.267: 7: http://www.google.com/search?q=Ruby => 200
-- 0.515: 11: http://www.google.com/search?q=JavaScript => 200
-- 0.746: 3: http://www.google.com/search?q=OCaml => 200
-- 5.044: 6: http://127.0.0.1:3000/ => 200
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment