diff --git a/craze.cabal b/craze.cabal --- a/craze.cabal +++ b/craze.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: craze -version: 0.1.1.0 +version: 0.1.2.0 synopsis: HTTP Racing Library description: A micro-library for racing HTTP GET requests homepage: https://github.com/etcinit/craze#readme diff --git a/src/Network/Craze.hs b/src/Network/Craze.hs --- a/src/Network/Craze.hs +++ b/src/Network/Craze.hs @@ -35,6 +35,7 @@ -- , racerHandler = return . respStatus -- , racerChecker = (200 ==) -- , racerDebug = False +-- , racerReturnLast = False -- } :: Racer [(String, String)] ByteString Int) -- in (raceGet racer "https://chromabits.com" >>= print) -- :} @@ -103,7 +104,7 @@ -- | Number of microseconds to delay the request by. , poDelay :: Maybe Int -- | A tag to identify this type provider. - , poTag :: Text + , poTag :: Text } deriving (Show) instance Default ProviderOptions where @@ -123,15 +124,19 @@ -- | A record describing the rules for racing requests. data Racer headerTy bodyTy a = Racer - { racerHandler :: RacerHandler headerTy bodyTy a - , racerChecker :: RacerChecker a + { 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] + , racerProviders :: [RacerProvider] -- | When set to `True`, debugging messages will be written to stdout. - , racerDebug :: Bool + , racerDebug :: Bool + -- | When set to `True`, the Racer will attempt to return the last response + -- in the event that all responses failed to pass the checker. This can be + -- used for identifying error conditions. + , racerReturnLast :: Bool } instance Default (Racer [(String,String)] ByteString ByteString) where @@ -140,6 +145,7 @@ , racerChecker = const True , racerProviders = [] , racerDebug = False + , racerReturnLast = False } -- | A `Racer` with some default values. @@ -197,9 +203,11 @@ -- -- - 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 check fails, go back to waiting for another request to +-- finish. -- --- * If the request 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) @@ -216,14 +224,14 @@ -> URLString -> IO (RacerResult a) raceGetResult r url = do - asyncs <- fromList <$> (mapM performGetAsync_ (racerProviders r)) + asyncs <- fromList <$> mapM performGetAsync_ (racerProviders r) when (racerDebug r) $ do TIO.putStr "[racer] Created Asyncs: " print . elems $ mapWithKey identifier asyncs maybeResponse <- waitForOne - asyncs (racerHandler r) (racerChecker r) (racerDebug r) + asyncs (racerHandler r) (racerChecker r) (racerDebug r) (racerReturnLast r) pure $ case maybeResponse of Nothing -> RacerResult @@ -249,8 +257,9 @@ -> RacerHandler ht bt a -> RacerChecker a -> Bool + -> Bool -> IO (Maybe (Async (CurlResponse_ ht bt), a)) -waitForOne asyncs handler check debug +waitForOne asyncs handler check debug returnLast = if null asyncs then pure Nothing else do winner <- waitAnyCatch (keys asyncs) @@ -258,25 +267,33 @@ (as, Right a) -> do result <- handler a + let remaining = delete as asyncs + if check result then do - cancelAll (keys $ delete as asyncs) + cancelAll (keys remaining) when debug $ do TIO.putStr "[racer] Winner: " print (asyncThreadId as) pure $ Just (as, result) - else waitForOne (delete as asyncs) handler check debug - (as, Left _) -> waitForOne (delete as asyncs) handler check debug + else (if returnLast && null remaining + then do + when debug $ do + TIO.putStr "[racer] Reached last. Returning: " + print (asyncThreadId as) + pure $ Just (as, result) + else waitForOne remaining handler check debug returnLast + ) + (as, Left _) -> waitForOne + (delete as asyncs) handler check debug returnLast + cancelAll :: [Async a] -> IO () cancelAll = mapM_ (async . cancel) -except :: (Eq a) => a -> [a] -> [a] -except x = filter (x /=) - -identifier :: (Async (CurlResponse_ ht bt)) -> ProviderOptions -> Text -identifier a o = (poTag o) <> ":" <> (pack . show . asyncThreadId $ a) +identifier :: Async (CurlResponse_ ht bt) -> ProviderOptions -> Text +identifier a o = poTag o <> ":" <> (pack . show . asyncThreadId $ a) performGetAsync :: (CurlHeader ht, CurlBuffer bt) diff --git a/test/Network/CrazeSpec.hs b/test/Network/CrazeSpec.hs --- a/test/Network/CrazeSpec.hs +++ b/test/Network/CrazeSpec.hs @@ -16,18 +16,17 @@ runDelayedProxy :: Integer -> Int -> ByteString -> IO () runDelayedProxy port delay fixedBody = proxyMain (def :: Settings ByteString) - { responseModifier = (\_ res + { 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) + { racerHandler = pure . respBody + , racerChecker = not . isInfixOf "Something" , racerProviders = [simple [CurlProxy "localhost", CurlProxyPort 8082] , simple [CurlProxy "localhost", CurlProxyPort 8083] @@ -35,11 +34,24 @@ , delayed [CurlProxy "localhost", CurlProxyPort 8085] 2000000 ] , racerDebug = True + , racerReturnLast = False } +failingRacer :: Racer [(String, String)] ByteString ByteString +failingRacer = racer + { racerChecker = isInfixOf "OMG WHY" + , racerReturnLast = True + , racerProviders + = [simple [CurlProxy "localhost", CurlProxyPort 8086] + , simple [CurlProxy "localhost", CurlProxyPort 8087] + , simple [CurlProxy "localhost", CurlProxyPort 8088] + , delayed [CurlProxy "localhost", CurlProxyPort 8089] 2000000 + ] + } + spec :: Spec spec = describe "Network.Craze" $ - describe "raceGet" $ + describe "raceGet" $ do it "should race GET requests" $ do proxies <- mapM (liftIO . forkIO) [ runDelayedProxy 8082 5 "Hoogle" @@ -56,5 +68,24 @@ response `shouldSatisfy` \x -> case x of - Just a -> isInfixOf "Hayoo" a + Just a -> "Hayoo" `isInfixOf` a Nothing -> False + it "should return the last when requested" $ do + proxies <- mapM (liftIO . forkIO) + [ runDelayedProxy 8086 10 "Hoogle" + , runDelayedProxy 8087 2 "Hayoo" + , runDelayedProxy 8088 1 "Something" + , runDelayedProxy 8089 1 "Slow" + ] + + liftIO $ threadDelay (1 * oneSecond) >> putStrLn "Waited 1 secs..." + + response <- liftIO $ raceGet failingRacer "http://www.google.com" + + liftIO $ mapM_ killThread proxies + + response `shouldSatisfy` + \x -> case x of + Just a -> "Hoogle" `isInfixOf` a + Nothing -> False +