craze (empty) → 0.0.1.1

raw patch · 8 files changed

+410/−0 lines, 8 filesdep +HTTPdep +asyncdep +basesetup-changed

Dependencies added: HTTP, async, base, bytestring, craze, curl, data-default-class, doctest, doctest-discover, haxy, hspec, hspec-discover, http-types, optparse-generic, text, transformers

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• app/Main.hs +38/−0
• craze.cabal +91/−0
• src/Network/Craze.hs +189/−0
• test/Doctest.hs +1/−0
• test/Network/CrazeSpec.hs +58/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,30 @@+Copyright Eduardo Trujillo (c) 2016++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 Eduardo Trujillo 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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++module Main (main) where++import Data.Text (Text)+import Network.Craze+import Options.Generic (ParseRecord, Generic, getRecord, unHelpful, (<?>)(..))++data Options = Options+  { clients :: Int <?> "Number of concurrent clients to use."+  , targetUri :: String <?> "Target URI for the GET request."+  , debug :: Bool+  }+  deriving (Generic, Show)++instance ParseRecord Options++getOptions :: Text -> IO Options+getOptions = getRecord++main :: IO ()+main = do+  opts <- getOptions "Craze"++  let clientCount = (unHelpful . clients) opts+  let racer = defaultRacer+               { racerProviders = map ((const . return) []) [1..clientCount]+               , racerDebug = (debug opts)+               }++  result <- raceGet racer ((unHelpful . targetUri) opts)++  print result+  return ()+

@@ -0,0 +1,91 @@+-- This file has been generated from package.yaml by hpack version 0.9.0.+--+-- see: https://github.com/sol/hpack++name:                craze+version:             0.0.1.1+synopsis:            HTTP Racing Library+description:         A micro-library for racing HTTP GET requests+homepage:            https://github.com/etcinit/craze#readme+bug-reports:         https://github.com/etcinit/craze/issues+license:             MIT+license-file:        LICENSE+maintainer:          Eduardo Trujillo <ed@chromabits.com>+category:            Web+build-type:          Simple+cabal-version:       >= 1.10++source-repository head+  type: git+  location: https://github.com/etcinit/craze++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >= 4.7 && < 5+    , curl+    , bytestring+    , transformers+    , async+    , data-default-class+  exposed-modules:+      Network.Craze+  default-language: Haskell2010++executable craze-example+  main-is: Main.hs+  hs-source-dirs:+      app+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind+  build-depends:+      base >= 4.7 && < 5+    , curl+    , bytestring+    , transformers+    , craze+    , optparse-generic+    , text+  default-language: Haskell2010++test-suite craze-spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind+  build-depends:+      base >= 4.7 && < 5+    , curl+    , bytestring+    , transformers+    , craze+    , hspec+    , hspec-discover+    , http-types+    , haxy+    , HTTP+  other-modules:+      Doctest+      Network.CrazeSpec+  default-language: Haskell2010++test-suite craze-doctest+  type: exitcode-stdio-1.0+  main-is: Doctest.hs+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind+  build-depends:+      base >= 4.7 && < 5+    , curl+    , bytestring+    , transformers+    , craze+    , doctest+    , doctest-discover+  other-modules:+      Network.CrazeSpec+      Spec+  default-language: Haskell2010

@@ -0,0 +1,189 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Craze is a small module for performing multiple similar HTTP GET requests+-- in parallel. This is performed through the `raceGet` function, which will+-- perform all the requests and pick the first successful response that passes+-- a certain check, menaing that the parallel requests are essentially racing+-- against each other.+--+-- __What is the usefulness of this?__+--+-- If you are dealing with data source or API that is very unreliable (high+-- latency, random failures) and there are no limitations or consequences on+-- perfoming significantly more requests, then performing multiple requests+-- (through direct connections, proxies, VPNs) may increase the chances of+-- getting a successful response faster and more reliably.+--+-- However, if using a different data source or transport is a possibility, it+-- is potentially a better option that this approach.+--+-- __Examples:__+--+-- Performing two parallel GET requests against https://chromabits.com and+-- returning the status code of the first successful one:+--+-- >>> :{+--  let racer = (Racer+--                { racerProviders = [return [], return []]+--                , racerHandler = return . respStatus+--                , racerChecker = (200 ==)+--                , racerDebug = False+--                } :: Racer [(String, String)] ByteString Int)+--  in (raceGet racer "https://chromabits.com" >>= print)+-- :}+-- Just 200+--+module Network.Craze (+  -- * Types+    RacerHandler+  , RacerChecker+  , Racer(..)+  -- * Functions+  , defaultRacer+  , raceGet+  ) where++import Data.ByteString (ByteString)+import Data.Default.Class (Default, def)+import Network.Curl+import Control.Concurrent.Async++-- | A `RacerHandler` is simply a function for transforming a response after it+-- is received. The handler is only applied to successful requests before they+-- are checked by the `RacerChecker`.+--+-- This is primarily for extracting or parsing a `CurlResponse_` before doing+-- any further work. The type returned by the handler will be used as the+-- input of the checker and will be the return type of `raceGet`.+type RacerHandler headerTy bodyTy a = CurlResponse_ headerTy bodyTy -> IO a++-- | A function that computes whether or not a result is valid or not.+-- Successful responses that do not pass the checker are discarded.+--+-- This should help filtering out successful responses that do not, for some+-- reason, have the expected result (e.g. Random content changes, Rate+-- Limitting, etc).+type RacerChecker a = a -> Bool++-- | A function that returns a list of `CurlOption`s to use for making a+-- request.+type RacerProvider = IO [CurlOption]++-- | A record describing the rules for racing requests.+data Racer headerTy bodyTy a = Racer+  { racerHandler :: RacerHandler headerTy bodyTy a+  , racerChecker :: RacerChecker a+  -- | On a `Racer`, each `RaceProvider` represents a separate client+  -- configuration. When performing a race, each provider will be used to spwan+  -- a client and perform a request. This allows one to control the number of+  -- requests performed and with which `CurlOption`s.+  , racerProviders :: [RacerProvider]+  -- | When set to `True`, debugging messages will be written to stdout.+  , racerDebug :: Bool+  }++instance Default (Racer [(String,String)] ByteString ByteString) where+  def = Racer+    { racerHandler = return . respBody+    , racerChecker = const True+    , racerProviders = []+    , racerDebug = False+    }++-- | A `Racer` with some default values.+--+-- __Note:__ The handler will extract the response body as a `ByteString` and+-- ignore everything else, hence the type:+--+-- @+-- Racer [(String, String)] ByteString ByteString+-- @+--+-- If this is not the desired behavior, or if the response should be parsed or+-- processed, you should use the `Racer` constructor directly and provide all +-- fields.+defaultRacer :: Racer [(String,String)] ByteString ByteString+defaultRacer = def++-- | Perform a GET request on the provided URL using all providers in+-- parallel.+--+-- Rough summary of the algorithm:+--+-- - Start all requests+-- - Wait for a request to finish.+--+--     * If the request is successful, apply the handler on it.+--+--         - If the result of the handler passes the checker, cancel all other+--           requests, and return the result.+--         - If the check fails, go back to waiting for another request to finish.+--+--     * If the request fails, go back to waiting for another request to finish.+--+raceGet+  :: (Eq a, CurlHeader ht, CurlBuffer bt)+  => Racer ht bt a+  -> URLString+  -> IO (Maybe a)+raceGet r url = do+  asyncs <- mapM performGetAsync_ (racerProviders r)++  if (racerDebug r) +  then do+    putStr "[racer] Created Asyncs: "+    print (map asyncThreadId asyncs)+  else return ()++  waitForOne asyncs (racerHandler r) (racerChecker r) (racerDebug r)+    where+      performGetAsync_+        :: (CurlHeader ht, CurlBuffer bt)+        => RacerProvider+        -> IO (Async (CurlResponse_ ht bt))+      performGetAsync_ = performGetAsync url++waitForOne+  :: (Eq a)+  => [Async (CurlResponse_ ht bt)]+  -> RacerHandler ht bt a+  -> RacerChecker a+  -> Bool+  -> IO (Maybe a)+waitForOne asyncs handler check debug+  = if null asyncs then pure Nothing else do+    winner <- waitAnyCatch asyncs++    case winner of+      (as, Right a) -> do+        result <- handler a++        if check result then do+          cancelAll (except as asyncs)++          if debug +          then do+            putStr "[racer] Winner: "+            print (asyncThreadId as)+          else return ()++          pure $ Just result+        else waitForOne (except as asyncs) handler check debug+      (as, Left _) -> waitForOne (except as asyncs) handler check debug++cancelAll :: [Async a] -> IO ()+cancelAll = mapM_ (async . cancel)++except :: (Eq a) => a -> [a] -> [a]+except x xs = filter (x /=) xs++performGetAsync+  :: (CurlHeader ht, CurlBuffer bt)+  => URLString+  -> RacerProvider+  -> IO (Async (CurlResponse_ ht bt))+performGetAsync url provider = async $ provider >>= curlGetResponse_ url+

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF doctest-discover -optF doctest.json #-}

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.CrazeSpec where++import Test.Hspec+import Control.Concurrent+import Control.Monad.IO.Class+import Data.ByteString (ByteString, isInfixOf)+import Network.Craze+import Network.Curl+import Network.HTTP.Proxy.Server+import Network.HTTP.Base hiding (port)++oneSecond :: Int+oneSecond = 1000000++runDelayedProxy :: Integer -> Int -> ByteString -> IO ()+runDelayedProxy port delay fixedBody = proxyMain (def :: Settings ByteString)+  { responseModifier = (\_ res +      -> threadDelay (delay * oneSecond) +      >> return (res { rspBody = fixedBody})+      )+  , portnum = port+  , hostname = Just "localhost"+  }++racer :: Racer [(String, String)] ByteString ByteString+racer = Racer+  { racerHandler = \res -> return (respBody res)+  , racerChecker = \x -> not (isInfixOf "Something" x)+  , racerProviders+      = [pure [CurlProxy "localhost", CurlProxyPort 8082]+      , pure [CurlProxy "localhost", CurlProxyPort 8083]+      , pure [CurlProxy "localhost", CurlProxyPort 8084]+      ]+  , racerDebug = True+  }++spec :: Spec+spec = describe "Network.Craze" $+  describe "raceGet" $+    it "should race GET requests" $ do+      proxies <- mapM (liftIO . forkIO)+        [runDelayedProxy 8082 5 "Hoogle"+        ,runDelayedProxy 8083 2 "Hayoo"+        ,runDelayedProxy 8084 1 "Something"+        ]++      liftIO $ threadDelay (1 * oneSecond) >> putStrLn "Waited 1 secs..."++      response <- liftIO $ raceGet racer "http://www.google.com"++      liftIO $ mapM_ killThread proxies++      response `shouldSatisfy`+        \x -> case x of+          Just a -> isInfixOf "Hayoo" a+          Nothing -> False

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}