From 892c15f35c4fde353669e73ab358712c52f64829 Mon Sep 17 00:00:00 2001 From: Remeike Forbes Date: Sat, 11 Jun 2022 08:43:06 -0400 Subject: [PATCH 01/36] Catch but do not thread job execution --- src/System/Hworker.hs | 21 ++++++++++++++------- test/Spec.hs | 6 +++--- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 7af19a7..e90f754 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -72,7 +72,9 @@ module System.Hworker import Control.Arrow (second) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -import Control.Exception (SomeException, catch) +import Control.Exception (SomeException, catchJust, + asyncExceptionFromException, + AsyncException) import Control.Monad (forM, forever, void, when) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as A @@ -81,7 +83,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB import Data.Either (isRight) -import Data.Maybe (fromJust, mapMaybe) +import Data.Maybe (fromJust, isJust, mapMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -340,11 +342,16 @@ worker hw = where delayAndRun = threadDelay 10000 >> worker hw justRun = worker hw runJob v = - do x <- newEmptyMVar - jt <- forkIO (catch (v >>= putMVar x . Right) - (\(e::SomeException) -> - putMVar x (Left e))) - res <- takeMVar x + do res <- + catchJust + ( \(e :: SomeException) -> + if isJust (asyncExceptionFromException e :: Maybe AsyncException) then + Nothing + else + Just e + ) + ( Right <$> v ) + ( \e -> return (Left e) ) case res of Left e -> let b = case hworkerExceptionBehavior hw of diff --git a/test/Spec.hs b/test/Spec.hs index 5feabc6..15f4f85 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -265,7 +265,7 @@ main = hspec $ threadDelay 10000000 destroy hworker v <- takeMVar mvar - assertEqual "State should be 2, since monitor thinks it failed" 2 v + assertEqual "State should be 1, since first failed" 1 v it "should add back multiple jobs after timeout" $ -- NOTE(dbp 2015-07-23): Similar to the above test, but we -- have multiple jobs started, multiple workers killed. @@ -287,7 +287,7 @@ main = hspec $ threadDelay 10000000 destroy hworker v <- takeMVar mvar - assertEqual "State should be 4, since monitor thinks first 2 failed" 4 v + assertEqual "State should be 2, since first 2 failed" 2 v it "should work with multiple monitors" $ do mvar <- newMVar 0 hworker <- createWith (conf "timedworker-3" @@ -313,7 +313,7 @@ main = hspec $ threadDelay 30000000 destroy hworker v <- takeMVar mvar - assertEqual "State should be 4, since monitor thinks first 2 failed" 4 v + assertEqual "State should be 2, since first 2 failed" 2 v -- NOTE(dbp 2015-07-24): It would be really great to have a -- test that went after a race between the retry logic and -- the monitors (ie, assume that the job completed with From a8d1f2bd84057fbe10cee873e6179fb84be2b42a Mon Sep 17 00:00:00 2001 From: remeike Date: Thu, 17 Nov 2022 13:19:15 -0500 Subject: [PATCH 02/36] Add batch ID and counters for batch job --- .gitignore | 3 +- hworker.cabal | 2 + src/System/Hworker.hs | 126 ++++++++++++++++++++++++++++++++++++++---- stack.yaml | 2 +- 4 files changed, 119 insertions(+), 14 deletions(-) diff --git a/.gitignore b/.gitignore index 499fe60..9e7f383 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ .cabal-sandbox .stack-work cabal.sandbox.config -dist-stack \ No newline at end of file +dist-stack +stack.yaml.lock diff --git a/hworker.cabal b/hworker.cabal index a96105d..9164854 100644 --- a/hworker.cabal +++ b/hworker.cabal @@ -22,6 +22,7 @@ library , time >= 1.5 , attoparsec , uuid >= 1.2.6 + , mtl hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -43,3 +44,4 @@ Test-Suite hworker-test , hspec >= 2 , hspec-contrib , HUnit + , mtl diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index e90f754..ec82659 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| @@ -52,10 +53,12 @@ module System.Hworker , ExceptionBehavior(..) , RedisConnection(..) , defaultHworkerConfig + , BatchID(..) -- * Managing Workers , create , createWith , destroy + , initBatch , worker , monitor -- * Queuing Jobs @@ -76,7 +79,8 @@ import Control.Exception (SomeException, catchJust, asyncExceptionFromException, AsyncException) import Control.Monad (forM, forever, void, when) -import Data.Aeson (FromJSON, ToJSON) +import Control.Monad.Trans (liftIO) +import Data.Aeson (FromJSON, ToJSON, (.=), (.:) ) import qualified Data.Aeson as A import Data.Aeson.Helpers import Data.ByteString (ByteString) @@ -91,6 +95,7 @@ import qualified Data.Text.Encoding as T import Data.Time.Calendar (Day (..)) import Data.Time.Clock (NominalDiffTime, UTCTime (..), diffUTCTime, getCurrentTime) +import Data.UUID ( UUID ) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import qualified Database.Redis as R @@ -139,6 +144,20 @@ data JobData t = JobData UTCTime t -- intermittent problems). data ExceptionBehavior = RetryOnException | FailOnException +type JobID = Text + +-- | A unique identifier for grouping jobs together. +newtype BatchID = BatchID UUID deriving (ToJSON, FromJSON) + +data JobRef = JobRef JobID (Maybe BatchID) + +instance ToJSON JobRef where + toJSON (JobRef j b) = A.object ["j" .= j, "b" .= b] + +instance FromJSON JobRef where + parseJSON (A.String j) = pure (JobRef j Nothing) + parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b") val + hwlog :: Show a => Hworker s t -> a -> IO () hwlog hw a = hworkerLogger hw (hworkerName hw, a) @@ -262,12 +281,25 @@ brokenQueue hw = "hworker-broken-" <> hworkerName hw failedQueue :: Hworker s t -> ByteString failedQueue hw = "hworker-failed-" <> hworkerName hw +batchCounter :: Hworker s t -> BatchID -> ByteString +batchCounter hw (BatchID batch) = + "hworker-batch-" <> hworkerName hw <> ":" <> UUID.toASCIIBytes batch + -- | Adds a job to the queue. Returns whether the operation succeeded. queue :: Job s t => Hworker s t -> t -> IO Bool queue hw j = - do job_id <- UUID.toString <$> UUID.nextRandom + do job_id <- UUID.toText <$> UUID.nextRandom isRight <$> R.runRedis (hworkerConnection hw) - (R.lpush (jobQueue hw) [LB.toStrict $ A.encode (job_id, j)]) + (R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id Nothing, j)]) + +queueBatch :: Job s t => Hworker s t -> t -> BatchID -> Bool -> IO Bool +queueBatch hw j batch finish = do + job_id <- UUID.toText <$> UUID.nextRandom + R.runRedis (hworkerConnection hw) $ do + result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id (Just batch), j)] + void $ R.hincrby (batchCounter hw batch) "total" 1 + when finish $ void $ R.hset (batchCounter hw batch) "status" "processing" + return $ isRight result -- | Creates a new worker thread. This is blocking, so you will want to -- 'forkIO' this into a thread. You can have any number of these (and @@ -302,13 +334,16 @@ worker hw = [progressQueue hw, brokenQueue hw] [t, LB.toStrict $ A.encode now]) delayAndRun - Just (_ :: String, j) -> do + Just (JobRef _ maybeBatch, j) -> do result <- runJob (job (hworkerState hw) j) case result of Success -> do when (hworkerDebug hw) $ hwlog hw ("JOB COMPLETE", t) delete_res <- R.runRedis (hworkerConnection hw) (R.hdel (progressQueue hw) [t]) + case maybeBatch of + Nothing -> return () + Just batch -> incBatchSuccesses hw batch case delete_res of Left err -> hwlog hw err >> delayAndRun Right 1 -> justRun @@ -324,6 +359,9 @@ worker hw = \return nil" [progressQueue hw, jobQueue hw] [t]) + case maybeBatch of + Nothing -> return () + Just batch -> incBatchRetries hw batch delayAndRun Failure msg -> do hwlog hw ("Failure: " <> msg) @@ -336,6 +374,9 @@ worker hw = \return nil" [progressQueue hw, failedQueue hw] [t, B8.pack (show (hworkerFailedQueueSize hw - 1))]) + case maybeBatch of + Nothing -> return () + Just batch -> incBatchFailures hw batch void $ R.runRedis (hworkerConnection hw) (R.hdel (progressQueue hw) [t]) delayAndRun @@ -434,6 +475,51 @@ debugger microseconds hw = (\queued -> hwlog hw ("DEBUG", queued, running))) threadDelay microseconds +initBatch :: Hworker s t -> IO BatchID +initBatch hw = do + batch <- BatchID <$> UUID.nextRandom + R.runRedis (hworkerConnection hw) $ + R.hmset (batchCounter hw batch) + [ ("total", "0") + , ("completed", "0") + , ("successes", "0") + , ("failures", "0") + , ("retries", "0") + , ("status", "queuing") + ] + return batch + +incBatchSuccesses :: Hworker s t -> BatchID -> IO () +incBatchSuccesses hw batch = + void $ R.runRedis (hworkerConnection hw) $ do + void $ withInt' hw $ R.hincrby (batchCounter hw batch) "successes" 1 + completeBatch hw batch + +incBatchFailures :: Hworker s t -> BatchID -> IO () +incBatchFailures hw batch = + void $ R.runRedis (hworkerConnection hw) $ do + void $ withInt' hw $ R.hincrby (batchCounter hw batch) "failures" 1 + completeBatch hw batch + +incBatchRetries :: Hworker s t -> BatchID -> IO () +incBatchRetries hw batch = + void $ R.runRedis (hworkerConnection hw) $ + R.hincrby (batchCounter hw batch) "retries" 1 + +completeBatch :: Hworker s t -> BatchID -> R.Redis () +completeBatch hw batch = do + completed <- withInt' hw $ R.hincrby (batchCounter hw batch) "completed" 1 + total <- withInt' hw $ R.hincrby (batchCounter hw batch) "total" 0 + withMaybe' hw (R.hget (batchCounter hw batch) "status") $ + \status -> + case status of + "processing" | completed >= total -> + void $ R.hset (batchCounter hw batch) "status" "processing" + + _ -> + return () + + -- Redis helpers follow withList hw a f = do r <- R.runRedis (hworkerConnection hw) a @@ -469,3 +555,19 @@ withIgnore hw a = case r of Left err -> hwlog hw err Right _ -> return () + +withInt' :: Hworker s t -> R.Redis (Either R.Reply Integer) -> R.Redis Integer +withInt' hw a = + do r <- a + case r of + Left err -> liftIO (hwlog hw err) >> return (-1) + Right n -> return n + + +withMaybe' :: Hworker s t -> R.Redis (Either R.Reply (Maybe a)) -> (a -> R.Redis ()) -> R.Redis () +withMaybe' hw a f = + do r <- a + case r of + Left err -> liftIO $ hwlog hw err + Right Nothing -> return () + Right (Just v) -> f v diff --git a/stack.yaml b/stack.yaml index e0f6367..6219f0c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,4 +3,4 @@ packages: - '.' - 'example' extra-deps: [] -resolver: lts-3.1 +resolver: lts-18.18 From 51736a265c9056a1f08e0c5441d5c6bf820fd322 Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 18 Nov 2022 11:03:03 -0500 Subject: [PATCH 03/36] Fix jobsFromQueue and kill unused threads in tests --- src/System/Hworker.hs | 10 +++++----- test/Spec.hs | 4 ++++ 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index ec82659..f08672c 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -147,9 +147,9 @@ data ExceptionBehavior = RetryOnException | FailOnException type JobID = Text -- | A unique identifier for grouping jobs together. -newtype BatchID = BatchID UUID deriving (ToJSON, FromJSON) +newtype BatchID = BatchID UUID deriving (ToJSON, FromJSON, Eq, Show) -data JobRef = JobRef JobID (Maybe BatchID) +data JobRef = JobRef JobID (Maybe BatchID) deriving (Eq, Show) instance ToJSON JobRef where toJSON (JobRef j b) = A.object ["j" .= j, "b" .= b] @@ -292,8 +292,8 @@ queue hw j = isRight <$> R.runRedis (hworkerConnection hw) (R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id Nothing, j)]) -queueBatch :: Job s t => Hworker s t -> t -> BatchID -> Bool -> IO Bool -queueBatch hw j batch finish = do +queueBatched :: Job s t => Hworker s t -> t -> BatchID -> Bool -> IO Bool +queueBatched hw j batch finish = do job_id <- UUID.toText <$> UUID.nextRandom R.runRedis (hworkerConnection hw) $ do result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id (Just batch), j)] @@ -451,7 +451,7 @@ jobsFromQueue hw queue = case r of Left err -> hwlog hw err >> return [] Right [] -> return [] - Right xs -> return $ mapMaybe (fmap (\(_::String, x) -> x) . decodeValue . LB.fromStrict) xs + Right xs -> return $ mapMaybe (fmap (\(JobRef _ _, x) -> x) . decodeValue . LB.fromStrict) xs -- | Returns all pending jobs. jobs :: Job s t => Hworker s t -> IO [t] diff --git a/test/Spec.hs b/test/Spec.hs index 15f4f85..31fbbbe 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -193,6 +193,7 @@ main = hspec $ wthread <- forkIO (worker hworker) queue hworker RetryJob threadDelay 50000 + killThread wthread destroy hworker v <- takeMVar mvar assertEqual "State should be 2, since it got retried" 2 v @@ -205,6 +206,7 @@ main = hspec $ wthread <- forkIO (worker hworker) queue hworker FailJob threadDelay 30000 + killThread wthread destroy hworker v <- takeMVar mvar assertEqual "State should be 1, since failing run wasn't retried" 1 v @@ -215,6 +217,7 @@ main = hspec $ wthread <- forkIO (worker hworker) queue hworker FailJob threadDelay 30000 + killThread wthread jobs <- failed hworker destroy hworker assertEqual "Should have failed job" [FailJob] jobs @@ -230,6 +233,7 @@ main = hspec $ queue hworker AlwaysFailJob queue hworker AlwaysFailJob threadDelay 100000 + killThread wthread jobs <- failed hworker destroy hworker v <- takeMVar mvar From a4618a7c92091c6d52659852d8573426bc8b45cc Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 18 Nov 2022 12:23:34 -0500 Subject: [PATCH 04/36] Add batch job type and tests --- src/System/Hworker.hs | 70 ++++++++++++++++++++++++++++++++++---- test/Spec.hs | 78 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 142 insertions(+), 6 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index f08672c..ccf0afa 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -54,15 +54,19 @@ module System.Hworker , RedisConnection(..) , defaultHworkerConfig , BatchID(..) + , BatchStatus(..) + , BatchJob(..) -- * Managing Workers , create , createWith , destroy - , initBatch + , batchJob , worker , monitor -- * Queuing Jobs , queue + , queueBatched + , initBatch -- * Inspecting Workers , jobs , failed @@ -87,7 +91,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB import Data.Either (isRight) -import Data.Maybe (fromJust, isJust, mapMaybe) +import Data.Maybe (fromJust, isJust, mapMaybe, listToMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -149,6 +153,31 @@ type JobID = Text -- | A unique identifier for grouping jobs together. newtype BatchID = BatchID UUID deriving (ToJSON, FromJSON, Eq, Show) +data BatchStatus = BatchQueuing | BatchProcessing | BatchFinished + deriving (Eq, Show) + +encodeBatchStatus :: BatchStatus -> ByteString +encodeBatchStatus BatchQueuing = "queueing" +encodeBatchStatus BatchProcessing = "processing" +encodeBatchStatus BatchFinished = "finished" + +decodeBatchStatus :: ByteString -> Maybe BatchStatus +decodeBatchStatus "queueing" = Just BatchQueuing +decodeBatchStatus "processing" = Just BatchProcessing +decodeBatchStatus "finished" = Just BatchFinished +decodeBatchStatus _ = Nothing + +data BatchJob = + BatchJob + { batchID :: BatchID + , batchTotal :: Int + , batchCompleted :: Int + , batchSuccesses :: Int + , batchFailures :: Int + , batchRetries :: Int + , batchStatus :: BatchStatus + } + data JobRef = JobRef JobID (Maybe BatchID) deriving (Eq, Show) instance ToJSON JobRef where @@ -262,7 +291,8 @@ createWith HworkerConfig{..} = -- all existing 'jobs', the 'broken' and 'failed' queues. There is no need -- to do this in normal applications (and most likely, you won't want to). destroy :: Job s t => Hworker s t -> IO () -destroy hw = void $ R.runRedis (hworkerConnection hw) $ +destroy hw = void $ R.runRedis (hworkerConnection hw) $ do + keys <- withList' hw (R.keys $ "hworker-batch-" <> hworkerName hw <> "*") (void . R.del) R.del [ jobQueue hw , progressQueue hw , brokenQueue hw @@ -298,7 +328,7 @@ queueBatched hw j batch finish = do R.runRedis (hworkerConnection hw) $ do result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id (Just batch), j)] void $ R.hincrby (batchCounter hw batch) "total" 1 - when finish $ void $ R.hset (batchCounter hw batch) "status" "processing" + when finish . void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchProcessing) return $ isRight result -- | Creates a new worker thread. This is blocking, so you will want to @@ -485,10 +515,26 @@ initBatch hw = do , ("successes", "0") , ("failures", "0") , ("retries", "0") - , ("status", "queuing") + , ("status", "queueing") ] return batch +batchJob :: Hworker s t -> BatchID -> IO (Maybe BatchJob) +batchJob hw batch = do + r <- R.runRedis (hworkerConnection hw) (R.hgetall (batchCounter hw batch)) + case r of + Left err -> hwlog hw err >> return Nothing + Right hm -> + return $ + BatchJob + <$> pure batch + <*> (lookup "total" hm >>= readMaybe) + <*> (lookup "completed" hm >>= readMaybe) + <*> (lookup "successes" hm >>= readMaybe) + <*> (lookup "failures" hm >>= readMaybe) + <*> (lookup "retries" hm >>= readMaybe) + <*> (lookup "status" hm >>= decodeBatchStatus) + incBatchSuccesses :: Hworker s t -> BatchID -> IO () incBatchSuccesses hw batch = void $ R.runRedis (hworkerConnection hw) $ do @@ -514,7 +560,7 @@ completeBatch hw batch = do \status -> case status of "processing" | completed >= total -> - void $ R.hset (batchCounter hw batch) "status" "processing" + void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchFinished) _ -> return () @@ -556,6 +602,14 @@ withIgnore hw a = Left err -> hwlog hw err Right _ -> return () + +withList' hw a f = + do r <- a + case r of + Left err -> liftIO $ hwlog hw err + Right [] -> return () + Right xs -> f xs + withInt' :: Hworker s t -> R.Redis (Either R.Reply Integer) -> R.Redis Integer withInt' hw a = do r <- a @@ -571,3 +625,7 @@ withMaybe' hw a f = Left err -> liftIO $ hwlog hw err Right Nothing -> return () Right (Just v) -> f v + +readMaybe :: Read a => ByteString -> Maybe a +readMaybe = + fmap fst . listToMaybe . reads . B8.unpack diff --git a/test/Spec.hs b/test/Spec.hs index 31fbbbe..361f627 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -240,6 +240,84 @@ main = hspec $ assertEqual "State should be 4, since all jobs were run" 4 v assertEqual "Should only have stored 2" [AlwaysFailJob,AlwaysFailJob] jobs + + fdescribe "Batch" $ + do it "should set up a batch job" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + Just batch <- initBatch hworker >>= batchJob hworker + batchTotal batch `shouldBe` 0 + batchCompleted batch `shouldBe` 0 + batchSuccesses batch `shouldBe` 0 + batchFailures batch `shouldBe` 0 + batchRetries batch `shouldBe` 0 + batchStatus batch `shouldBe` BatchQueuing + destroy hworker + + it "should increment batch total after queueing a batch job" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + ref <- initBatch hworker + queueBatched hworker SimpleJob ref False + Just batch <- batchJob hworker ref + batchTotal batch `shouldBe` 1 + destroy hworker + + it "should increment success and completed after completing a successful batch job" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + ref <- initBatch hworker + queueBatched hworker SimpleJob ref False + threadDelay 30000 + Just batch <- batchJob hworker ref + batchTotal batch `shouldBe` 1 + batchFailures batch `shouldBe` 0 + batchSuccesses batch `shouldBe` 1 + batchCompleted batch `shouldBe` 1 + batchStatus batch `shouldBe` BatchQueuing + killThread wthread + destroy hworker + + it "should increment failure and completed after completing a failed batch job" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "failworker-1" (FailState mvar)) + wthread <- forkIO (worker hworker) + ref <- initBatch hworker + queueBatched hworker FailJob ref False + threadDelay 30000 + Just batch <- batchJob hworker ref + batchTotal batch `shouldBe` 1 + batchFailures batch `shouldBe` 1 + batchSuccesses batch `shouldBe` 0 + batchCompleted batch `shouldBe` 1 + batchStatus batch `shouldBe` BatchQueuing + killThread wthread + destroy hworker + + it "should change job status to processing when indicated in queued job" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + ref <- initBatch hworker + queueBatched hworker SimpleJob ref True + Just batch <- batchJob hworker ref + batchTotal batch `shouldBe` 1 + batchStatus batch `shouldBe` BatchProcessing + destroy hworker + + it "should change job status finished when last process" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + ref <- initBatch hworker + queueBatched hworker SimpleJob ref True + threadDelay 30000 + Just batch <- batchJob hworker ref + batchTotal batch `shouldBe` 1 + batchStatus batch `shouldBe` BatchFinished + killThread wthread + destroy hworker + describe "Monitor" $ do it "should add job back after timeout" $ -- NOTE(dbp 2015-07-12): The timing on this test is somewhat From 7ce929fcbe6a39e39a7e0750c8304b5f6fd35ad9 Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 18 Nov 2022 13:10:14 -0500 Subject: [PATCH 05/36] Add callback --- src/System/Hworker.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index ccf0afa..ad85c6f 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -201,6 +201,7 @@ data Hworker s t = , hworkerJobTimeout :: NominalDiffTime , hworkerFailedQueueSize :: Int , hworkerDebug :: Bool + , hworkerBatchCompleted :: BatchJob -> IO () } -- | When configuring a worker, you can tell it to use an existing @@ -286,6 +287,7 @@ createWith HworkerConfig{..} = hwconfigTimeout hwconfigFailedQueueSize hwconfigDebug + (const (return ())) -- | Destroy a worker. This will delete all the queues, clearing out -- all existing 'jobs', the 'broken' and 'failed' queues. There is no need @@ -559,8 +561,13 @@ completeBatch hw batch = do withMaybe' hw (R.hget (batchCounter hw batch) "status") $ \status -> case status of - "processing" | completed >= total -> + "processing" | completed >= total -> do void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchFinished) + liftIO $ do + r <- batchJob hw batch + case r of + Nothing -> hwlog hw ("Batch Job not found" :: Text) + Just batchjob -> hworkerBatchCompleted hw batchjob _ -> return () From ee2c9a4f510cba5d97d1fed064cc3adf2d02eec7 Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 18 Nov 2022 13:12:54 -0500 Subject: [PATCH 06/36] Remove fdescribe --- test/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Spec.hs b/test/Spec.hs index 361f627..0481451 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -241,7 +241,7 @@ main = hspec $ assertEqual "Should only have stored 2" [AlwaysFailJob,AlwaysFailJob] jobs - fdescribe "Batch" $ + describe "Batch" $ do it "should set up a batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) From cb3e5b10f014396b591d420088dc3d75056a76d1 Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 18 Nov 2022 18:19:56 -0500 Subject: [PATCH 07/36] Move batch functions into lua scripts --- src/System/Hworker.hs | 211 +++++++++++++++++++++++------------------- 1 file changed, 116 insertions(+), 95 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index ad85c6f..d32d37c 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -176,7 +176,7 @@ data BatchJob = , batchFailures :: Int , batchRetries :: Int , batchStatus :: BatchStatus - } + } deriving Show data JobRef = JobRef JobID (Maybe BatchID) deriving (Eq, Show) @@ -371,47 +371,117 @@ worker hw = case result of Success -> do when (hworkerDebug hw) $ hwlog hw ("JOB COMPLETE", t) - delete_res <- R.runRedis (hworkerConnection hw) - (R.hdel (progressQueue hw) [t]) case maybeBatch of - Nothing -> return () - Just batch -> incBatchSuccesses hw batch - case delete_res of - Left err -> hwlog hw err >> delayAndRun - Right 1 -> justRun - Right n -> do hwlog hw ("Job done: did not delete 1, deleted " <> show n) - delayAndRun + Nothing -> do + delete_res <- R.runRedis (hworkerConnection hw) + (R.hdel (progressQueue hw) [t]) + case delete_res of + Left err -> hwlog hw err >> delayAndRun + Right 1 -> justRun + Right n -> do hwlog hw ("Job done: did not delete 1, deleted " <> show n) + delayAndRun + + Just batch -> + withMaybe hw + (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ local batch = KEYS[2]\n\ + \ redis.call('hincrby', batch, 'successes', '1')\n\ + \ local completed = redis.call('hincrby', batch, 'completed', '1')\n\ + \ local total = redis.call('hincrby', batch, 'total', '0')\n\ + \ local status = redis.call('hget', batch, 'status')\n\ + \ if tonumber(completed) >= tonumber(total) and status == 'processing' then\n\ + \ redis.call('hset', batch, 'status', 'finished')\n\ + \ end\n\ + \ return redis.call('hgetall', batch)\ + \end\n\ + \return nil" + [progressQueue hw, batchCounter hw batch] + [t] + ) + (\r -> + case decodeBatchSummary batch r of + Nothing -> do + hwlog hw ("Job done: did not delete 1" :: Text) + delayAndRun + + Just summary -> do + when (batchStatus summary == BatchFinished) + $ hworkerBatchCompleted hw summary + justRun + ) + + Retry msg -> do hwlog hw ("Retry: " <> msg) - withNil hw - (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ - \if del == 1 then\n\ - \ redis.call('lpush', KEYS[2], ARGV[1])\n\ - \end\n\ - \return nil" - [progressQueue hw, jobQueue hw] - [t]) case maybeBatch of - Nothing -> return () - Just batch -> incBatchRetries hw batch - delayAndRun + Nothing -> do + withNil hw + (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('lpush', KEYS[2], ARGV[1])\n\ + \end\n\ + \return nil" + [progressQueue hw, jobQueue hw] + [t]) + delayAndRun + + Just batch -> do + withNil hw + (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('lpush', KEYS[2], ARGV[1])\n\ + \ redis.call('hincrby', KEYS[3], 'retries', '1')\n\ + \end\n\ + \return nil" + [progressQueue hw, jobQueue hw, batchCounter hw batch] + [t]) + delayAndRun + Failure msg -> do hwlog hw ("Failure: " <> msg) - withNil hw - (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ - \if del == 1 then\n\ - \ redis.call('lpush', KEYS[2], ARGV[1])\n\ - \ redis.call('ltrim', KEYS[2], 0, ARGV[2])\n\ - \end\n\ - \return nil" - [progressQueue hw, failedQueue hw] - [t, B8.pack (show (hworkerFailedQueueSize hw - 1))]) case maybeBatch of - Nothing -> return () - Just batch -> incBatchFailures hw batch - void $ R.runRedis (hworkerConnection hw) - (R.hdel (progressQueue hw) [t]) - delayAndRun + Nothing -> do + withNil hw + (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('lpush', KEYS[2], ARGV[1])\n\ + \ redis.call('ltrim', KEYS[2], 0, ARGV[2])\n\ + \end\n\ + \return nil" + [progressQueue hw, failedQueue hw] + [t, B8.pack (show (hworkerFailedQueueSize hw - 1))]) + void $ R.runRedis (hworkerConnection hw) + (R.hdel (progressQueue hw) [t]) + delayAndRun + + Just batch -> do + withMaybe hw + (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('lpush', KEYS[2], ARGV[1])\n\ + \ redis.call('ltrim', KEYS[2], 0, ARGV[2])\n\ + \ local batch = KEYS[3]\n\ + \ redis.call('hincrby', batch, 'failures', '1')\n\ + \ local completed = redis.call('hincrby', batch, 'completed', '1')\n\ + \ local total = redis.call('hincrby', batch, 'total', '0')\n\ + \ local status = redis.call('hget', batch, 'status')\n\ + \ if tonumber(completed) >= tonumber(total) and status == 'processing' then\n\ + \ redis.call('hset', batch, 'status', 'finished')\n\ + \ return redis.call('hgetall', batch)\ + \ end\n\ + \end\n\ + \return nil" + [progressQueue hw, failedQueue hw, batchCounter hw batch] + [t, B8.pack (show (hworkerFailedQueueSize hw - 1))] + ) + (\r -> + case decodeBatchSummary batch r of + Nothing -> return () + Just summary -> hworkerBatchCompleted hw summary + ) + delayAndRun + where delayAndRun = threadDelay 10000 >> worker hw justRun = worker hw runJob v = @@ -526,52 +596,18 @@ batchJob hw batch = do r <- R.runRedis (hworkerConnection hw) (R.hgetall (batchCounter hw batch)) case r of Left err -> hwlog hw err >> return Nothing - Right hm -> - return $ - BatchJob - <$> pure batch - <*> (lookup "total" hm >>= readMaybe) - <*> (lookup "completed" hm >>= readMaybe) - <*> (lookup "successes" hm >>= readMaybe) - <*> (lookup "failures" hm >>= readMaybe) - <*> (lookup "retries" hm >>= readMaybe) - <*> (lookup "status" hm >>= decodeBatchStatus) - -incBatchSuccesses :: Hworker s t -> BatchID -> IO () -incBatchSuccesses hw batch = - void $ R.runRedis (hworkerConnection hw) $ do - void $ withInt' hw $ R.hincrby (batchCounter hw batch) "successes" 1 - completeBatch hw batch - -incBatchFailures :: Hworker s t -> BatchID -> IO () -incBatchFailures hw batch = - void $ R.runRedis (hworkerConnection hw) $ do - void $ withInt' hw $ R.hincrby (batchCounter hw batch) "failures" 1 - completeBatch hw batch - -incBatchRetries :: Hworker s t -> BatchID -> IO () -incBatchRetries hw batch = - void $ R.runRedis (hworkerConnection hw) $ - R.hincrby (batchCounter hw batch) "retries" 1 - -completeBatch :: Hworker s t -> BatchID -> R.Redis () -completeBatch hw batch = do - completed <- withInt' hw $ R.hincrby (batchCounter hw batch) "completed" 1 - total <- withInt' hw $ R.hincrby (batchCounter hw batch) "total" 0 - withMaybe' hw (R.hget (batchCounter hw batch) "status") $ - \status -> - case status of - "processing" | completed >= total -> do - void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchFinished) - liftIO $ do - r <- batchJob hw batch - case r of - Nothing -> hwlog hw ("Batch Job not found" :: Text) - Just batchjob -> hworkerBatchCompleted hw batchjob - - _ -> - return () + Right hm -> return $ decodeBatchSummary batch hm +decodeBatchSummary :: BatchID -> [(ByteString, ByteString)] -> Maybe BatchJob +decodeBatchSummary batch hm = + BatchJob + <$> pure batch + <*> (lookup "total" hm >>= readMaybe) + <*> (lookup "completed" hm >>= readMaybe) + <*> (lookup "successes" hm >>= readMaybe) + <*> (lookup "failures" hm >>= readMaybe) + <*> (lookup "retries" hm >>= readMaybe) + <*> (lookup "status" hm >>= decodeBatchStatus) -- Redis helpers follow withList hw a f = @@ -617,21 +653,6 @@ withList' hw a f = Right [] -> return () Right xs -> f xs -withInt' :: Hworker s t -> R.Redis (Either R.Reply Integer) -> R.Redis Integer -withInt' hw a = - do r <- a - case r of - Left err -> liftIO (hwlog hw err) >> return (-1) - Right n -> return n - - -withMaybe' :: Hworker s t -> R.Redis (Either R.Reply (Maybe a)) -> (a -> R.Redis ()) -> R.Redis () -withMaybe' hw a f = - do r <- a - case r of - Left err -> liftIO $ hwlog hw err - Right Nothing -> return () - Right (Just v) -> f v readMaybe :: Read a => ByteString -> Maybe a readMaybe = From f297329c29acaabce9daffb162787f4518a70d43 Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 18 Nov 2022 20:05:34 -0500 Subject: [PATCH 08/36] Rename BatchJob to BatchSummary --- src/System/Hworker.hs | 30 +++++++++++++-------------- test/Spec.hs | 47 +++++++++++++++++++------------------------ 2 files changed, 36 insertions(+), 41 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index d32d37c..a8e1312 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -55,7 +55,7 @@ module System.Hworker , defaultHworkerConfig , BatchID(..) , BatchStatus(..) - , BatchJob(..) + , BatchSummary(..) -- * Managing Workers , create , createWith @@ -167,15 +167,15 @@ decodeBatchStatus "processing" = Just BatchProcessing decodeBatchStatus "finished" = Just BatchFinished decodeBatchStatus _ = Nothing -data BatchJob = - BatchJob - { batchID :: BatchID - , batchTotal :: Int - , batchCompleted :: Int - , batchSuccesses :: Int - , batchFailures :: Int - , batchRetries :: Int - , batchStatus :: BatchStatus +data BatchSummary = + BatchSummary + { batchSummaryID :: BatchID + , batchSummaryTotal :: Int + , batchSummaryCompleted :: Int + , batchSummarySuccesses :: Int + , batchSummaryFailures :: Int + , batchSummaryRetries :: Int + , batchSummaryStatus :: BatchStatus } deriving Show data JobRef = JobRef JobID (Maybe BatchID) deriving (Eq, Show) @@ -201,7 +201,7 @@ data Hworker s t = , hworkerJobTimeout :: NominalDiffTime , hworkerFailedQueueSize :: Int , hworkerDebug :: Bool - , hworkerBatchCompleted :: BatchJob -> IO () + , hworkerBatchCompleted :: BatchSummary -> IO () } -- | When configuring a worker, you can tell it to use an existing @@ -406,7 +406,7 @@ worker hw = delayAndRun Just summary -> do - when (batchStatus summary == BatchFinished) + when (batchSummaryStatus summary == BatchFinished) $ hworkerBatchCompleted hw summary justRun ) @@ -591,16 +591,16 @@ initBatch hw = do ] return batch -batchJob :: Hworker s t -> BatchID -> IO (Maybe BatchJob) +batchJob :: Hworker s t -> BatchID -> IO (Maybe BatchSummary) batchJob hw batch = do r <- R.runRedis (hworkerConnection hw) (R.hgetall (batchCounter hw batch)) case r of Left err -> hwlog hw err >> return Nothing Right hm -> return $ decodeBatchSummary batch hm -decodeBatchSummary :: BatchID -> [(ByteString, ByteString)] -> Maybe BatchJob +decodeBatchSummary :: BatchID -> [(ByteString, ByteString)] -> Maybe BatchSummary decodeBatchSummary batch hm = - BatchJob + BatchSummary <$> pure batch <*> (lookup "total" hm >>= readMaybe) <*> (lookup "completed" hm >>= readMaybe) diff --git a/test/Spec.hs b/test/Spec.hs index 0481451..888567e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -246,23 +246,21 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) Just batch <- initBatch hworker >>= batchJob hworker - batchTotal batch `shouldBe` 0 - batchCompleted batch `shouldBe` 0 - batchSuccesses batch `shouldBe` 0 - batchFailures batch `shouldBe` 0 - batchRetries batch `shouldBe` 0 - batchStatus batch `shouldBe` BatchQueuing + batchSummaryTotal batch `shouldBe` 0 + batchSummaryCompleted batch `shouldBe` 0 + batchSummarySuccesses batch `shouldBe` 0 + batchSummaryFailures batch `shouldBe` 0 + batchSummaryRetries batch `shouldBe` 0 + batchSummaryStatus batch `shouldBe` BatchQueuing destroy hworker - it "should increment batch total after queueing a batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) ref <- initBatch hworker queueBatched hworker SimpleJob ref False Just batch <- batchJob hworker ref - batchTotal batch `shouldBe` 1 + batchSummaryTotal batch `shouldBe` 1 destroy hworker - it "should increment success and completed after completing a successful batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) @@ -271,14 +269,13 @@ main = hspec $ queueBatched hworker SimpleJob ref False threadDelay 30000 Just batch <- batchJob hworker ref - batchTotal batch `shouldBe` 1 - batchFailures batch `shouldBe` 0 - batchSuccesses batch `shouldBe` 1 - batchCompleted batch `shouldBe` 1 - batchStatus batch `shouldBe` BatchQueuing + batchSummaryTotal batch `shouldBe` 1 + batchSummaryFailures batch `shouldBe` 0 + batchSummarySuccesses batch `shouldBe` 1 + batchSummaryCompleted batch `shouldBe` 1 + batchSummaryStatus batch `shouldBe` BatchQueuing killThread wthread destroy hworker - it "should increment failure and completed after completing a failed batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "failworker-1" (FailState mvar)) @@ -287,24 +284,22 @@ main = hspec $ queueBatched hworker FailJob ref False threadDelay 30000 Just batch <- batchJob hworker ref - batchTotal batch `shouldBe` 1 - batchFailures batch `shouldBe` 1 - batchSuccesses batch `shouldBe` 0 - batchCompleted batch `shouldBe` 1 - batchStatus batch `shouldBe` BatchQueuing + batchSummaryTotal batch `shouldBe` 1 + batchSummaryFailures batch `shouldBe` 1 + batchSummarySuccesses batch `shouldBe` 0 + batchSummaryCompleted batch `shouldBe` 1 + batchSummaryStatus batch `shouldBe` BatchQueuing killThread wthread destroy hworker - it "should change job status to processing when indicated in queued job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) ref <- initBatch hworker queueBatched hworker SimpleJob ref True Just batch <- batchJob hworker ref - batchTotal batch `shouldBe` 1 - batchStatus batch `shouldBe` BatchProcessing + batchSummaryTotal batch `shouldBe` 1 + batchSummaryStatus batch `shouldBe` BatchProcessing destroy hworker - it "should change job status finished when last process" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) @@ -313,8 +308,8 @@ main = hspec $ queueBatched hworker SimpleJob ref True threadDelay 30000 Just batch <- batchJob hworker ref - batchTotal batch `shouldBe` 1 - batchStatus batch `shouldBe` BatchFinished + batchSummaryTotal batch `shouldBe` 1 + batchSummaryStatus batch `shouldBe` BatchFinished killThread wthread destroy hworker From b0a6b8a05df5355a05b972a79ee5e03c72de56ff Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 18 Nov 2022 20:07:04 -0500 Subject: [PATCH 09/36] Remove redundant line of code --- src/System/Hworker.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index a8e1312..75d361d 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -451,8 +451,6 @@ worker hw = \return nil" [progressQueue hw, failedQueue hw] [t, B8.pack (show (hworkerFailedQueueSize hw - 1))]) - void $ R.runRedis (hworkerConnection hw) - (R.hdel (progressQueue hw) [t]) delayAndRun Just batch -> do From 3adca5725656294cb90885f5abc13b157d2292d7 Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 18 Nov 2022 21:13:44 -0500 Subject: [PATCH 10/36] Create separate function for stop batch queueing --- src/System/Hworker.hs | 38 ++++++++++++++++++++++++++++---------- test/Spec.hs | 26 +++++++++++++++++++++----- 2 files changed, 49 insertions(+), 15 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 75d361d..e475688 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -66,6 +65,7 @@ module System.Hworker -- * Queuing Jobs , queue , queueBatched + , stopBatchQueueing , initBatch -- * Inspecting Workers , jobs @@ -294,7 +294,7 @@ createWith HworkerConfig{..} = -- to do this in normal applications (and most likely, you won't want to). destroy :: Job s t => Hworker s t -> IO () destroy hw = void $ R.runRedis (hworkerConnection hw) $ do - keys <- withList' hw (R.keys $ "hworker-batch-" <> hworkerName hw <> "*") (void . R.del) + withList' hw (R.keys $ "hworker-batch-" <> hworkerName hw <> "*") (void . R.del) R.del [ jobQueue hw , progressQueue hw , brokenQueue hw @@ -324,14 +324,32 @@ queue hw j = isRight <$> R.runRedis (hworkerConnection hw) (R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id Nothing, j)]) -queueBatched :: Job s t => Hworker s t -> t -> BatchID -> Bool -> IO Bool -queueBatched hw j batch finish = do +queueBatched :: Job s t => Hworker s t -> t -> BatchID -> IO Bool +queueBatched hw j batch = do job_id <- UUID.toText <$> UUID.nextRandom R.runRedis (hworkerConnection hw) $ do - result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id (Just batch), j)] - void $ R.hincrby (batchCounter hw batch) "total" 1 - when finish . void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchProcessing) - return $ isRight result + s <- R.hget (batchCounter hw batch) "status" + case s of + Left err -> + liftIO (hwlog hw err) >> return False + + Right Nothing -> do + liftIO $ hwlog hw $ "Batch not found: " <> show batch + return False + + Right (Just status) | status == "queueing" -> do + result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id (Just batch), j)] + void $ R.hincrby (batchCounter hw batch) "total" 1 + return $ isRight result + + Right (Just _)-> do + liftIO $ hwlog hw $ "Batch queuing completed, cannot enqueue further: " <> show batch + return False + +stopBatchQueueing :: Hworker s t -> BatchID -> IO () +stopBatchQueueing hw batch = + void . R.runRedis (hworkerConnection hw) $ + R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchProcessing) -- | Creates a new worker thread. This is blocking, so you will want to -- 'forkIO' this into a thread. You can have any number of these (and @@ -473,8 +491,8 @@ worker hw = [progressQueue hw, failedQueue hw, batchCounter hw batch] [t, B8.pack (show (hworkerFailedQueueSize hw - 1))] ) - (\r -> - case decodeBatchSummary batch r of + (\s -> + case decodeBatchSummary batch s of Nothing -> return () Just summary -> hworkerBatchCompleted hw summary ) diff --git a/test/Spec.hs b/test/Spec.hs index 888567e..2e0475f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -257,16 +257,30 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) ref <- initBatch hworker - queueBatched hworker SimpleJob ref False + queueBatched hworker SimpleJob ref Just batch <- batchJob hworker ref batchSummaryTotal batch `shouldBe` 1 destroy hworker + it "should not enqueue job for completed batch" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + ref <- initBatch hworker + queueBatched hworker SimpleJob ref + threadDelay 30000 + stopBatchQueueing hworker ref + queueBatched hworker SimpleJob ref >>= shouldBe False + threadDelay 30000 + Just batch <- batchJob hworker ref + batchSummaryTotal batch `shouldBe` 1 + killThread wthread + destroy hworker it "should increment success and completed after completing a successful batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) ref <- initBatch hworker - queueBatched hworker SimpleJob ref False + queueBatched hworker SimpleJob ref threadDelay 30000 Just batch <- batchJob hworker ref batchSummaryTotal batch `shouldBe` 1 @@ -281,7 +295,7 @@ main = hspec $ hworker <- createWith (conf "failworker-1" (FailState mvar)) wthread <- forkIO (worker hworker) ref <- initBatch hworker - queueBatched hworker FailJob ref False + queueBatched hworker FailJob ref threadDelay 30000 Just batch <- batchJob hworker ref batchSummaryTotal batch `shouldBe` 1 @@ -295,7 +309,8 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) ref <- initBatch hworker - queueBatched hworker SimpleJob ref True + queueBatched hworker SimpleJob ref + stopBatchQueueing hworker ref Just batch <- batchJob hworker ref batchSummaryTotal batch `shouldBe` 1 batchSummaryStatus batch `shouldBe` BatchProcessing @@ -305,7 +320,8 @@ main = hspec $ hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) ref <- initBatch hworker - queueBatched hworker SimpleJob ref True + queueBatched hworker SimpleJob ref + stopBatchQueueing hworker ref threadDelay 30000 Just batch <- batchJob hworker ref batchSummaryTotal batch `shouldBe` 1 From b8ba9dd75fe2d765dc0d6f32da4736f6800795e2 Mon Sep 17 00:00:00 2001 From: remeike Date: Sat, 19 Nov 2022 10:12:19 -0500 Subject: [PATCH 11/36] Add test for large batch job --- src/System/Hworker.hs | 6 +++--- test/Spec.hs | 32 +++++++++++++++++++++++++------- 2 files changed, 28 insertions(+), 10 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index e475688..057feec 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -59,7 +59,7 @@ module System.Hworker , create , createWith , destroy - , batchJob + , batchSummary , worker , monitor -- * Queuing Jobs @@ -607,8 +607,8 @@ initBatch hw = do ] return batch -batchJob :: Hworker s t -> BatchID -> IO (Maybe BatchSummary) -batchJob hw batch = do +batchSummary :: Hworker s t -> BatchID -> IO (Maybe BatchSummary) +batchSummary hw batch = do r <- R.runRedis (hworkerConnection hw) (R.hgetall (batchCounter hw batch)) case r of Left err -> hwlog hw err >> return Nothing diff --git a/test/Spec.hs b/test/Spec.hs index 2e0475f..ca8853d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -245,7 +245,7 @@ main = hspec $ do it "should set up a batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - Just batch <- initBatch hworker >>= batchJob hworker + Just batch <- initBatch hworker >>= batchSummary hworker batchSummaryTotal batch `shouldBe` 0 batchSummaryCompleted batch `shouldBe` 0 batchSummarySuccesses batch `shouldBe` 0 @@ -258,7 +258,7 @@ main = hspec $ hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) ref <- initBatch hworker queueBatched hworker SimpleJob ref - Just batch <- batchJob hworker ref + Just batch <- batchSummary hworker ref batchSummaryTotal batch `shouldBe` 1 destroy hworker it "should not enqueue job for completed batch" $ @@ -271,7 +271,7 @@ main = hspec $ stopBatchQueueing hworker ref queueBatched hworker SimpleJob ref >>= shouldBe False threadDelay 30000 - Just batch <- batchJob hworker ref + Just batch <- batchSummary hworker ref batchSummaryTotal batch `shouldBe` 1 killThread wthread destroy hworker @@ -282,7 +282,7 @@ main = hspec $ ref <- initBatch hworker queueBatched hworker SimpleJob ref threadDelay 30000 - Just batch <- batchJob hworker ref + Just batch <- batchSummary hworker ref batchSummaryTotal batch `shouldBe` 1 batchSummaryFailures batch `shouldBe` 0 batchSummarySuccesses batch `shouldBe` 1 @@ -297,7 +297,7 @@ main = hspec $ ref <- initBatch hworker queueBatched hworker FailJob ref threadDelay 30000 - Just batch <- batchJob hworker ref + Just batch <- batchSummary hworker ref batchSummaryTotal batch `shouldBe` 1 batchSummaryFailures batch `shouldBe` 1 batchSummarySuccesses batch `shouldBe` 0 @@ -311,7 +311,7 @@ main = hspec $ ref <- initBatch hworker queueBatched hworker SimpleJob ref stopBatchQueueing hworker ref - Just batch <- batchJob hworker ref + Just batch <- batchSummary hworker ref batchSummaryTotal batch `shouldBe` 1 batchSummaryStatus batch `shouldBe` BatchProcessing destroy hworker @@ -323,11 +323,29 @@ main = hspec $ queueBatched hworker SimpleJob ref stopBatchQueueing hworker ref threadDelay 30000 - Just batch <- batchJob hworker ref + Just batch <- batchSummary hworker ref batchSummaryTotal batch `shouldBe` 1 batchSummaryStatus batch `shouldBe` BatchFinished killThread wthread destroy hworker + it "queueing 1000 jobs should increment 1000" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-3" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + ref <- initBatch hworker + replicateM_ 1000 (queueBatched hworker SimpleJob ref) + stopBatchQueueing hworker ref + threadDelay 2000000 + v <- takeMVar mvar + v `shouldBe` 1000 + Just batch <- batchSummary hworker ref + batchSummaryTotal batch `shouldBe` 1000 + batchSummaryFailures batch `shouldBe` 0 + batchSummarySuccesses batch `shouldBe` 1000 + batchSummaryCompleted batch `shouldBe` 1000 + batchSummaryStatus batch `shouldBe` BatchFinished + killThread wthread + destroy hworker describe "Monitor" $ do it "should add job back after timeout" $ From 965cbcc1f2631be22c13bb8a3c8f3936f161f3cc Mon Sep 17 00:00:00 2001 From: remeike Date: Sat, 19 Nov 2022 11:23:38 -0500 Subject: [PATCH 12/36] Add expiration to batch --- src/System/Hworker.hs | 84 +++++++++++++++++++++++++++---------------- test/Spec.hs | 30 ++++++++++------ 2 files changed, 73 insertions(+), 41 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 057feec..cb2c62b 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -52,7 +52,7 @@ module System.Hworker , ExceptionBehavior(..) , RedisConnection(..) , defaultHworkerConfig - , BatchID(..) + , BatchId(..) , BatchStatus(..) , BatchSummary(..) -- * Managing Workers @@ -65,8 +65,8 @@ module System.Hworker -- * Queuing Jobs , queue , queueBatched - , stopBatchQueueing , initBatch + , stopBatchQueueing -- * Inspecting Workers , jobs , failed @@ -91,7 +91,8 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB import Data.Either (isRight) -import Data.Maybe (fromJust, isJust, mapMaybe, listToMaybe) +import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe, + listToMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -148,42 +149,56 @@ data JobData t = JobData UTCTime t -- intermittent problems). data ExceptionBehavior = RetryOnException | FailOnException -type JobID = Text +type JobId = Text -- | A unique identifier for grouping jobs together. -newtype BatchID = BatchID UUID deriving (ToJSON, FromJSON, Eq, Show) - -data BatchStatus = BatchQueuing | BatchProcessing | BatchFinished +newtype BatchId = BatchId UUID deriving (ToJSON, FromJSON, Eq, Show) + +-- | Represents the current status of a batch. A batch is considered to be +-- "queueing" if jobs can still be added to the batch. While jobs are +-- queueing it is possible for them to be "processing" during that time. +-- The status only changes to "processing" once jobs can no longer be queued +-- but are still being processed. The batch is then finished once all jobs +-- are processed (they have either failed or succeeded). +data BatchStatus = BatchQueueing | BatchProcessing | BatchFinished deriving (Eq, Show) encodeBatchStatus :: BatchStatus -> ByteString -encodeBatchStatus BatchQueuing = "queueing" +encodeBatchStatus BatchQueueing = "queueing" encodeBatchStatus BatchProcessing = "processing" encodeBatchStatus BatchFinished = "finished" decodeBatchStatus :: ByteString -> Maybe BatchStatus -decodeBatchStatus "queueing" = Just BatchQueuing +decodeBatchStatus "queueing" = Just BatchQueueing decodeBatchStatus "processing" = Just BatchProcessing decodeBatchStatus "finished" = Just BatchFinished decodeBatchStatus _ = Nothing +-- | A summary of a particular batch, including figures on the total number +-- of jobs expected to be run, the number of jobs that have completed (i.e. +-- failed or succeeded), the number of jobs succeeded, the number of jobs +-- failed, the number of jobs retried, and the current status of the +-- batch overall. data BatchSummary = BatchSummary - { batchSummaryID :: BatchID + { batchSummaryID :: BatchId , batchSummaryTotal :: Int , batchSummaryCompleted :: Int , batchSummarySuccesses :: Int , batchSummaryFailures :: Int , batchSummaryRetries :: Int , batchSummaryStatus :: BatchStatus - } deriving Show + } deriving (Eq, Show) -data JobRef = JobRef JobID (Maybe BatchID) deriving (Eq, Show) +data JobRef = JobRef JobId (Maybe BatchId) deriving (Eq, Show) instance ToJSON JobRef where toJSON (JobRef j b) = A.object ["j" .= j, "b" .= b] instance FromJSON JobRef where + -- NOTE(rjbf 2022-11-19): This is just here for the sake of migration and + -- can be removed eventually. Before `JobRef`, which is encoded as + -- a JSON object, there was a just a `String` representing the job ID. parseJSON (A.String j) = pure (JobRef j Nothing) parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b") val @@ -313,8 +328,8 @@ brokenQueue hw = "hworker-broken-" <> hworkerName hw failedQueue :: Hworker s t -> ByteString failedQueue hw = "hworker-failed-" <> hworkerName hw -batchCounter :: Hworker s t -> BatchID -> ByteString -batchCounter hw (BatchID batch) = +batchCounter :: Hworker s t -> BatchId -> ByteString +batchCounter hw (BatchId batch) = "hworker-batch-" <> hworkerName hw <> ":" <> UUID.toASCIIBytes batch -- | Adds a job to the queue. Returns whether the operation succeeded. @@ -324,7 +339,9 @@ queue hw j = isRight <$> R.runRedis (hworkerConnection hw) (R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id Nothing, j)]) -queueBatched :: Job s t => Hworker s t -> t -> BatchID -> IO Bool +-- | Adds a job to the queue, but as part of a particular batch of jobs. +-- Returns whether the operation succeeded. +queueBatched :: Job s t => Hworker s t -> t -> BatchId -> IO Bool queueBatched hw j batch = do job_id <- UUID.toText <$> UUID.nextRandom R.runRedis (hworkerConnection hw) $ do @@ -346,7 +363,8 @@ queueBatched hw j batch = do liftIO $ hwlog hw $ "Batch queuing completed, cannot enqueue further: " <> show batch return False -stopBatchQueueing :: Hworker s t -> BatchID -> IO () +-- | Prevents queueing new jobs to a batch. +stopBatchQueueing :: Hworker s t -> BatchId -> IO () stopBatchQueueing hw batch = void . R.runRedis (hworkerConnection hw) $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchProcessing) @@ -593,28 +611,34 @@ debugger microseconds hw = (\queued -> hwlog hw ("DEBUG", queued, running))) threadDelay microseconds -initBatch :: Hworker s t -> IO BatchID -initBatch hw = do - batch <- BatchID <$> UUID.nextRandom - R.runRedis (hworkerConnection hw) $ - R.hmset (batchCounter hw batch) - [ ("total", "0") - , ("completed", "0") - , ("successes", "0") - , ("failures", "0") - , ("retries", "0") - , ("status", "queueing") - ] +-- | Initializes a batch of jobs. By default the information for tracking a +-- batch of jobs, created by this function, will expires a week from +-- its creation. The optional `seconds` argument can be used to override this. +initBatch :: Hworker s t -> Maybe Integer -> IO BatchId +initBatch hw seconds = do + batch <- BatchId <$> UUID.nextRandom + void . R.runRedis (hworkerConnection hw) $ do + _ <- + R.hmset (batchCounter hw batch) + [ ("total", "0") + , ("completed", "0") + , ("successes", "0") + , ("failures", "0") + , ("retries", "0") + , ("status", "queueing") + ] + R.expire (batchCounter hw batch) (fromMaybe 604800 seconds) return batch -batchSummary :: Hworker s t -> BatchID -> IO (Maybe BatchSummary) +-- | Return a summary of the batch. +batchSummary :: Hworker s t -> BatchId -> IO (Maybe BatchSummary) batchSummary hw batch = do r <- R.runRedis (hworkerConnection hw) (R.hgetall (batchCounter hw batch)) case r of Left err -> hwlog hw err >> return Nothing Right hm -> return $ decodeBatchSummary batch hm -decodeBatchSummary :: BatchID -> [(ByteString, ByteString)] -> Maybe BatchSummary +decodeBatchSummary :: BatchId -> [(ByteString, ByteString)] -> Maybe BatchSummary decodeBatchSummary batch hm = BatchSummary <$> pure batch diff --git a/test/Spec.hs b/test/Spec.hs index ca8853d..94569de 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -245,18 +245,26 @@ main = hspec $ do it "should set up a batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - Just batch <- initBatch hworker >>= batchSummary hworker + Just batch <- initBatch hworker Nothing >>= batchSummary hworker batchSummaryTotal batch `shouldBe` 0 batchSummaryCompleted batch `shouldBe` 0 batchSummarySuccesses batch `shouldBe` 0 batchSummaryFailures batch `shouldBe` 0 batchSummaryRetries batch `shouldBe` 0 - batchSummaryStatus batch `shouldBe` BatchQueuing + batchSummaryStatus batch `shouldBe` BatchQueueing + destroy hworker + it "should expire batch job" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- initBatch hworker (Just 1) + batchSummary hworker batch >>= shouldNotBe Nothing + threadDelay 2000000 + batchSummary hworker batch >>= shouldBe Nothing destroy hworker it "should increment batch total after queueing a batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - ref <- initBatch hworker + ref <- initBatch hworker Nothing queueBatched hworker SimpleJob ref Just batch <- batchSummary hworker ref batchSummaryTotal batch `shouldBe` 1 @@ -265,7 +273,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker + ref <- initBatch hworker Nothing queueBatched hworker SimpleJob ref threadDelay 30000 stopBatchQueueing hworker ref @@ -279,7 +287,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker + ref <- initBatch hworker Nothing queueBatched hworker SimpleJob ref threadDelay 30000 Just batch <- batchSummary hworker ref @@ -287,14 +295,14 @@ main = hspec $ batchSummaryFailures batch `shouldBe` 0 batchSummarySuccesses batch `shouldBe` 1 batchSummaryCompleted batch `shouldBe` 1 - batchSummaryStatus batch `shouldBe` BatchQueuing + batchSummaryStatus batch `shouldBe` BatchQueueing killThread wthread destroy hworker it "should increment failure and completed after completing a failed batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "failworker-1" (FailState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker + ref <- initBatch hworker Nothing queueBatched hworker FailJob ref threadDelay 30000 Just batch <- batchSummary hworker ref @@ -302,13 +310,13 @@ main = hspec $ batchSummaryFailures batch `shouldBe` 1 batchSummarySuccesses batch `shouldBe` 0 batchSummaryCompleted batch `shouldBe` 1 - batchSummaryStatus batch `shouldBe` BatchQueuing + batchSummaryStatus batch `shouldBe` BatchQueueing killThread wthread destroy hworker it "should change job status to processing when indicated in queued job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - ref <- initBatch hworker + ref <- initBatch hworker Nothing queueBatched hworker SimpleJob ref stopBatchQueueing hworker ref Just batch <- batchSummary hworker ref @@ -319,7 +327,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker + ref <- initBatch hworker Nothing queueBatched hworker SimpleJob ref stopBatchQueueing hworker ref threadDelay 30000 @@ -332,7 +340,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-3" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker + ref <- initBatch hworker Nothing replicateM_ 1000 (queueBatched hworker SimpleJob ref) stopBatchQueueing hworker ref threadDelay 2000000 From 54ba9f58c9b827f2f7d11d39645ea69100a20aab Mon Sep 17 00:00:00 2001 From: remeike Date: Sat, 19 Nov 2022 12:00:14 -0500 Subject: [PATCH 13/36] Finish batch with stop batch queuing when jobs are all run --- src/System/Hworker.hs | 50 ++++++++++++++++++++++++++++++------------- test/Spec.hs | 33 +++++++++++++++++++--------- 2 files changed, 58 insertions(+), 25 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index cb2c62b..947892a 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -175,14 +175,14 @@ decodeBatchStatus "finished" = Just BatchFinished decodeBatchStatus _ = Nothing -- | A summary of a particular batch, including figures on the total number --- of jobs expected to be run, the number of jobs that have completed (i.e. +-- of jobs queued, the number of jobs that have completed (i.e. -- failed or succeeded), the number of jobs succeeded, the number of jobs -- failed, the number of jobs retried, and the current status of the -- batch overall. data BatchSummary = BatchSummary { batchSummaryID :: BatchId - , batchSummaryTotal :: Int + , batchSummaryQueued :: Int , batchSummaryCompleted :: Int , batchSummarySuccesses :: Int , batchSummaryFailures :: Int @@ -356,18 +356,29 @@ queueBatched hw j batch = do Right (Just status) | status == "queueing" -> do result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id (Just batch), j)] - void $ R.hincrby (batchCounter hw batch) "total" 1 + void $ R.hincrby (batchCounter hw batch) "queued" 1 return $ isRight result Right (Just _)-> do liftIO $ hwlog hw $ "Batch queuing completed, cannot enqueue further: " <> show batch return False --- | Prevents queueing new jobs to a batch. +-- | Prevents queueing new jobs to a batch. If the number of jobs completed equals +-- the number of jobs queued, then the status of the batch is immediately set +-- to `BatchFinished`, otherwise it's set to `BatchProcessing`. stopBatchQueueing :: Hworker s t -> BatchId -> IO () stopBatchQueueing hw batch = - void . R.runRedis (hworkerConnection hw) $ - R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchProcessing) + void . R.runRedis (hworkerConnection hw) $ do + r <- batchSummary' hw batch + case r of + Nothing -> + liftIO $ hwlog hw $ "Batch not found: " <> show batch + + Just summary | batchSummaryCompleted summary >= batchSummaryQueued summary -> + void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchFinished) + + Just _-> do + void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchProcessing) -- | Creates a new worker thread. This is blocking, so you will want to -- 'forkIO' this into a thread. You can have any number of these (and @@ -424,9 +435,9 @@ worker hw = \ local batch = KEYS[2]\n\ \ redis.call('hincrby', batch, 'successes', '1')\n\ \ local completed = redis.call('hincrby', batch, 'completed', '1')\n\ - \ local total = redis.call('hincrby', batch, 'total', '0')\n\ + \ local queued = redis.call('hincrby', batch, 'queued', '0')\n\ \ local status = redis.call('hget', batch, 'status')\n\ - \ if tonumber(completed) >= tonumber(total) and status == 'processing' then\n\ + \ if tonumber(completed) >= tonumber(queued) and status == 'processing' then\n\ \ redis.call('hset', batch, 'status', 'finished')\n\ \ end\n\ \ return redis.call('hgetall', batch)\ @@ -498,9 +509,9 @@ worker hw = \ local batch = KEYS[3]\n\ \ redis.call('hincrby', batch, 'failures', '1')\n\ \ local completed = redis.call('hincrby', batch, 'completed', '1')\n\ - \ local total = redis.call('hincrby', batch, 'total', '0')\n\ + \ local queued = redis.call('hincrby', batch, 'queued', '0')\n\ \ local status = redis.call('hget', batch, 'status')\n\ - \ if tonumber(completed) >= tonumber(total) and status == 'processing' then\n\ + \ if tonumber(completed) >= tonumber(queued) and status == 'processing' then\n\ \ redis.call('hset', batch, 'status', 'finished')\n\ \ return redis.call('hgetall', batch)\ \ end\n\ @@ -620,7 +631,7 @@ initBatch hw seconds = do void . R.runRedis (hworkerConnection hw) $ do _ <- R.hmset (batchCounter hw batch) - [ ("total", "0") + [ ("queued", "0") , ("completed", "0") , ("successes", "0") , ("failures", "0") @@ -632,17 +643,21 @@ initBatch hw seconds = do -- | Return a summary of the batch. batchSummary :: Hworker s t -> BatchId -> IO (Maybe BatchSummary) -batchSummary hw batch = do - r <- R.runRedis (hworkerConnection hw) (R.hgetall (batchCounter hw batch)) +batchSummary hw batch = + R.runRedis (hworkerConnection hw) (batchSummary' hw batch) + +batchSummary' :: Hworker s t -> BatchId -> R.Redis (Maybe BatchSummary) +batchSummary' hw batch = do + r <- R.hgetall (batchCounter hw batch) case r of - Left err -> hwlog hw err >> return Nothing + Left err -> liftIO (hwlog hw err) >> return Nothing Right hm -> return $ decodeBatchSummary batch hm decodeBatchSummary :: BatchId -> [(ByteString, ByteString)] -> Maybe BatchSummary decodeBatchSummary batch hm = BatchSummary <$> pure batch - <*> (lookup "total" hm >>= readMaybe) + <*> (lookup "queued" hm >>= readMaybe) <*> (lookup "completed" hm >>= readMaybe) <*> (lookup "successes" hm >>= readMaybe) <*> (lookup "failures" hm >>= readMaybe) @@ -693,6 +708,11 @@ withList' hw a f = Right [] -> return () Right xs -> f xs +withInt' hw a = + do r <- a + case r of + Left err -> hwlog hw err >> return (-1) + Right n -> return n readMaybe :: Read a => ByteString -> Maybe a readMaybe = diff --git a/test/Spec.hs b/test/Spec.hs index 94569de..4335f23 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -246,7 +246,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) Just batch <- initBatch hworker Nothing >>= batchSummary hworker - batchSummaryTotal batch `shouldBe` 0 + batchSummaryQueued batch `shouldBe` 0 batchSummaryCompleted batch `shouldBe` 0 batchSummarySuccesses batch `shouldBe` 0 batchSummaryFailures batch `shouldBe` 0 @@ -267,7 +267,7 @@ main = hspec $ ref <- initBatch hworker Nothing queueBatched hworker SimpleJob ref Just batch <- batchSummary hworker ref - batchSummaryTotal batch `shouldBe` 1 + batchSummaryQueued batch `shouldBe` 1 destroy hworker it "should not enqueue job for completed batch" $ do mvar <- newMVar 0 @@ -280,7 +280,7 @@ main = hspec $ queueBatched hworker SimpleJob ref >>= shouldBe False threadDelay 30000 Just batch <- batchSummary hworker ref - batchSummaryTotal batch `shouldBe` 1 + batchSummaryQueued batch `shouldBe` 1 killThread wthread destroy hworker it "should increment success and completed after completing a successful batch job" $ @@ -291,7 +291,7 @@ main = hspec $ queueBatched hworker SimpleJob ref threadDelay 30000 Just batch <- batchSummary hworker ref - batchSummaryTotal batch `shouldBe` 1 + batchSummaryQueued batch `shouldBe` 1 batchSummaryFailures batch `shouldBe` 0 batchSummarySuccesses batch `shouldBe` 1 batchSummaryCompleted batch `shouldBe` 1 @@ -306,24 +306,37 @@ main = hspec $ queueBatched hworker FailJob ref threadDelay 30000 Just batch <- batchSummary hworker ref - batchSummaryTotal batch `shouldBe` 1 + batchSummaryQueued batch `shouldBe` 1 batchSummaryFailures batch `shouldBe` 1 batchSummarySuccesses batch `shouldBe` 0 batchSummaryCompleted batch `shouldBe` 1 batchSummaryStatus batch `shouldBe` BatchQueueing killThread wthread destroy hworker - it "should change job status to processing when indicated in queued job" $ + it "should change job status to processing when batch is set to stop queueing" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) ref <- initBatch hworker Nothing queueBatched hworker SimpleJob ref stopBatchQueueing hworker ref Just batch <- batchSummary hworker ref - batchSummaryTotal batch `shouldBe` 1 + batchSummaryQueued batch `shouldBe` 1 batchSummaryStatus batch `shouldBe` BatchProcessing destroy hworker - it "should change job status finished when last process" $ + it "should change job status to finished when batch is set to stop queueing and jobs are already run" $ + do mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + ref <- initBatch hworker Nothing + queueBatched hworker SimpleJob ref + threadDelay 30000 + stopBatchQueueing hworker ref + Just batch <- batchSummary hworker ref + batchSummaryQueued batch `shouldBe` 1 + batchSummaryStatus batch `shouldBe` BatchFinished + killThread wthread + destroy hworker + it "should change job status finished when last processed" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) @@ -332,7 +345,7 @@ main = hspec $ stopBatchQueueing hworker ref threadDelay 30000 Just batch <- batchSummary hworker ref - batchSummaryTotal batch `shouldBe` 1 + batchSummaryQueued batch `shouldBe` 1 batchSummaryStatus batch `shouldBe` BatchFinished killThread wthread destroy hworker @@ -347,7 +360,7 @@ main = hspec $ v <- takeMVar mvar v `shouldBe` 1000 Just batch <- batchSummary hworker ref - batchSummaryTotal batch `shouldBe` 1000 + batchSummaryQueued batch `shouldBe` 1000 batchSummaryFailures batch `shouldBe` 0 batchSummarySuccesses batch `shouldBe` 1000 batchSummaryCompleted batch `shouldBe` 1000 From e61bb74ce451812c5e47f791e38592288c2579bf Mon Sep 17 00:00:00 2001 From: remeike Date: Wed, 23 Nov 2022 12:17:27 -0500 Subject: [PATCH 14/36] Make batch expiration optional --- src/System/Hworker.hs | 19 ++++--- test/Spec.hs | 119 +++++++++++++++++++++--------------------- 2 files changed, 73 insertions(+), 65 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 947892a..5dfcaab 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -625,11 +625,11 @@ debugger microseconds hw = -- | Initializes a batch of jobs. By default the information for tracking a -- batch of jobs, created by this function, will expires a week from -- its creation. The optional `seconds` argument can be used to override this. -initBatch :: Hworker s t -> Maybe Integer -> IO BatchId -initBatch hw seconds = do +initBatch :: Hworker s t -> Maybe Integer -> IO (Maybe BatchId) +initBatch hw mseconds = do batch <- BatchId <$> UUID.nextRandom - void . R.runRedis (hworkerConnection hw) $ do - _ <- + R.runRedis (hworkerConnection hw) $ do + r <- R.hmset (batchCounter hw batch) [ ("queued", "0") , ("completed", "0") @@ -638,8 +638,15 @@ initBatch hw seconds = do , ("retries", "0") , ("status", "queueing") ] - R.expire (batchCounter hw batch) (fromMaybe 604800 seconds) - return batch + case r of + Left err -> + liftIO (hwlog hw err) >> return Nothing + + Right _ -> do + case mseconds of + Nothing -> return () + Just s -> void $ R.expire (batchCounter hw batch) s + return (Just batch) -- | Return a summary of the batch. batchSummary :: Hworker s t -> BatchId -> IO (Maybe BatchSummary) diff --git a/test/Spec.hs b/test/Spec.hs index 4335f23..d4958b5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -245,18 +245,19 @@ main = hspec $ do it "should set up a batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - Just batch <- initBatch hworker Nothing >>= batchSummary hworker - batchSummaryQueued batch `shouldBe` 0 - batchSummaryCompleted batch `shouldBe` 0 - batchSummarySuccesses batch `shouldBe` 0 - batchSummaryFailures batch `shouldBe` 0 - batchSummaryRetries batch `shouldBe` 0 - batchSummaryStatus batch `shouldBe` BatchQueueing + Just batch <- initBatch hworker Nothing + Just summary <- batchSummary hworker batch + batchSummaryQueued summary `shouldBe` 0 + batchSummaryCompleted summary `shouldBe` 0 + batchSummarySuccesses summary `shouldBe` 0 + batchSummaryFailures summary `shouldBe` 0 + batchSummaryRetries summary `shouldBe` 0 + batchSummaryStatus summary `shouldBe` BatchQueueing destroy hworker it "should expire batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - batch <- initBatch hworker (Just 1) + Just batch <- initBatch hworker (Just 1) batchSummary hworker batch >>= shouldNotBe Nothing threadDelay 2000000 batchSummary hworker batch >>= shouldBe Nothing @@ -264,74 +265,74 @@ main = hspec $ it "should increment batch total after queueing a batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - ref <- initBatch hworker Nothing - queueBatched hworker SimpleJob ref - Just batch <- batchSummary hworker ref - batchSummaryQueued batch `shouldBe` 1 + Just batch <- initBatch hworker Nothing + queueBatched hworker SimpleJob batch + Just summary <- batchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 destroy hworker it "should not enqueue job for completed batch" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker Nothing - queueBatched hworker SimpleJob ref + Just batch <- initBatch hworker Nothing + queueBatched hworker SimpleJob batch threadDelay 30000 - stopBatchQueueing hworker ref - queueBatched hworker SimpleJob ref >>= shouldBe False + stopBatchQueueing hworker batch + queueBatched hworker SimpleJob batch >>= shouldBe False threadDelay 30000 - Just batch <- batchSummary hworker ref - batchSummaryQueued batch `shouldBe` 1 + Just summary <- batchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 killThread wthread destroy hworker it "should increment success and completed after completing a successful batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker Nothing - queueBatched hworker SimpleJob ref + Just batch <- initBatch hworker Nothing + queueBatched hworker SimpleJob batch threadDelay 30000 - Just batch <- batchSummary hworker ref - batchSummaryQueued batch `shouldBe` 1 - batchSummaryFailures batch `shouldBe` 0 - batchSummarySuccesses batch `shouldBe` 1 - batchSummaryCompleted batch `shouldBe` 1 - batchSummaryStatus batch `shouldBe` BatchQueueing + Just summary <- batchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + batchSummaryFailures summary `shouldBe` 0 + batchSummarySuccesses summary `shouldBe` 1 + batchSummaryCompleted summary `shouldBe` 1 + batchSummaryStatus summary `shouldBe` BatchQueueing killThread wthread destroy hworker it "should increment failure and completed after completing a failed batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "failworker-1" (FailState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker Nothing - queueBatched hworker FailJob ref + Just batch <- initBatch hworker Nothing + queueBatched hworker FailJob batch threadDelay 30000 - Just batch <- batchSummary hworker ref - batchSummaryQueued batch `shouldBe` 1 - batchSummaryFailures batch `shouldBe` 1 - batchSummarySuccesses batch `shouldBe` 0 - batchSummaryCompleted batch `shouldBe` 1 - batchSummaryStatus batch `shouldBe` BatchQueueing + Just summary <- batchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + batchSummaryFailures summary `shouldBe` 1 + batchSummarySuccesses summary `shouldBe` 0 + batchSummaryCompleted summary `shouldBe` 1 + batchSummaryStatus summary `shouldBe` BatchQueueing killThread wthread destroy hworker it "should change job status to processing when batch is set to stop queueing" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - ref <- initBatch hworker Nothing - queueBatched hworker SimpleJob ref - stopBatchQueueing hworker ref - Just batch <- batchSummary hworker ref - batchSummaryQueued batch `shouldBe` 1 - batchSummaryStatus batch `shouldBe` BatchProcessing + Just batch <- initBatch hworker Nothing + queueBatched hworker SimpleJob batch + stopBatchQueueing hworker batch + Just summary <- batchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + batchSummaryStatus summary `shouldBe` BatchProcessing destroy hworker it "should change job status to finished when batch is set to stop queueing and jobs are already run" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker Nothing - queueBatched hworker SimpleJob ref + Just batch <- initBatch hworker Nothing + queueBatched hworker SimpleJob batch threadDelay 30000 - stopBatchQueueing hworker ref - Just batch <- batchSummary hworker ref + stopBatchQueueing hworker batch + Just batch <- batchSummary hworker batch batchSummaryQueued batch `shouldBe` 1 batchSummaryStatus batch `shouldBe` BatchFinished killThread wthread @@ -340,31 +341,31 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker Nothing - queueBatched hworker SimpleJob ref - stopBatchQueueing hworker ref + Just batch <- initBatch hworker Nothing + queueBatched hworker SimpleJob batch + stopBatchQueueing hworker batch threadDelay 30000 - Just batch <- batchSummary hworker ref - batchSummaryQueued batch `shouldBe` 1 - batchSummaryStatus batch `shouldBe` BatchFinished + Just summary <- batchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + batchSummaryStatus summary `shouldBe` BatchFinished killThread wthread destroy hworker it "queueing 1000 jobs should increment 1000" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-3" (SimpleState mvar)) wthread <- forkIO (worker hworker) - ref <- initBatch hworker Nothing - replicateM_ 1000 (queueBatched hworker SimpleJob ref) - stopBatchQueueing hworker ref + Just batch <- initBatch hworker Nothing + replicateM_ 1000 (queueBatched hworker SimpleJob batch) + stopBatchQueueing hworker batch threadDelay 2000000 v <- takeMVar mvar v `shouldBe` 1000 - Just batch <- batchSummary hworker ref - batchSummaryQueued batch `shouldBe` 1000 - batchSummaryFailures batch `shouldBe` 0 - batchSummarySuccesses batch `shouldBe` 1000 - batchSummaryCompleted batch `shouldBe` 1000 - batchSummaryStatus batch `shouldBe` BatchFinished + Just summary <- batchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1000 + batchSummaryFailures summary `shouldBe` 0 + batchSummarySuccesses summary `shouldBe` 1000 + batchSummaryCompleted summary `shouldBe` 1000 + batchSummaryStatus summary `shouldBe` BatchFinished killThread wthread destroy hworker From ea9ac1dc21616fdc814dae1cb4f290a0bc62d5e5 Mon Sep 17 00:00:00 2001 From: remeike Date: Wed, 23 Nov 2022 12:22:20 -0500 Subject: [PATCH 15/36] Bump version --- CHANGELOG.md | 4 ++++ hworker.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index dc7c099..3f81095 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +* 0.3.0 Remeike Forbes 2022-11-23 + + Introduce batched jobs + * 0.2.0 Remeike Forbes Coerce jobs to string (to work with Redis 5) diff --git a/hworker.cabal b/hworker.cabal index 9164854..71cc63c 100644 --- a/hworker.cabal +++ b/hworker.cabal @@ -1,5 +1,5 @@ name: hworker -version: 0.2.0 +version: 0.3.0 synopsis: A reliable at-least-once job queue built on top of redis. description: See README. homepage: http://github.com/positiondev/hworker From 72fb243d4262e8ff4b6521401721f6f69aeae78a Mon Sep 17 00:00:00 2001 From: remeike Date: Thu, 24 Nov 2022 14:14:00 -0600 Subject: [PATCH 16/36] Change formatting --- src/System/Hworker.hs | 1035 ++++++++++++++++++++++++----------------- test/Spec.hs | 1026 +++++++++++++++++++++------------------- 2 files changed, 1148 insertions(+), 913 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 5dfcaab..4032e59 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -44,78 +45,92 @@ also good examples): -} module System.Hworker - ( -- * Types - Result(..) - , Job(..) - , Hworker - , HworkerConfig(..) - , ExceptionBehavior(..) - , RedisConnection(..) - , defaultHworkerConfig - , BatchId(..) - , BatchStatus(..) - , BatchSummary(..) - -- * Managing Workers - , create - , createWith - , destroy - , batchSummary - , worker - , monitor - -- * Queuing Jobs - , queue - , queueBatched - , initBatch - , stopBatchQueueing - -- * Inspecting Workers - , jobs - , failed - , broken - -- * Debugging Utilities - , debugger - ) - where - -import Control.Arrow (second) -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -import Control.Exception (SomeException, catchJust, - asyncExceptionFromException, - AsyncException) -import Control.Monad (forM, forever, void, when) -import Control.Monad.Trans (liftIO) -import Data.Aeson (FromJSON, ToJSON, (.=), (.:) ) -import qualified Data.Aeson as A -import Data.Aeson.Helpers -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as LB -import Data.Either (isRight) -import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe, - listToMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Time.Calendar (Day (..)) -import Data.Time.Clock (NominalDiffTime, UTCTime (..), - diffUTCTime, getCurrentTime) -import Data.UUID ( UUID ) -import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUID -import qualified Database.Redis as R -import GHC.Generics (Generic) + ( -- * Types + Result(..) + , Job(..) + , Hworker + , HworkerConfig(..) + , ExceptionBehavior(..) + , RedisConnection(..) + , defaultHworkerConfig + , BatchId(..) + , BatchStatus(..) + , BatchSummary(..) + -- * Managing Workers + , create + , createWith + , destroy + , batchSummary + , worker + , monitor + -- * Queuing Jobs + , queue + , queueBatched + , initBatch + , stopBatchQueueing + -- * Inspecting Workers + , jobs + , failed + , broken + -- * Debugging Utilities + , debugger + ) where + +-------------------------------------------------------------------------------- +import Control.Arrow ( second) +import Control.Concurrent ( threadDelay) +import Control.Exception ( SomeException + , catchJust + , asyncExceptionFromException + , AsyncException + ) +import Control.Monad ( forM_, forever, void, when ) +import Control.Monad.Trans ( liftIO ) +import Data.Aeson ( FromJSON, ToJSON, (.=), (.:) ) +import qualified Data.Aeson as A +import Data.Aeson.Helpers ( decodeValue ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as LB +import Data.Either ( isRight ) +import Data.Maybe ( isJust, mapMaybe, listToMaybe ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock ( NominalDiffTime + , UTCTime (..) + , diffUTCTime + , getCurrentTime + ) +import Data.UUID ( UUID ) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID +import Database.Redis ( Redis + , Connection + , ConnectInfo + , runRedis + ) +import qualified Database.Redis as R +import GHC.Generics ( Generic ) +-------------------------------------------------------------------------------- + + -- | Jobs can return 'Success', 'Retry' (with a message), or 'Failure' -- (with a message). Jobs that return 'Failure' are stored in the -- 'failed' queue and are not re-run. Jobs that return 'Retry' are re-run. -data Result = Success - | Retry Text - | Failure Text - deriving (Generic, Show) + +data Result + = Success + | Retry Text + | Failure Text + deriving (Generic, Show) + + instance ToJSON Result instance FromJSON Result + -- | Each Worker that you create will be responsible for one type of -- job, defined by a 'Job' instance. -- @@ -138,21 +153,30 @@ instance FromJSON Result -- queue). This will only happen if the queue is non-empty when you -- replce the running application version, but this is obviously -- possible and could be likely depending on your use. + class (FromJSON t, ToJSON t, Show t) => Job s t | s -> t where job :: s -> t -> IO Result -data JobData t = JobData UTCTime t -- | What should happen when an unexpected exception is thrown in a -- job - it can be treated as either a 'Failure' (the default) or a -- 'Retry' (if you know the only exceptions are triggered by -- intermittent problems). -data ExceptionBehavior = RetryOnException | FailOnException + +data ExceptionBehavior + = RetryOnException + | FailOnException + type JobId = Text + -- | A unique identifier for grouping jobs together. -newtype BatchId = BatchId UUID deriving (ToJSON, FromJSON, Eq, Show) + +newtype BatchId = + BatchId UUID + deriving (ToJSON, FromJSON, Eq, Show) + -- | Represents the current status of a batch. A batch is considered to be -- "queueing" if jobs can still be added to the batch. While jobs are @@ -160,25 +184,20 @@ newtype BatchId = BatchId UUID deriving (ToJSON, FromJSON, Eq, Show) -- The status only changes to "processing" once jobs can no longer be queued -- but are still being processed. The batch is then finished once all jobs -- are processed (they have either failed or succeeded). -data BatchStatus = BatchQueueing | BatchProcessing | BatchFinished - deriving (Eq, Show) -encodeBatchStatus :: BatchStatus -> ByteString -encodeBatchStatus BatchQueueing = "queueing" -encodeBatchStatus BatchProcessing = "processing" -encodeBatchStatus BatchFinished = "finished" +data BatchStatus + = BatchQueueing + | BatchProcessing + | BatchFinished + deriving (Eq, Show) -decodeBatchStatus :: ByteString -> Maybe BatchStatus -decodeBatchStatus "queueing" = Just BatchQueueing -decodeBatchStatus "processing" = Just BatchProcessing -decodeBatchStatus "finished" = Just BatchFinished -decodeBatchStatus _ = Nothing -- | A summary of a particular batch, including figures on the total number -- of jobs queued, the number of jobs that have completed (i.e. -- failed or succeeded), the number of jobs succeeded, the number of jobs -- failed, the number of jobs retried, and the current status of the -- batch overall. + data BatchSummary = BatchSummary { batchSummaryID :: BatchId @@ -190,42 +209,57 @@ data BatchSummary = , batchSummaryStatus :: BatchStatus } deriving (Eq, Show) -data JobRef = JobRef JobId (Maybe BatchId) deriving (Eq, Show) + +data JobRef = + JobRef JobId (Maybe BatchId) + deriving (Eq, Show) + instance ToJSON JobRef where toJSON (JobRef j b) = A.object ["j" .= j, "b" .= b] + instance FromJSON JobRef where -- NOTE(rjbf 2022-11-19): This is just here for the sake of migration and -- can be removed eventually. Before `JobRef`, which is encoded as -- a JSON object, there was a just a `String` representing the job ID. + parseJSON (A.String j) = pure (JobRef j Nothing) parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b") val + hwlog :: Show a => Hworker s t -> a -> IO () -hwlog hw a = hworkerLogger hw (hworkerName hw, a) +hwlog hw a = + hworkerLogger hw (hworkerName hw, a) + -- | The worker data type - it is parametrized be the worker -- state (the `s`) and the job type (the `t`). + data Hworker s t = - Hworker { hworkerName :: ByteString - , hworkerState :: s - , hworkerConnection :: R.Connection - , hworkerExceptionBehavior :: ExceptionBehavior - , hworkerLogger :: forall a. Show a => a -> IO () - , hworkerJobTimeout :: NominalDiffTime - , hworkerFailedQueueSize :: Int - , hworkerDebug :: Bool - , hworkerBatchCompleted :: BatchSummary -> IO () - } + Hworker + { hworkerName :: ByteString + , hworkerState :: s + , hworkerConnection :: Connection + , hworkerExceptionBehavior :: ExceptionBehavior + , hworkerLogger :: forall a. Show a => a -> IO () + , hworkerJobTimeout :: NominalDiffTime + , hworkerFailedQueueSize :: Int + , hworkerDebug :: Bool + , hworkerBatchCompleted :: BatchSummary -> IO () + } + -- | When configuring a worker, you can tell it to use an existing -- redis connection pool (which you may have for the rest of your -- application). Otherwise, you can specify connection info. By -- default, hworker tries to connect to localhost, which may not be -- true for your production application. -data RedisConnection = RedisConnectInfo R.ConnectInfo - | RedisConnection R.Connection + +data RedisConnection + = RedisConnectInfo ConnectInfo + | RedisConnection Connection + -- | The main configuration for workers. -- @@ -251,302 +285,403 @@ data RedisConnection = RedisConnectInfo R.ConnectInfo -- -- 'hwconfigFailedQueueSize' controls how many 'failed' jobs will be -- kept. It defaults to 1000. + data HworkerConfig s = - HworkerConfig { - hwconfigName :: Text - , hwconfigState :: s - , hwconfigRedisConnectInfo :: RedisConnection - , hwconfigExceptionBehavior :: ExceptionBehavior - , hwconfigLogger :: forall a. Show a => a -> IO () - , hwconfigTimeout :: NominalDiffTime - , hwconfigFailedQueueSize :: Int - , hwconfigDebug :: Bool - } + HworkerConfig + { hwconfigName :: Text + , hwconfigState :: s + , hwconfigRedisConnectInfo :: RedisConnection + , hwconfigExceptionBehavior :: ExceptionBehavior + , hwconfigLogger :: forall a. Show a => a -> IO () + , hwconfigTimeout :: NominalDiffTime + , hwconfigFailedQueueSize :: Int + , hwconfigDebug :: Bool + } + -- | The default worker config - it needs a name and a state (as those -- will always be unique). + defaultHworkerConfig :: Text -> s -> HworkerConfig s defaultHworkerConfig name state = - HworkerConfig name - state - (RedisConnectInfo R.defaultConnectInfo) - FailOnException - print - 120 - 1000 - False + HworkerConfig + { hwconfigName = name + , hwconfigState = state + , hwconfigRedisConnectInfo = RedisConnectInfo R.defaultConnectInfo + , hwconfigExceptionBehavior = FailOnException + , hwconfigLogger = print + , hwconfigTimeout = 120 + , hwconfigFailedQueueSize = 1000 + , hwconfigDebug = False + } + -- | Create a new worker with the default 'HworkerConfig'. -- -- Note that you must create at least one 'worker' and 'monitor' for -- the queue to actually process jobs (and for it to retry ones that -- time-out). + create :: Job s t => Text -> s -> IO (Hworker s t) -create name state = createWith (defaultHworkerConfig name state) +create name state = + createWith (defaultHworkerConfig name state) + -- | Create a new worker with a specified 'HworkerConfig'. -- -- Note that you must create at least one 'worker' and 'monitor' for -- the queue to actually process jobs (and for it to retry ones that -- time-out). + createWith :: Job s t => HworkerConfig s -> IO (Hworker s t) -createWith HworkerConfig{..} = - do conn <- case hwconfigRedisConnectInfo of - RedisConnectInfo c -> R.connect c - RedisConnection c -> return c - return $ Hworker (T.encodeUtf8 hwconfigName) - hwconfigState - conn - hwconfigExceptionBehavior - hwconfigLogger - hwconfigTimeout - hwconfigFailedQueueSize - hwconfigDebug - (const (return ())) +createWith HworkerConfig{..} = do + conn <- + case hwconfigRedisConnectInfo of + RedisConnectInfo c -> R.connect c + RedisConnection c -> return c + + return $ + Hworker + { hworkerName = T.encodeUtf8 hwconfigName + , hworkerState = hwconfigState + , hworkerConnection = conn + , hworkerExceptionBehavior = hwconfigExceptionBehavior + , hworkerLogger = hwconfigLogger + , hworkerJobTimeout = hwconfigTimeout + , hworkerFailedQueueSize = hwconfigFailedQueueSize + , hworkerDebug = hwconfigDebug + , hworkerBatchCompleted = const (return ()) + } + -- | Destroy a worker. This will delete all the queues, clearing out --- all existing 'jobs', the 'broken' and 'failed' queues. There is no need --- to do this in normal applications (and most likely, you won't want to). +-- all existing 'jobs', the 'broken' and 'failed' queues, and the hashes for +-- batched jobs. There is no need to do this in normal applications +-- (and most likely, you won't want to). + destroy :: Job s t => Hworker s t -> IO () -destroy hw = void $ R.runRedis (hworkerConnection hw) $ do - withList' hw (R.keys $ "hworker-batch-" <> hworkerName hw <> "*") (void . R.del) - R.del [ jobQueue hw - , progressQueue hw - , brokenQueue hw - , failedQueue hw - ] +destroy hw = + let + batchKeys = + "hworker-batch-" <> hworkerName hw <> "*" + in + void $ runRedis (hworkerConnection hw) $ do + R.keys batchKeys >>= + \case + Left err -> liftIO $ hwlog hw err + Right keys -> void $ R.del keys + + R.del + [ jobQueue hw + , progressQueue hw + , brokenQueue hw + , failedQueue hw + ] + jobQueue :: Hworker s t -> ByteString -jobQueue hw = "hworker-jobs-" <> hworkerName hw +jobQueue hw = + "hworker-jobs-" <> hworkerName hw + progressQueue :: Hworker s t -> ByteString -progressQueue hw = "hworker-progress-" <> hworkerName hw +progressQueue hw = + "hworker-progress-" <> hworkerName hw + brokenQueue :: Hworker s t -> ByteString -brokenQueue hw = "hworker-broken-" <> hworkerName hw +brokenQueue hw = + "hworker-broken-" <> hworkerName hw + failedQueue :: Hworker s t -> ByteString -failedQueue hw = "hworker-failed-" <> hworkerName hw +failedQueue hw = + "hworker-failed-" <> hworkerName hw + batchCounter :: Hworker s t -> BatchId -> ByteString batchCounter hw (BatchId batch) = "hworker-batch-" <> hworkerName hw <> ":" <> UUID.toASCIIBytes batch + -- | Adds a job to the queue. Returns whether the operation succeeded. + queue :: Job s t => Hworker s t -> t -> IO Bool -queue hw j = - do job_id <- UUID.toText <$> UUID.nextRandom - isRight <$> R.runRedis (hworkerConnection hw) - (R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id Nothing, j)]) +queue hw j = do + jobId <- UUID.toText <$> UUID.nextRandom + result <- + runRedis (hworkerConnection hw) + $ R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef jobId Nothing, j)] + return $ isRight result + -- | Adds a job to the queue, but as part of a particular batch of jobs. -- Returns whether the operation succeeded. + queueBatched :: Job s t => Hworker s t -> t -> BatchId -> IO Bool queueBatched hw j batch = do - job_id <- UUID.toText <$> UUID.nextRandom - R.runRedis (hworkerConnection hw) $ do - s <- R.hget (batchCounter hw batch) "status" - case s of - Left err -> - liftIO (hwlog hw err) >> return False + jobId <- UUID.toText <$> UUID.nextRandom + runRedis (hworkerConnection hw) $ + R.hget (batchCounter hw batch) "status" >>= + \case + Left err -> do + liftIO (hwlog hw err) + return False + + Right Nothing -> do + liftIO $ hwlog hw $ "BATCH NOT FOUND: " <> show batch + return False + + Right (Just status) | status == "queueing" -> + let + ref = + JobRef jobId (Just batch) + in do + result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] + _ <- R.hincrby (batchCounter hw batch) "queued" 1 + return $ isRight result + + Right (Just _)-> do + liftIO $ hwlog hw $ + mconcat + [ "QUEUEING COMPLETED FOR BATCH: " + , show batch + , ". CANNOT ENQUEUE NEW JOBS." + ] + return False - Right Nothing -> do - liftIO $ hwlog hw $ "Batch not found: " <> show batch - return False - - Right (Just status) | status == "queueing" -> do - result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef job_id (Just batch), j)] - void $ R.hincrby (batchCounter hw batch) "queued" 1 - return $ isRight result - - Right (Just _)-> do - liftIO $ hwlog hw $ "Batch queuing completed, cannot enqueue further: " <> show batch - return False -- | Prevents queueing new jobs to a batch. If the number of jobs completed equals -- the number of jobs queued, then the status of the batch is immediately set -- to `BatchFinished`, otherwise it's set to `BatchProcessing`. + stopBatchQueueing :: Hworker s t -> BatchId -> IO () stopBatchQueueing hw batch = - void . R.runRedis (hworkerConnection hw) $ do - r <- batchSummary' hw batch - case r of - Nothing -> - liftIO $ hwlog hw $ "Batch not found: " <> show batch + runRedis (hworkerConnection hw) $ do + batchSummary' hw batch >>= + \case + Nothing -> + liftIO $ hwlog hw $ "Batch not found: " <> show batch + + Just summary | batchSummaryCompleted summary >= batchSummaryQueued summary -> + void + $ R.hset (batchCounter hw batch) "status" + $ encodeBatchStatus BatchFinished - Just summary | batchSummaryCompleted summary >= batchSummaryQueued summary -> - void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchFinished) + Just _-> + void + $ R.hset (batchCounter hw batch) "status" + $ encodeBatchStatus BatchProcessing - Just _-> do - void $ R.hset (batchCounter hw batch) "status" (encodeBatchStatus BatchProcessing) -- | Creates a new worker thread. This is blocking, so you will want to -- 'forkIO' this into a thread. You can have any number of these (and -- on any number of servers); the more there are, the faster jobs will -- be processed. + worker :: Job s t => Hworker s t -> IO () worker hw = - do now <- getCurrentTime - r <- R.runRedis (hworkerConnection hw) $ - R.eval "local job = redis.call('rpop',KEYS[1])\n\ - \if job ~= nil then\n\ - \ redis.call('hset', KEYS[2], tostring(job), ARGV[1])\n\ - \ return job\n\ - \else\n\ - \ return nil\n\ - \end" - [jobQueue hw, progressQueue hw] - [LB.toStrict $ A.encode now] - case r of - Left err -> hwlog hw err >> delayAndRun - Right Nothing -> delayAndRun - Right (Just t) -> - do when (hworkerDebug hw) $ hwlog hw ("WORKER RUNNING", t) - case decodeValue (LB.fromStrict t) of - Nothing -> do hwlog hw ("BROKEN JOB", t) - now <- getCurrentTime - withNil hw (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ - \if del == 1 then\n\ - \ redis.call('hset', KEYS[2], ARGV[1], ARGV[2])\n\ - \end\n\ - \return nil" - [progressQueue hw, brokenQueue hw] - [t, LB.toStrict $ A.encode now]) - delayAndRun - Just (JobRef _ maybeBatch, j) -> do - result <- runJob (job (hworkerState hw) j) - case result of - Success -> - do when (hworkerDebug hw) $ hwlog hw ("JOB COMPLETE", t) - case maybeBatch of - Nothing -> do - delete_res <- R.runRedis (hworkerConnection hw) - (R.hdel (progressQueue hw) [t]) - case delete_res of - Left err -> hwlog hw err >> delayAndRun - Right 1 -> justRun - Right n -> do hwlog hw ("Job done: did not delete 1, deleted " <> show n) - delayAndRun - - Just batch -> - withMaybe hw - (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ - \if del == 1 then\n\ - \ local batch = KEYS[2]\n\ - \ redis.call('hincrby', batch, 'successes', '1')\n\ - \ local completed = redis.call('hincrby', batch, 'completed', '1')\n\ - \ local queued = redis.call('hincrby', batch, 'queued', '0')\n\ - \ local status = redis.call('hget', batch, 'status')\n\ - \ if tonumber(completed) >= tonumber(queued) and status == 'processing' then\n\ - \ redis.call('hset', batch, 'status', 'finished')\n\ - \ end\n\ - \ return redis.call('hgetall', batch)\ - \end\n\ - \return nil" - [progressQueue hw, batchCounter hw batch] - [t] - ) - (\r -> - case decodeBatchSummary batch r of - Nothing -> do - hwlog hw ("Job done: did not delete 1" :: Text) - delayAndRun - - Just summary -> do - when (batchSummaryStatus summary == BatchFinished) - $ hworkerBatchCompleted hw summary - justRun - ) - - - Retry msg -> - do hwlog hw ("Retry: " <> msg) - case maybeBatch of - Nothing -> do - withNil hw - (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ - \if del == 1 then\n\ - \ redis.call('lpush', KEYS[2], ARGV[1])\n\ - \end\n\ - \return nil" - [progressQueue hw, jobQueue hw] - [t]) - delayAndRun - - Just batch -> do - withNil hw - (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ - \if del == 1 then\n\ - \ redis.call('lpush', KEYS[2], ARGV[1])\n\ - \ redis.call('hincrby', KEYS[3], 'retries', '1')\n\ - \end\n\ - \return nil" - [progressQueue hw, jobQueue hw, batchCounter hw batch] - [t]) - delayAndRun - - Failure msg -> - do hwlog hw ("Failure: " <> msg) - case maybeBatch of - Nothing -> do - withNil hw - (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ - \if del == 1 then\n\ - \ redis.call('lpush', KEYS[2], ARGV[1])\n\ - \ redis.call('ltrim', KEYS[2], 0, ARGV[2])\n\ - \end\n\ - \return nil" - [progressQueue hw, failedQueue hw] - [t, B8.pack (show (hworkerFailedQueueSize hw - 1))]) - delayAndRun - - Just batch -> do - withMaybe hw - (R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ - \if del == 1 then\n\ - \ redis.call('lpush', KEYS[2], ARGV[1])\n\ - \ redis.call('ltrim', KEYS[2], 0, ARGV[2])\n\ - \ local batch = KEYS[3]\n\ - \ redis.call('hincrby', batch, 'failures', '1')\n\ - \ local completed = redis.call('hincrby', batch, 'completed', '1')\n\ - \ local queued = redis.call('hincrby', batch, 'queued', '0')\n\ - \ local status = redis.call('hget', batch, 'status')\n\ - \ if tonumber(completed) >= tonumber(queued) and status == 'processing' then\n\ - \ redis.call('hset', batch, 'status', 'finished')\n\ - \ return redis.call('hgetall', batch)\ - \ end\n\ - \end\n\ - \return nil" - [progressQueue hw, failedQueue hw, batchCounter hw batch] - [t, B8.pack (show (hworkerFailedQueueSize hw - 1))] - ) - (\s -> - case decodeBatchSummary batch s of - Nothing -> return () - Just summary -> hworkerBatchCompleted hw summary - ) - delayAndRun - - where delayAndRun = threadDelay 10000 >> worker hw - justRun = worker hw - runJob v = - do res <- - catchJust - ( \(e :: SomeException) -> - if isJust (asyncExceptionFromException e :: Maybe AsyncException) then - Nothing - else - Just e - ) - ( Right <$> v ) - ( \e -> return (Left e) ) - case res of - Left e -> - let b = case hworkerExceptionBehavior hw of - RetryOnException -> Retry - FailOnException -> Failure in - return (b ("Exception raised: " <> (T.pack . show) e)) - Right r -> return r + let + delayAndRun = + threadDelay 10000 >> worker hw + + justRun = + worker hw + + runJob action = do + eitherResult <- + catchJust + ( \(e :: SomeException) -> + if isJust (asyncExceptionFromException e :: Maybe AsyncException) + then Nothing + else Just e + ) + ( Right <$> action ) + ( return . Left ) + + case eitherResult of + Left exception -> + let + resultMessage = + case hworkerExceptionBehavior hw of + RetryOnException -> Retry + FailOnException -> Failure + in + return + $ resultMessage + $ "Exception raised: " <> (T.pack . show) exception + + Right result -> + return result + in do + now <- getCurrentTime + + eitherReply <- + runRedis (hworkerConnection hw) $ + R.eval + "local job = redis.call('rpop',KEYS[1])\n\ + \if job ~= nil then\n\ + \ redis.call('hset', KEYS[2], tostring(job), ARGV[1])\n\ + \ return job\n\ + \else\n\ + \ return nil\n\ + \end" + [jobQueue hw, progressQueue hw] + [LB.toStrict $ A.encode now] + + case eitherReply of + Left err -> + hwlog hw err >> delayAndRun + + Right Nothing -> + delayAndRun + + Right (Just t) -> do + when (hworkerDebug hw) $ hwlog hw ("WORKER RUNNING" :: Text, t) + + case decodeValue (LB.fromStrict t) of + Nothing -> do + hwlog hw ("BROKEN JOB" :: Text, t) + now' <- getCurrentTime + + withNil hw $ + R.eval + "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('hset', KEYS[2], ARGV[1], ARGV[2])\n\ + \end\n\ + \return nil" + [progressQueue hw, brokenQueue hw] + [t, LB.toStrict $ A.encode now'] + + delayAndRun + + Just (JobRef _ maybeBatch, j) -> do + runJob (job (hworkerState hw) j) >>= + \case + Success -> do + when (hworkerDebug hw) $ hwlog hw ("JOB COMPLETE" :: Text, t) + + case maybeBatch of + Nothing -> do + deletionResult <- + runRedis (hworkerConnection hw) + $ R.hdel (progressQueue hw) [t] + + case deletionResult of + Left err -> hwlog hw err >> delayAndRun + Right 1 -> justRun + Right n -> do + hwlog hw ("Job done: did not delete 1, deleted " <> show n) + delayAndRun + + Just batch -> + withMaybe hw + ( R.eval + "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ local batch = KEYS[2]\n\ + \ redis.call('hincrby', batch, 'successes', '1')\n\ + \ local completed = redis.call('hincrby', batch, 'completed', '1')\n\ + \ local queued = redis.call('hincrby', batch, 'queued', '0')\n\ + \ local status = redis.call('hget', batch, 'status')\n\ + \ if tonumber(completed) >= tonumber(queued) and status == 'processing' then\n\ + \ redis.call('hset', batch, 'status', 'finished')\n\ + \ end\n\ + \ return redis.call('hgetall', batch)\ + \end\n\ + \return nil" + [progressQueue hw, batchCounter hw batch] + [t] + ) + ( \hm -> + case decodeBatchSummary batch hm of + Nothing -> do + hwlog hw ("Job done: did not delete 1" :: Text) + delayAndRun + + Just summary -> do + when (batchSummaryStatus summary == BatchFinished) + $ hworkerBatchCompleted hw summary + justRun + ) + + + Retry msg -> do + hwlog hw ("RETRY: " <> msg) + + case maybeBatch of + Nothing -> do + withNil hw $ + R.eval + "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('lpush', KEYS[2], ARGV[1])\n\ + \end\n\ + \return nil" + [progressQueue hw, jobQueue hw] + [t] + + delayAndRun + + Just batch -> do + withNil hw $ + R.eval + "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('lpush', KEYS[2], ARGV[1])\n\ + \ redis.call('hincrby', KEYS[3], 'retries', '1')\n\ + \end\n\ + \return nil" + [progressQueue hw, jobQueue hw, batchCounter hw batch] + [t] + + delayAndRun + + Failure msg -> do + hwlog hw ("Failure: " <> msg) + + case maybeBatch of + Nothing -> do + withNil hw $ + R.eval + "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('lpush', KEYS[2], ARGV[1])\n\ + \ redis.call('ltrim', KEYS[2], 0, ARGV[2])\n\ + \end\n\ + \return nil" + [progressQueue hw, failedQueue hw] + [t, B8.pack (show (hworkerFailedQueueSize hw - 1))] + + delayAndRun + + Just batch -> do + withMaybe hw + ( R.eval + "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ + \if del == 1 then\n\ + \ redis.call('lpush', KEYS[2], ARGV[1])\n\ + \ redis.call('ltrim', KEYS[2], 0, ARGV[2])\n\ + \ local batch = KEYS[3]\n\ + \ redis.call('hincrby', batch, 'failures', '1')\n\ + \ local completed = redis.call('hincrby', batch, 'completed', '1')\n\ + \ local queued = redis.call('hincrby', batch, 'queued', '0')\n\ + \ local status = redis.call('hget', batch, 'status')\n\ + \ if tonumber(completed) >= tonumber(queued) and status == 'processing' then\n\ + \ redis.call('hset', batch, 'status', 'finished')\n\ + \ return redis.call('hgetall', batch)\ + \ end\n\ + \end\n\ + \return nil" + [progressQueue hw, failedQueue hw, batchCounter hw batch] + [t, B8.pack (show (hworkerFailedQueueSize hw - 1))] + ) + ( \hm -> + forM_ (decodeBatchSummary batch hm) + $ hworkerBatchCompleted hw + ) + delayAndRun -- | Start a monitor. Like 'worker', this is blocking, so should be @@ -554,81 +689,112 @@ worker hw = -- time out (which can happen if the processing thread is killed, for -- example). You need to have at least one of these running to have -- the retry happen, but it is safe to have any number running. + monitor :: Job s t => Hworker s t -> IO () monitor hw = - forever $ - do now <- getCurrentTime - withList hw (R.hkeys (progressQueue hw)) - (\jobs -> - void $ forM jobs $ \job -> - withMaybe hw (R.hget (progressQueue hw) job) - (\start -> - when (diffUTCTime now (fromJust $ decodeValue (LB.fromStrict start)) > hworkerJobTimeout hw) $ - do n <- - withInt hw - (R.eval "local del = redis.call('hdel', KEYS[2], ARGV[1])\n\ - \if del == 1 then\ - \ redis.call('rpush', KEYS[1], ARGV[1])\n\ \end\n\ - \return del" - [jobQueue hw, progressQueue hw] - [job]) - when (hworkerDebug hw) $ hwlog hw ("MONITOR RV", n) - when (hworkerDebug hw && n == 1) $ hwlog hw ("MONITOR REQUEUED", job))) - -- NOTE(dbp 2015-07-25): We check every 1/10th of timeout. - threadDelay (floor $ 100000 * hworkerJobTimeout hw) + forever $ do + now <- getCurrentTime + + withList hw (R.hkeys (progressQueue hw)) $ \js -> + forM_ js $ \j -> + withMaybe hw (R.hget (progressQueue hw) j) $ + \start -> + let + duration = + diffUTCTime now (parseTime start) + + in + when (duration > hworkerJobTimeout hw) $ do + n <- + withInt hw $ + R.eval + "local del = redis.call('hdel', KEYS[2], ARGV[1])\n\ + \if del == 1 then\ + \ redis.call('rpush', KEYS[1], ARGV[1])\n\ + \end\n\ + \return del" + [jobQueue hw, progressQueue hw] + [j] + when (hworkerDebug hw) + $ hwlog hw ("MONITOR RV" :: Text, n) + when (hworkerDebug hw && n == 1) + $ hwlog hw ("MONITOR REQUEUED" :: Text, j) + + -- NOTE(dbp 2015-07-25): We check every 1/10th of timeout. + threadDelay (floor $ 100000 * hworkerJobTimeout hw) + -- | Returns the jobs that could not be deserialized, most likely -- because you changed the 'ToJSON'/'FromJSON' instances for you job -- in a way that resulted in old jobs not being able to be converted -- back from json. Another reason for jobs to end up here (and much -- worse) is if you point two instances of 'Hworker', with different --- job types, at the same queue (ie, you re-use the name). Then +-- job types, at the same queue (i.e., you re-use the name). Then -- anytime a worker from one queue gets a job from the other it would -- think it is broken. + broken :: Hworker s t -> IO [(ByteString, UTCTime)] -broken hw = do r <- R.runRedis (hworkerConnection hw) (R.hgetall (brokenQueue hw)) - case r of - Left err -> hwlog hw err >> return [] - Right xs -> return (map (second parseTime) xs) - where parseTime = fromJust . decodeValue . LB.fromStrict +broken hw = + runRedis (hworkerConnection hw) (R.hgetall (brokenQueue hw)) >>= + \case + Left err -> hwlog hw err >> return [] + Right xs -> return (map (second parseTime) xs) + jobsFromQueue :: Job s t => Hworker s t -> ByteString -> IO [t] -jobsFromQueue hw queue = - do r <- R.runRedis (hworkerConnection hw) (R.lrange queue 0 (-1)) - case r of - Left err -> hwlog hw err >> return [] - Right [] -> return [] - Right xs -> return $ mapMaybe (fmap (\(JobRef _ _, x) -> x) . decodeValue . LB.fromStrict) xs +jobsFromQueue hw q = + runRedis (hworkerConnection hw) (R.lrange q 0 (-1)) >>= + \case + Left err -> + hwlog hw err >> return [] + + Right [] -> + return [] + + Right xs -> + return + $ mapMaybe (fmap (\(JobRef _ _, x) -> x) . decodeValue . LB.fromStrict) xs + -- | Returns all pending jobs. + jobs :: Job s t => Hworker s t -> IO [t] -jobs hw = jobsFromQueue hw (jobQueue hw) +jobs hw = + jobsFromQueue hw (jobQueue hw) + -- | Returns all failed jobs. This is capped at the most recent -- 'hworkerconfigFailedQueueSize' jobs that returned 'Failure' (or -- threw an exception when 'hworkerconfigExceptionBehavior' is -- 'FailOnException'). + failed :: Job s t => Hworker s t -> IO [t] -failed hw = jobsFromQueue hw (failedQueue hw) +failed hw = + jobsFromQueue hw (failedQueue hw) + -- | Logs the contents of the jobqueue and the inprogress queue at -- `microseconds` intervals. + debugger :: Job s t => Int -> Hworker s t -> IO () debugger microseconds hw = - forever $ - do withList hw (R.hkeys (progressQueue hw)) - (\running -> - withList hw (R.lrange (jobQueue hw) 0 (-1)) - (\queued -> hwlog hw ("DEBUG", queued, running))) - threadDelay microseconds + forever $ do + withList hw (R.hkeys (progressQueue hw)) $ + \running -> + withList hw (R.lrange (jobQueue hw) 0 (-1)) + $ \queued -> hwlog hw ("DEBUG" :: Text, queued, running) + + threadDelay microseconds + -- | Initializes a batch of jobs. By default the information for tracking a -- batch of jobs, created by this function, will expires a week from -- its creation. The optional `seconds` argument can be used to override this. + initBatch :: Hworker s t -> Maybe Integer -> IO (Maybe BatchId) initBatch hw mseconds = do batch <- BatchId <$> UUID.nextRandom - R.runRedis (hworkerConnection hw) $ do + runRedis (hworkerConnection hw) $ do r <- R.hmset (batchCounter hw batch) [ ("queued", "0") @@ -646,80 +812,95 @@ initBatch hw mseconds = do case mseconds of Nothing -> return () Just s -> void $ R.expire (batchCounter hw batch) s + return (Just batch) + -- | Return a summary of the batch. + batchSummary :: Hworker s t -> BatchId -> IO (Maybe BatchSummary) batchSummary hw batch = - R.runRedis (hworkerConnection hw) (batchSummary' hw batch) + runRedis (hworkerConnection hw) (batchSummary' hw batch) + -batchSummary' :: Hworker s t -> BatchId -> R.Redis (Maybe BatchSummary) +batchSummary' :: Hworker s t -> BatchId -> Redis (Maybe BatchSummary) batchSummary' hw batch = do - r <- R.hgetall (batchCounter hw batch) - case r of - Left err -> liftIO (hwlog hw err) >> return Nothing - Right hm -> return $ decodeBatchSummary batch hm + R.hgetall (batchCounter hw batch) >>= + \case + Left err -> liftIO (hwlog hw err) >> return Nothing + Right hm -> return $ decodeBatchSummary batch hm + + +-- Redis helpers follow + +withList :: + Show a => Hworker s t -> Redis (Either a [b]) -> ([b] -> IO ()) -> IO () +withList hw a f = + runRedis (hworkerConnection hw) a >>= + \case + Left err -> hwlog hw err + Right [] -> return () + Right xs -> f xs + + +withMaybe :: + Show a => Hworker s t -> Redis (Either a (Maybe b)) -> (b -> IO ()) -> IO () +withMaybe hw a f = do + runRedis (hworkerConnection hw) a >>= + \case + Left err -> hwlog hw err + Right Nothing -> return () + Right (Just v) -> f v + + +withNil :: Show a => Hworker s t -> Redis (Either a (Maybe ByteString)) -> IO () +withNil hw a = + runRedis (hworkerConnection hw) a >>= + \case + Left err -> hwlog hw err + Right _ -> return () + + +withInt :: Hworker s t -> Redis (Either R.Reply Integer) -> IO Integer +withInt hw a = + runRedis (hworkerConnection hw) a >>= + \case + Left err -> hwlog hw err >> return (-1) + Right n -> return n + + +-- Parsing Helpers + +encodeBatchStatus :: BatchStatus -> ByteString +encodeBatchStatus BatchQueueing = "queueing" +encodeBatchStatus BatchProcessing = "processing" +encodeBatchStatus BatchFinished = "finished" + + +decodeBatchStatus :: ByteString -> Maybe BatchStatus +decodeBatchStatus "queueing" = Just BatchQueueing +decodeBatchStatus "processing" = Just BatchProcessing +decodeBatchStatus "finished" = Just BatchFinished +decodeBatchStatus _ = Nothing + decodeBatchSummary :: BatchId -> [(ByteString, ByteString)] -> Maybe BatchSummary decodeBatchSummary batch hm = - BatchSummary - <$> pure batch - <*> (lookup "queued" hm >>= readMaybe) + BatchSummary batch + <$> (lookup "queued" hm >>= readMaybe) <*> (lookup "completed" hm >>= readMaybe) <*> (lookup "successes" hm >>= readMaybe) <*> (lookup "failures" hm >>= readMaybe) <*> (lookup "retries" hm >>= readMaybe) <*> (lookup "status" hm >>= decodeBatchStatus) --- Redis helpers follow -withList hw a f = - do r <- R.runRedis (hworkerConnection hw) a - case r of - Left err -> hwlog hw err - Right [] -> return () - Right xs -> f xs - -withMaybe hw a f = - do r <- R.runRedis (hworkerConnection hw) a - case r of - Left err -> hwlog hw err - Right Nothing -> return () - Right (Just v) -> f v -withNil hw a = - do r <- R.runRedis (hworkerConnection hw) a - case r of - Left err -> hwlog hw err - Right (Just ("" :: ByteString)) -> return () - Right _ -> return () +parseTime :: ByteString -> UTCTime +parseTime t = + case decodeValue (LB.fromStrict t) of + Nothing -> error ("FAILED TO PARSE TIMESTAMP: " <> B8.unpack t) + Just time -> time -withInt :: Hworker s t -> R.Redis (Either R.Reply Integer) -> IO Integer -withInt hw a = - do r <- R.runRedis (hworkerConnection hw) a - case r of - Left err -> hwlog hw err >> return (-1) - Right n -> return n - -withIgnore :: Hworker s t -> R.Redis (Either R.Reply a) -> IO () -withIgnore hw a = - do r <- R.runRedis (hworkerConnection hw) a - case r of - Left err -> hwlog hw err - Right _ -> return () - - -withList' hw a f = - do r <- a - case r of - Left err -> liftIO $ hwlog hw err - Right [] -> return () - Right xs -> f xs - -withInt' hw a = - do r <- a - case r of - Left err -> hwlog hw err >> return (-1) - Right n -> return n readMaybe :: Read a => ByteString -> Maybe a readMaybe = diff --git a/test/Spec.hs b/test/Spec.hs index d4958b5..cc75963 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,522 +1,576 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Concurrent (forkIO, killThread, threadDelay) -import Control.Concurrent.MVar (MVar, modifyMVarMasked_, newMVar, - readMVar, takeMVar) -import Control.Monad (replicateM_) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Text as T -import GHC.Generics (Generic) -import System.Hworker -import System.IO + +-------------------------------------------------------------------------------- +import Control.Concurrent ( forkIO, killThread, threadDelay ) +import Control.Concurrent.MVar ( MVar, modifyMVarMasked_, newMVar + , readMVar, takeMVar + ) +import Control.Monad ( replicateM_ ) +import Data.Aeson ( FromJSON, ToJSON ) +import Data.Text ( Text ) +import qualified Data.Text as T +import GHC.Generics ( Generic) +import System.IO ( stdout, hFlush ) import Test.Hspec -import Test.Hspec.Contrib.HUnit -import Test.HUnit +import Test.HUnit ( assertEqual ) +-------------------------------------------------------------------------------- +import System.Hworker +-------------------------------------------------------------------------------- + + + +main :: IO () +main = hspec $ do + describe "Simple" $ do + it "should run and increment counter" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + queue hworker SimpleJob + threadDelay 30000 + killThread wthread + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 1 after job runs" 1 v + + it "queueing 2 jobs should increment twice" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-2" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + queue hworker SimpleJob + queue hworker SimpleJob + threadDelay 40000 + killThread wthread + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 2 after 2 jobs run" 2 v + + it "queueing 1000 jobs should increment 1000" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-3" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + replicateM_ 1000 (queue hworker SimpleJob) + threadDelay 2000000 + killThread wthread + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 1000 after 1000 job runs" 1000 v + + it "should work with multiple workers" $ do + -- NOTE(dbp 2015-07-12): This probably won't run faster, because + -- they are all blocking on the MVar, but that's not the point. + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-4" (SimpleState mvar)) + wthread1 <- forkIO (worker hworker) + wthread2 <- forkIO (worker hworker) + wthread3 <- forkIO (worker hworker) + wthread4 <- forkIO (worker hworker) + replicateM_ 1000 (queue hworker SimpleJob) + threadDelay 1000000 + killThread wthread1 + killThread wthread2 + killThread wthread3 + killThread wthread4 + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 1000 after 1000 job runs" 1000 v + + describe "Exceptions" $ do + it "should be able to have exceptions thrown in jobs and retry the job" $ do + mvar <- newMVar 0 + hworker <- + createWith + (conf "exworker-1" (ExState mvar)) + { hwconfigExceptionBehavior = RetryOnException } + wthread <- forkIO (worker hworker) + queue hworker ExJob + threadDelay 40000 + killThread wthread + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 2, since the first run failed" 2 v + + it "should not retry if mode is FailOnException" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "exworker-2" (ExState mvar)) + wthread <- forkIO (worker hworker) + queue hworker ExJob + threadDelay 30000 + killThread wthread + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 1, since failing run wasn't retried" 1 v + + describe "Retry" $ do + it "should be able to return Retry and get run again" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "retryworker-1" (RetryState mvar)) + wthread <- forkIO (worker hworker) + queue hworker RetryJob + threadDelay 50000 + killThread wthread + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 2, since it got retried" 2 v + + describe "Fail" $ do + it "should not retry a job that Fails" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "failworker-1" (FailState mvar)) + wthread <- forkIO (worker hworker) + queue hworker FailJob + threadDelay 30000 + killThread wthread + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 1, since failing run wasn't retried" 1 v + + it "should put a failed job into the failed queue" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "failworker-2" (FailState mvar)) + wthread <- forkIO (worker hworker) + queue hworker FailJob + threadDelay 30000 + killThread wthread + jobs <- failed hworker + destroy hworker + assertEqual "Should have failed job" [FailJob] jobs + + it "should only store failedQueueSize failed jobs" $ do + mvar <- newMVar 0 + hworker <- + createWith + (conf "failworker-3" (AlwaysFailState mvar)) + { hwconfigFailedQueueSize = 2 } + wthread <- forkIO (worker hworker) + queue hworker AlwaysFailJob + queue hworker AlwaysFailJob + queue hworker AlwaysFailJob + queue hworker AlwaysFailJob + threadDelay 100000 + killThread wthread + jobs <- failed hworker + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 4, since all jobs were run" 4 v + assertEqual "Should only have stored 2" [AlwaysFailJob,AlwaysFailJob] jobs + + describe "Batch" $ do + it "should set up a batch job" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + summary <- startBatch hworker Nothing >>= expectBatchSummary hworker + batchSummaryQueued summary `shouldBe` 0 + batchSummaryCompleted summary `shouldBe` 0 + batchSummarySuccesses summary `shouldBe` 0 + batchSummaryFailures summary `shouldBe` 0 + batchSummaryRetries summary `shouldBe` 0 + batchSummaryStatus summary `shouldBe` BatchQueueing + destroy hworker + + it "should expire batch job" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- startBatch hworker (Just 1) + batchSummary hworker batch >>= shouldNotBe Nothing + threadDelay 2000000 + batchSummary hworker batch >>= shouldBe Nothing + destroy hworker + + it "should increment batch total after queueing a batch job" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- startBatch hworker Nothing + queueBatched hworker SimpleJob batch + summary <- expectBatchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + destroy hworker + + it "should not enqueue job for completed batch" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + batch <- startBatch hworker Nothing + queueBatched hworker SimpleJob batch + threadDelay 30000 + stopBatchQueueing hworker batch + queueBatched hworker SimpleJob batch >>= shouldBe False + threadDelay 30000 + summary <- expectBatchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + killThread wthread + destroy hworker + + it "should increment success and completed after completing a successful batch job" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + batch <- startBatch hworker Nothing + queueBatched hworker SimpleJob batch + threadDelay 30000 + summary <- expectBatchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + batchSummaryFailures summary `shouldBe` 0 + batchSummarySuccesses summary `shouldBe` 1 + batchSummaryCompleted summary `shouldBe` 1 + batchSummaryStatus summary `shouldBe` BatchQueueing + killThread wthread + destroy hworker + + it "should increment failure and completed after completing a failed batch job" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "failworker-1" (FailState mvar)) + wthread <- forkIO (worker hworker) + batch <- startBatch hworker Nothing + queueBatched hworker FailJob batch + threadDelay 30000 + summary <- expectBatchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + batchSummaryFailures summary `shouldBe` 1 + batchSummarySuccesses summary `shouldBe` 0 + batchSummaryCompleted summary `shouldBe` 1 + batchSummaryStatus summary `shouldBe` BatchQueueing + killThread wthread + destroy hworker + + it "should change job status to processing when batch is set to stop queueing" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- startBatch hworker Nothing + queueBatched hworker SimpleJob batch + stopBatchQueueing hworker batch + summary <- expectBatchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + batchSummaryStatus summary `shouldBe` BatchProcessing + destroy hworker + + it "should change job status to finished when batch is set to stop queueing and jobs are already run" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + batch <- startBatch hworker Nothing + queueBatched hworker SimpleJob batch + threadDelay 30000 + stopBatchQueueing hworker batch + Just batch <- batchSummary hworker batch + batchSummaryQueued batch `shouldBe` 1 + batchSummaryStatus batch `shouldBe` BatchFinished + killThread wthread + destroy hworker + + it "should change job status finished when last processed" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + batch <- startBatch hworker Nothing + queueBatched hworker SimpleJob batch + stopBatchQueueing hworker batch + threadDelay 30000 + summary <- expectBatchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1 + batchSummaryStatus summary `shouldBe` BatchFinished + killThread wthread + destroy hworker + + it "queueing 1000 jobs should increment 1000" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-3" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + batch <- startBatch hworker Nothing + replicateM_ 1000 (queueBatched hworker SimpleJob batch) + stopBatchQueueing hworker batch + threadDelay 2000000 + v <- takeMVar mvar + v `shouldBe` 1000 + summary <- expectBatchSummary hworker batch + batchSummaryQueued summary `shouldBe` 1000 + batchSummaryFailures summary `shouldBe` 0 + batchSummarySuccesses summary `shouldBe` 1000 + batchSummaryCompleted summary `shouldBe` 1000 + batchSummaryStatus summary `shouldBe` BatchFinished + killThread wthread + destroy hworker + + describe "Monitor" $ do + it "should add job back after timeout" $ do + -- NOTE(dbp 2015-07-12): The timing on this test is somewhat + -- tricky. We want to get the job started with one worker, + -- then kill the worker, then start a new worker, and have + -- the monitor put the job back in the queue and have the + -- second worker finish it. It's important that the job + -- takes less time to complete than the timeout for the + -- monitor, or else it'll queue it forever. + -- + -- The timeout is 5 seconds. The job takes 1 seconds to run. + -- The worker is killed after 0.5 seconds, which should be + -- plenty of time for it to have started the job. Then after + -- the second worker is started, we wait 10 seconds, which + -- should be plenty; we expect the total run to take around 11. + mvar <- newMVar 0 + hworker <- + createWith + (conf "timedworker-1" (TimedState mvar)) { hwconfigTimeout = 5 } + wthread1 <- forkIO (worker hworker) + mthread <- forkIO (monitor hworker) + queue hworker (TimedJob 1000000) + threadDelay 500000 + killThread wthread1 + wthread2 <- forkIO (worker hworker) + threadDelay 10000000 + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 1, since first failed" 1 v + + it "should add back multiple jobs after timeout" $ do + -- NOTE(dbp 2015-07-23): Similar to the above test, but we + -- have multiple jobs started, multiple workers killed. + -- then one worker will finish both interrupted jobs. + mvar <- newMVar 0 + hworker <- + createWith + (conf "timedworker-2" (TimedState mvar)) { hwconfigTimeout = 5 } + wthread1 <- forkIO (worker hworker) + wthread2 <- forkIO (worker hworker) + mthread <- forkIO (monitor hworker) + queue hworker (TimedJob 1000000) + queue hworker (TimedJob 1000000) + threadDelay 500000 + killThread wthread1 + killThread wthread2 + wthread3 <- forkIO (worker hworker) + threadDelay 10000000 + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 2, since first 2 failed" 2 v + + it "should work with multiple monitors" $ do + mvar <- newMVar 0 + hworker <- + createWith + (conf "timedworker-3" (TimedState mvar)) { hwconfigTimeout = 5 } + wthread1 <- forkIO (worker hworker) + wthread2 <- forkIO (worker hworker) + -- NOTE(dbp 2015-07-24): This might seem silly, but it + -- was actually sufficient to expose a race condition. + mthread1 <- forkIO (monitor hworker) + mthread2 <- forkIO (monitor hworker) + mthread3 <- forkIO (monitor hworker) + mthread4 <- forkIO (monitor hworker) + mthread5 <- forkIO (monitor hworker) + mthread6 <- forkIO (monitor hworker) + queue hworker (TimedJob 1000000) + queue hworker (TimedJob 1000000) + threadDelay 500000 + killThread wthread1 + killThread wthread2 + wthread3 <- forkIO (worker hworker) + threadDelay 30000000 + destroy hworker + v <- takeMVar mvar + assertEqual "State should be 2, since first 2 failed" 2 v + -- NOTE(dbp 2015-07-24): It would be really great to have a + -- test that went after a race between the retry logic and + -- the monitors (ie, assume that the job completed with + -- Retry, and it happened to complete right at the timeout + -- period). I'm not sure if I could get that sort of + -- precision without adding other delay mechanisms, or + -- something to make it more deterministic. + + describe "Broken jobs" $ + it "should store broken jobs" $ do + -- NOTE(dbp 2015-08-09): The more common way this could + -- happen is that you change your serialization format. But + -- we can abuse this by creating two different workers + -- pointing to the same queue, and submit jobs in one, try + -- to run them in another, where the types are different. + mvar <- newMVar 0 + hworker1 <- createWith (conf "broken-1" (TimedState mvar)) { hwconfigTimeout = 5 } + hworker2 <- createWith (conf "broken-1" (SimpleState mvar)) { hwconfigTimeout = 5 } + wthread <- forkIO (worker hworker1) + queue hworker2 SimpleJob + threadDelay 100000 + jobs <- broken hworker2 + killThread wthread + destroy hworker1 + v <- takeMVar mvar + assertEqual "State should be 0, as nothing should have happened" 0 v + assertEqual "Should be one broken job, as serialization is wrong" 1 (length jobs) + + describe "Dump jobs" $ do + it "should return the job that was queued" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "dump-1" (SimpleState mvar)) { hwconfigTimeout = 5 } + queue hworker SimpleJob + res <- jobs hworker + destroy hworker + assertEqual "Should be [SimpleJob]" [SimpleJob] res + + it "should return jobs in order (most recently added at front; worker pulls from back)" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "dump-2" (TimedState mvar)) { hwconfigTimeout = 5 } + queue hworker (TimedJob 1) + queue hworker (TimedJob 2) + res <- jobs hworker + destroy hworker + assertEqual "Should by [TimedJob 2, TimedJob 1]" [TimedJob 2, TimedJob 1] res + + describe "Large jobs" $ do + it "should be able to deal with lots of large jobs" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "big-1" (BigState mvar)) + wthread1 <- forkIO (worker hworker) + wthread2 <- forkIO (worker hworker) + wthread3 <- forkIO (worker hworker) + wthread4 <- forkIO (worker hworker) + let content = T.intercalate "\n" (take 1000 (repeat "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) + replicateM_ 5000 (queue hworker (BigJob content)) + threadDelay 10000000 + killThread wthread1 + killThread wthread2 + killThread wthread3 + killThread wthread4 + destroy hworker + v <- takeMVar mvar + assertEqual "Should have processed 5000" 5000 v + + +data SimpleJob = + SimpleJob deriving (Generic, Show, Eq) -data SimpleJob = SimpleJob deriving (Generic, Show, Eq) -data SimpleState = SimpleState { unSimpleState :: MVar Int } instance ToJSON SimpleJob instance FromJSON SimpleJob + +newtype SimpleState = + SimpleState { unSimpleState :: MVar Int } + instance Job SimpleState SimpleJob where job (SimpleState mvar) SimpleJob = - do modifyMVarMasked_ mvar (return . (+1)) - return Success + modifyMVarMasked_ mvar (return . (+1)) >> return Success + + +data ExJob = + ExJob deriving (Generic, Show) -data ExJob = ExJob deriving (Generic, Show) -data ExState = ExState { unExState :: MVar Int } instance ToJSON ExJob instance FromJSON ExJob + +newtype ExState = + ExState { unExState :: MVar Int } + instance Job ExState ExJob where - job (ExState mvar) ExJob = - do modifyMVarMasked_ mvar (return . (+1)) - v <- readMVar mvar - if v > 1 - then return Success - else error "ExJob: failing badly!" - -data RetryJob = RetryJob deriving (Generic, Show) -data RetryState = RetryState { unRetryState :: MVar Int } + job (ExState mvar) ExJob = do + modifyMVarMasked_ mvar (return . (+1)) + v <- readMVar mvar + if v > 1 + then return Success + else error "ExJob: failing badly!" + + +data RetryJob = + RetryJob deriving (Generic, Show) + instance ToJSON RetryJob instance FromJSON RetryJob + +newtype RetryState = + RetryState { unRetryState :: MVar Int } + instance Job RetryState RetryJob where - job (RetryState mvar) RetryJob = - do modifyMVarMasked_ mvar (return . (+1)) - v <- readMVar mvar - if v > 1 - then return Success - else return (Retry "RetryJob retries") - -data FailJob = FailJob deriving (Eq, Generic, Show) -data FailState = FailState { unFailState :: MVar Int } + job (RetryState mvar) RetryJob = do + modifyMVarMasked_ mvar (return . (+1)) + v <- readMVar mvar + if v > 1 + then return Success + else return (Retry "RetryJob retries") + + +data FailJob = + FailJob deriving (Eq, Generic, Show) + instance ToJSON FailJob instance FromJSON FailJob + +newtype FailState = + FailState { unFailState :: MVar Int } + instance Job FailState FailJob where - job (FailState mvar) FailJob = - do modifyMVarMasked_ mvar (return . (+1)) - v <- readMVar mvar - if v > 1 - then return Success - else return (Failure "FailJob fails") - -data AlwaysFailJob = AlwaysFailJob deriving (Eq, Generic, Show) -data AlwaysFailState = AlwaysFailState { unAlwaysFailState :: MVar Int } + job (FailState mvar) FailJob = do + modifyMVarMasked_ mvar (return . (+1)) + v <- readMVar mvar + if v > 1 + then return Success + else return (Failure "FailJob fails") + + +data AlwaysFailJob = + AlwaysFailJob deriving (Eq, Generic, Show) + instance ToJSON AlwaysFailJob instance FromJSON AlwaysFailJob + +newtype AlwaysFailState = + AlwaysFailState { unAlwaysFailState :: MVar Int } + instance Job AlwaysFailState AlwaysFailJob where - job (AlwaysFailState mvar) AlwaysFailJob = - do modifyMVarMasked_ mvar (return . (+1)) - return (Failure "AlwaysFailJob fails") + job (AlwaysFailState mvar) AlwaysFailJob = do + modifyMVarMasked_ mvar (return . (+1)) + return (Failure "AlwaysFailJob fails") + + +data TimedJob = + TimedJob Int deriving (Generic, Show, Eq) -data TimedJob = TimedJob Int deriving (Generic, Show, Eq) -data TimedState = TimedState { unTimedState :: MVar Int } instance ToJSON TimedJob instance FromJSON TimedJob + +newtype TimedState = + TimedState { unTimedState :: MVar Int } + instance Job TimedState TimedJob where - job (TimedState mvar) (TimedJob delay) = - do threadDelay delay - modifyMVarMasked_ mvar (return . (+1)) - return Success + job (TimedState mvar) (TimedJob delay) = do + threadDelay delay + modifyMVarMasked_ mvar (return . (+1)) + return Success + + +data BigJob = + BigJob Text deriving (Generic, Show, Eq) -data BigJob = BigJob T.Text deriving (Generic, Show, Eq) -data BigState = BigState { unBigState :: MVar Int } instance ToJSON BigJob instance FromJSON BigJob + +newtype BigState = + BigState { unBigState :: MVar Int } + instance Job BigState BigJob where job (BigState mvar) (BigJob _) = - do modifyMVarMasked_ mvar (return . (+1)) - return Success + modifyMVarMasked_ mvar (return . (+1)) >> return Success -nullLogger :: Show a => a -> IO () -nullLogger = const (return ()) -print' :: Show a => a -> IO () -print' a = do print a - hFlush stdout +conf :: Text -> s -> HworkerConfig s +conf n s = + (defaultHworkerConfig n s) + { hwconfigLogger = const (return ()) + , hwconfigExceptionBehavior = FailOnException + , hwconfigTimeout = 4 + } -conf n s = (defaultHworkerConfig n s) { - hwconfigLogger = nullLogger - , hwconfigExceptionBehavior = FailOnException - , hwconfigTimeout = 4 - } -main :: IO () -main = hspec $ - do describe "Simple" $ - do it "should run and increment counter" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" - (SimpleState mvar)) - wthread <- forkIO (worker hworker) - queue hworker SimpleJob - threadDelay 30000 - killThread wthread - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 1 after job runs" 1 v - it "queueing 2 jobs should increment twice" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-2" - (SimpleState mvar)) - wthread <- forkIO (worker hworker) - queue hworker SimpleJob - queue hworker SimpleJob - threadDelay 40000 - killThread wthread - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 2 after 2 jobs run" 2 v - it "queueing 1000 jobs should increment 1000" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-3" - (SimpleState mvar)) - wthread <- forkIO (worker hworker) - replicateM_ 1000 (queue hworker SimpleJob) - threadDelay 2000000 - killThread wthread - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 1000 after 1000 job runs" 1000 v - it "should work with multiple workers" $ - -- NOTE(dbp 2015-07-12): This probably won't run faster, because - -- they are all blocking on the MVar, but that's not the point. - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-4" - (SimpleState mvar)) - wthread1 <- forkIO (worker hworker) - wthread2 <- forkIO (worker hworker) - wthread3 <- forkIO (worker hworker) - wthread4 <- forkIO (worker hworker) - replicateM_ 1000 (queue hworker SimpleJob) - threadDelay 1000000 - killThread wthread1 - killThread wthread2 - killThread wthread3 - killThread wthread4 - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 1000 after 1000 job runs" 1000 v - - describe "Exceptions" $ - do it "should be able to have exceptions thrown in jobs and retry the job" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "exworker-1" - (ExState mvar)) { - hwconfigExceptionBehavior = - RetryOnException - } - wthread <- forkIO (worker hworker) - queue hworker ExJob - threadDelay 40000 - killThread wthread - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 2, since the first run failed" 2 v - it "should not retry if mode is FailOnException" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "exworker-2" - (ExState mvar)) - wthread <- forkIO (worker hworker) - queue hworker ExJob - threadDelay 30000 - killThread wthread - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 1, since failing run wasn't retried" 1 v - - describe "Retry" $ - do it "should be able to return Retry and get run again" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "retryworker-1" - (RetryState mvar)) - wthread <- forkIO (worker hworker) - queue hworker RetryJob - threadDelay 50000 - killThread wthread - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 2, since it got retried" 2 v - - describe "Fail" $ - do it "should not retry a job that Fails" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "failworker-1" - (FailState mvar)) - wthread <- forkIO (worker hworker) - queue hworker FailJob - threadDelay 30000 - killThread wthread - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 1, since failing run wasn't retried" 1 v - it "should put a failed job into the failed queue" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "failworker-2" - (FailState mvar)) - wthread <- forkIO (worker hworker) - queue hworker FailJob - threadDelay 30000 - killThread wthread - jobs <- failed hworker - destroy hworker - assertEqual "Should have failed job" [FailJob] jobs - it "should only store failedQueueSize failed jobs" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "failworker-3" - (AlwaysFailState mvar)) { - hwconfigFailedQueueSize = 2 - } - wthread <- forkIO (worker hworker) - queue hworker AlwaysFailJob - queue hworker AlwaysFailJob - queue hworker AlwaysFailJob - queue hworker AlwaysFailJob - threadDelay 100000 - killThread wthread - jobs <- failed hworker - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 4, since all jobs were run" 4 v - assertEqual "Should only have stored 2" - [AlwaysFailJob,AlwaysFailJob] jobs - - describe "Batch" $ - do it "should set up a batch job" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - Just batch <- initBatch hworker Nothing - Just summary <- batchSummary hworker batch - batchSummaryQueued summary `shouldBe` 0 - batchSummaryCompleted summary `shouldBe` 0 - batchSummarySuccesses summary `shouldBe` 0 - batchSummaryFailures summary `shouldBe` 0 - batchSummaryRetries summary `shouldBe` 0 - batchSummaryStatus summary `shouldBe` BatchQueueing - destroy hworker - it "should expire batch job" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - Just batch <- initBatch hworker (Just 1) - batchSummary hworker batch >>= shouldNotBe Nothing - threadDelay 2000000 - batchSummary hworker batch >>= shouldBe Nothing - destroy hworker - it "should increment batch total after queueing a batch job" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - Just batch <- initBatch hworker Nothing - queueBatched hworker SimpleJob batch - Just summary <- batchSummary hworker batch - batchSummaryQueued summary `shouldBe` 1 - destroy hworker - it "should not enqueue job for completed batch" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - wthread <- forkIO (worker hworker) - Just batch <- initBatch hworker Nothing - queueBatched hworker SimpleJob batch - threadDelay 30000 - stopBatchQueueing hworker batch - queueBatched hworker SimpleJob batch >>= shouldBe False - threadDelay 30000 - Just summary <- batchSummary hworker batch - batchSummaryQueued summary `shouldBe` 1 - killThread wthread - destroy hworker - it "should increment success and completed after completing a successful batch job" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - wthread <- forkIO (worker hworker) - Just batch <- initBatch hworker Nothing - queueBatched hworker SimpleJob batch - threadDelay 30000 - Just summary <- batchSummary hworker batch - batchSummaryQueued summary `shouldBe` 1 - batchSummaryFailures summary `shouldBe` 0 - batchSummarySuccesses summary `shouldBe` 1 - batchSummaryCompleted summary `shouldBe` 1 - batchSummaryStatus summary `shouldBe` BatchQueueing - killThread wthread - destroy hworker - it "should increment failure and completed after completing a failed batch job" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "failworker-1" (FailState mvar)) - wthread <- forkIO (worker hworker) - Just batch <- initBatch hworker Nothing - queueBatched hworker FailJob batch - threadDelay 30000 - Just summary <- batchSummary hworker batch - batchSummaryQueued summary `shouldBe` 1 - batchSummaryFailures summary `shouldBe` 1 - batchSummarySuccesses summary `shouldBe` 0 - batchSummaryCompleted summary `shouldBe` 1 - batchSummaryStatus summary `shouldBe` BatchQueueing - killThread wthread - destroy hworker - it "should change job status to processing when batch is set to stop queueing" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - Just batch <- initBatch hworker Nothing - queueBatched hworker SimpleJob batch - stopBatchQueueing hworker batch - Just summary <- batchSummary hworker batch - batchSummaryQueued summary `shouldBe` 1 - batchSummaryStatus summary `shouldBe` BatchProcessing - destroy hworker - it "should change job status to finished when batch is set to stop queueing and jobs are already run" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - wthread <- forkIO (worker hworker) - Just batch <- initBatch hworker Nothing - queueBatched hworker SimpleJob batch - threadDelay 30000 - stopBatchQueueing hworker batch - Just batch <- batchSummary hworker batch - batchSummaryQueued batch `shouldBe` 1 - batchSummaryStatus batch `shouldBe` BatchFinished - killThread wthread - destroy hworker - it "should change job status finished when last processed" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - wthread <- forkIO (worker hworker) - Just batch <- initBatch hworker Nothing - queueBatched hworker SimpleJob batch - stopBatchQueueing hworker batch - threadDelay 30000 - Just summary <- batchSummary hworker batch - batchSummaryQueued summary `shouldBe` 1 - batchSummaryStatus summary `shouldBe` BatchFinished - killThread wthread - destroy hworker - it "queueing 1000 jobs should increment 1000" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "simpleworker-3" (SimpleState mvar)) - wthread <- forkIO (worker hworker) - Just batch <- initBatch hworker Nothing - replicateM_ 1000 (queueBatched hworker SimpleJob batch) - stopBatchQueueing hworker batch - threadDelay 2000000 - v <- takeMVar mvar - v `shouldBe` 1000 - Just summary <- batchSummary hworker batch - batchSummaryQueued summary `shouldBe` 1000 - batchSummaryFailures summary `shouldBe` 0 - batchSummarySuccesses summary `shouldBe` 1000 - batchSummaryCompleted summary `shouldBe` 1000 - batchSummaryStatus summary `shouldBe` BatchFinished - killThread wthread - destroy hworker - - describe "Monitor" $ - do it "should add job back after timeout" $ - -- NOTE(dbp 2015-07-12): The timing on this test is somewhat - -- tricky. We want to get the job started with one worker, - -- then kill the worker, then start a new worker, and have - -- the monitor put the job back in the queue and have the - -- second worker finish it. It's important that the job - -- takes less time to complete than the timeout for the - -- monitor, or else it'll queue it forever. - -- - -- The timeout is 5 seconds. The job takes 1 seconds to run. - -- The worker is killed after 0.5 seconds, which should be - -- plenty of time for it to have started the job. Then after - -- the second worker is started, we wait 10 seconds, which - -- should be plenty; we expect the total run to take around 11. - do mvar <- newMVar 0 - hworker <- createWith (conf "timedworker-1" - (TimedState mvar)) { - hwconfigTimeout = 5 - } - wthread1 <- forkIO (worker hworker) - mthread <- forkIO (monitor hworker) - queue hworker (TimedJob 1000000) - threadDelay 500000 - killThread wthread1 - wthread2 <- forkIO (worker hworker) - threadDelay 10000000 - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 1, since first failed" 1 v - it "should add back multiple jobs after timeout" $ - -- NOTE(dbp 2015-07-23): Similar to the above test, but we - -- have multiple jobs started, multiple workers killed. - -- then one worker will finish both interrupted jobs. - do mvar <- newMVar 0 - hworker <- createWith (conf "timedworker-2" - (TimedState mvar)) { - hwconfigTimeout = 5 - } - wthread1 <- forkIO (worker hworker) - wthread2 <- forkIO (worker hworker) - mthread <- forkIO (monitor hworker) - queue hworker (TimedJob 1000000) - queue hworker (TimedJob 1000000) - threadDelay 500000 - killThread wthread1 - killThread wthread2 - wthread3 <- forkIO (worker hworker) - threadDelay 10000000 - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 2, since first 2 failed" 2 v - it "should work with multiple monitors" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "timedworker-3" - (TimedState mvar)) { - hwconfigTimeout = 5 - } - wthread1 <- forkIO (worker hworker) - wthread2 <- forkIO (worker hworker) - -- NOTE(dbp 2015-07-24): This might seem silly, but it - -- was actually sufficient to expose a race condition. - mthread1 <- forkIO (monitor hworker) - mthread2 <- forkIO (monitor hworker) - mthread3 <- forkIO (monitor hworker) - mthread4 <- forkIO (monitor hworker) - mthread5 <- forkIO (monitor hworker) - mthread6 <- forkIO (monitor hworker) - queue hworker (TimedJob 1000000) - queue hworker (TimedJob 1000000) - threadDelay 500000 - killThread wthread1 - killThread wthread2 - wthread3 <- forkIO (worker hworker) - threadDelay 30000000 - destroy hworker - v <- takeMVar mvar - assertEqual "State should be 2, since first 2 failed" 2 v - -- NOTE(dbp 2015-07-24): It would be really great to have a - -- test that went after a race between the retry logic and - -- the monitors (ie, assume that the job completed with - -- Retry, and it happened to complete right at the timeout - -- period). I'm not sure if I could get that sort of - -- precision without adding other delay mechanisms, or - -- something to make it more deterministic. - describe "Broken jobs" $ - it "should store broken jobs" $ - do -- NOTE(dbp 2015-08-09): The more common way this could - -- happen is that you change your serialization format. But - -- we can abuse this by creating two different workers - -- pointing to the same queue, and submit jobs in one, try - -- to run them in another, where the types are different. - mvar <- newMVar 0 - hworker1 <- createWith (conf "broken-1" - (TimedState mvar)) { - hwconfigTimeout = 5 - } - hworker2 <- createWith (conf "broken-1" - (SimpleState mvar)) { - hwconfigTimeout = 5 - } - wthread <- forkIO (worker hworker1) - queue hworker2 SimpleJob - threadDelay 100000 - jobs <- broken hworker2 - killThread wthread - destroy hworker1 - v <- takeMVar mvar - assertEqual "State should be 0, as nothing should have happened" 0 v - assertEqual "Should be one broken job, as serialization is wrong" 1 (length jobs) - describe "Dump jobs" $ do - it "should return the job that was queued" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "dump-1" - (SimpleState mvar)) { - hwconfigTimeout = 5 - } - queue hworker SimpleJob - res <- jobs hworker - destroy hworker - assertEqual "Should be [SimpleJob]" [SimpleJob] res - it "should return jobs in order (most recently added at front; worker pulls from back)" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "dump-2" - (TimedState mvar)) { - hwconfigTimeout = 5 - } - queue hworker (TimedJob 1) - queue hworker (TimedJob 2) - res <- jobs hworker - destroy hworker - assertEqual "Should by [TimedJob 2, TimedJob 1]" [TimedJob 2, TimedJob 1] res - describe "Large jobs" $ do - it "should be able to deal with lots of large jobs" $ - do mvar <- newMVar 0 - hworker <- createWith (conf "big-1" - (BigState mvar)) - wthread1 <- forkIO (worker hworker) - wthread2 <- forkIO (worker hworker) - wthread3 <- forkIO (worker hworker) - wthread4 <- forkIO (worker hworker) - let content = T.intercalate "\n" (take 1000 (repeat "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - replicateM_ 5000 (queue hworker (BigJob content)) - threadDelay 10000000 - killThread wthread1 - killThread wthread2 - killThread wthread3 - killThread wthread4 - destroy hworker - v <- takeMVar mvar - assertEqual "Should have processed 5000" 5000 v +startBatch :: Hworker s t -> Maybe Integer -> IO BatchId +startBatch hw expiration = + initBatch hw expiration >>= + \case + Just batch -> return batch + Nothing -> fail "Failed to create batch" + + +expectBatchSummary :: Hworker s t -> BatchId -> IO BatchSummary +expectBatchSummary hw batch = + batchSummary hw batch >>= + \case + Just summary -> return summary + Nothing -> fail "Failed to getch batch summary" From 803124ffd9ef9d8ba2c206bca4967d2722b611a9 Mon Sep 17 00:00:00 2001 From: remeike Date: Thu, 24 Nov 2022 14:36:20 -0600 Subject: [PATCH 17/36] Remove Aeson helper module --- example/src/Main.hs | 71 ++++++++++++++++++++++++--------------- hworker.cabal | 10 +++--- src/Data/Aeson/Helpers.hs | 20 ----------- src/System/Hworker.hs | 8 ++--- 4 files changed, 51 insertions(+), 58 deletions(-) delete mode 100644 src/Data/Aeson/Helpers.hs diff --git a/example/src/Main.hs b/example/src/Main.hs index de6c3e9..1c27766 100644 --- a/example/src/Main.hs +++ b/example/src/Main.hs @@ -1,37 +1,54 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) -import Control.Monad (forever) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Text as T -import GHC.Generics (Generic) + + +-------------------------------------------------------------------------------- +import Control.Concurrent ( forkIO, threadDelay ) +import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar ) +import Control.Monad ( forever ) +import Data.Aeson ( FromJSON, ToJSON ) +import GHC.Generics ( Generic ) +-------------------------------------------------------------------------------- import System.Hworker +-------------------------------------------------------------------------------- + + +data PrintJob + = PrintA + | PrintB + deriving (Generic, Show) + + +newtype State = + State (MVar Int) + -data PrintJob = PrintA | PrintB deriving (Generic, Show) -data State = State (MVar Int) instance ToJSON PrintJob instance FromJSON PrintJob -loopForever :: a -loopForever = loopForever instance Job State PrintJob where - job (State mvar) PrintA = - do v <- takeMVar mvar - if v == 0 - then do putMVar mvar 0 - putStrLn "A" >> return Success - else do putMVar mvar (v - 1) - error $ "Dying: " ++ show v - - job _ PrintB = putStrLn "B" >> return Success - -main = do mvar <- newMVar 3 - hworker <- create "printer" (State mvar) - forkIO (worker hworker) - forkIO (monitor hworker) - forkIO (forever $ queue hworker PrintA >> threadDelay 1000000) - forkIO (forever $ queue hworker PrintB >> threadDelay 500000) - forever (threadDelay 1000000) + job (State mvar) PrintA = do + v <- takeMVar mvar + if v == 0 + then do + putMVar mvar 0 + putStrLn "A" >> return Success + else do + putMVar mvar (v - 1) + error $ "Dying: " ++ show v + + job _ PrintB = + putStrLn "B" >> return Success + + +main :: IO () +main = do + mvar <- newMVar 3 + hworker <- create "printer" (State mvar) + _ <- forkIO (worker hworker) + _ <- forkIO (monitor hworker) + _ <- forkIO (forever $ queue hworker PrintA >> threadDelay 1000000) + _ <- forkIO (forever $ queue hworker PrintB >> threadDelay 500000) + forever (threadDelay 1000000) diff --git a/hworker.cabal b/hworker.cabal index 71cc63c..df5eb94 100644 --- a/hworker.cabal +++ b/hworker.cabal @@ -13,7 +13,6 @@ cabal-version: >=1.10 library exposed-modules: System.Hworker - other-modules: Data.Aeson.Helpers build-depends: base >= 4.7 && < 5 , aeson , hedis >= 0.6.5 @@ -28,11 +27,10 @@ library ghc-options: -Wall Test-Suite hworker-test - type: exitcode-stdio-1.0 - hs-source-dirs: src test - main-is: Spec.hs - other-modules: Data.Aeson.Helpers - , System.Hworker + type: exitcode-stdio-1.0 + hs-source-dirs: src test + main-is: Spec.hs + other-modules: System.Hworker build-depends: base >= 4.7 && < 5 , aeson , hedis >= 0.6.5 diff --git a/src/Data/Aeson/Helpers.hs b/src/Data/Aeson/Helpers.hs deleted file mode 100644 index f6a3a3b..0000000 --- a/src/Data/Aeson/Helpers.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Data.Aeson.Helpers where - -import Data.Aeson -import Data.Aeson.Parser (value) -import Data.Attoparsec.Lazy (Parser) -import qualified Data.Attoparsec.Lazy as L -import qualified Data.ByteString.Lazy as L - --- NOTE(dbp 2015-06-14): Taken from Data.Aeson.Parser.Internal -decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a -decodeWith p to s = - case L.parse p s of - L.Done _ v -> case to v of - Success a -> Just a - _ -> Nothing - _ -> Nothing -{-# INLINE decodeWith #-} - -decodeValue :: FromJSON t => L.ByteString -> Maybe t -decodeValue = decodeWith value fromJSON diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 4032e59..d6b8fa2 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -88,7 +88,6 @@ import Control.Monad ( forM_, forever, void, when ) import Control.Monad.Trans ( liftIO ) import Data.Aeson ( FromJSON, ToJSON, (.=), (.:) ) import qualified Data.Aeson as A -import Data.Aeson.Helpers ( decodeValue ) import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB @@ -539,7 +538,7 @@ worker hw = Right (Just t) -> do when (hworkerDebug hw) $ hwlog hw ("WORKER RUNNING" :: Text, t) - case decodeValue (LB.fromStrict t) of + case A.decodeStrict t of Nothing -> do hwlog hw ("BROKEN JOB" :: Text, t) now' <- getCurrentTime @@ -752,8 +751,7 @@ jobsFromQueue hw q = return [] Right xs -> - return - $ mapMaybe (fmap (\(JobRef _ _, x) -> x) . decodeValue . LB.fromStrict) xs + return $ mapMaybe (fmap (\(JobRef _ _, x) -> x) . A.decodeStrict) xs -- | Returns all pending jobs. @@ -897,7 +895,7 @@ decodeBatchSummary batch hm = parseTime :: ByteString -> UTCTime parseTime t = - case decodeValue (LB.fromStrict t) of + case A.decodeStrict t of Nothing -> error ("FAILED TO PARSE TIMESTAMP: " <> B8.unpack t) Just time -> time From a68f40b409376083dfec88dcabdf13d08386ac79 Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 25 Nov 2022 10:03:23 -0600 Subject: [PATCH 18/36] Add StrictData and fix couple typos --- src/System/Hworker.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index d6b8fa2..f725500 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} {-| @@ -50,9 +51,9 @@ module System.Hworker , Job(..) , Hworker , HworkerConfig(..) + , defaultHworkerConfig , ExceptionBehavior(..) , RedisConnection(..) - , defaultHworkerConfig , BatchId(..) , BatchStatus(..) , BatchSummary(..) @@ -142,7 +143,7 @@ instance FromJSON Result -- structure. The data structure (the `t` parameter) will be stored -- and copied a few times in Redis while in the lifecycle, so -- generally it is a good idea for it to be relatively small (and have --- it be able to look up data that it needs while the job in running). +-- it be able to look up data that it needs while the job is running). -- -- Finally, while deriving FromJSON and ToJSON instances automatically -- might seem like a good idea, you will most likely be better off @@ -150,7 +151,7 @@ instance FromJSON Result -- compatible if you change them, as any jobs that can't be -- deserialized will not be run (and will end up in the 'broken' -- queue). This will only happen if the queue is non-empty when you --- replce the running application version, but this is obviously +-- replace the running application version, but this is obviously -- possible and could be likely depending on your use. class (FromJSON t, ToJSON t, Show t) => Job s t | s -> t where From 5fe4115336076a8c91ab22dbebe1726c2c5fc9eb Mon Sep 17 00:00:00 2001 From: remeike Date: Mon, 5 Dec 2022 18:59:27 -0500 Subject: [PATCH 19/36] Make queuing batched jobs atomic --- hworker.cabal | 2 + src/System/Hworker.hs | 164 +++++++++++++++++++++++++++++++++--------- test/Spec.hs | 120 +++++++++++++++++++++++++++---- 3 files changed, 239 insertions(+), 47 deletions(-) diff --git a/hworker.cabal b/hworker.cabal index df5eb94..5c31e41 100644 --- a/hworker.cabal +++ b/hworker.cabal @@ -22,6 +22,7 @@ library , attoparsec , uuid >= 1.2.6 , mtl + , conduit hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -43,3 +44,4 @@ Test-Suite hworker-test , hspec-contrib , HUnit , mtl + , conduit diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index f725500..46c4464 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -49,7 +49,7 @@ module System.Hworker ( -- * Types Result(..) , Job(..) - , Hworker + , Hworker(..) , HworkerConfig(..) , defaultHworkerConfig , ExceptionBehavior(..) @@ -66,7 +66,8 @@ module System.Hworker , monitor -- * Queuing Jobs , queue - , queueBatched + , queueBatch + , streamBatch , initBatch , stopBatchQueueing -- * Inspecting Workers @@ -75,23 +76,27 @@ module System.Hworker , broken -- * Debugging Utilities , debugger + , batchCounter ) where -------------------------------------------------------------------------------- import Control.Arrow ( second) import Control.Concurrent ( threadDelay) import Control.Exception ( SomeException + , catch , catchJust , asyncExceptionFromException , AsyncException ) import Control.Monad ( forM_, forever, void, when ) -import Control.Monad.Trans ( liftIO ) +import Control.Monad.Trans ( liftIO, lift ) import Data.Aeson ( FromJSON, ToJSON, (.=), (.:) ) import qualified Data.Aeson as A import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB +import Data.Conduit ( ConduitT, (.|) ) +import qualified Data.Conduit as Conduit import Data.Either ( isRight ) import Data.Maybe ( isJust, mapMaybe, listToMaybe ) import Data.Text ( Text ) @@ -106,6 +111,8 @@ import Data.UUID ( UUID ) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import Database.Redis ( Redis + , RedisTx + , TxResult(..) , Connection , ConnectInfo , runRedis @@ -415,40 +422,112 @@ queue hw j = do return $ isRight result --- | Adds a job to the queue, but as part of a particular batch of jobs. --- Returns whether the operation succeeded. +-- | Adds jobs to the queue, but as part of a particular batch of jobs. +-- It takes the `BatchId` of the specified job, a `Bool` that when `True` +-- closes the batch to further queueing, and a list of jobs to be queued, and +-- returns whether the operation succeeded. The process is atomic +-- so that if a single job fails to queue then then none of the jobs +-- in the list will queue. + +queueBatch :: Job s t => Hworker s t -> BatchId -> Bool -> [t] -> IO Bool +queueBatch hw batch close js = + withBatchQueue hw batch $ runRedis (hworkerConnection hw) $ + R.multiExec $ do + mapM_ + ( \j -> do + jobId <- UUID.toText <$> liftIO UUID.nextRandom + let ref = JobRef jobId (Just batch) + _ <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] + + -- Do the counting outside of the transaction, hence runRedis here. + liftIO + $ runRedis (hworkerConnection hw) + $ R.hincrby (batchCounter hw batch) "queued" 1 + ) + js + + when close + $ void + $ R.hset (batchCounter hw batch) "status" "processing" + + return (pure ()) + + +-- | Like 'queueBatch', but instead of a list of jobs, it takes a conduit +-- that streams jobs in. + +streamBatch :: + Job s t => + Hworker s t -> BatchId -> Bool -> ConduitT () t RedisTx () -> IO Bool +streamBatch hw batch close producer = + let + sink = + Conduit.await >>= + \case + Nothing -> do + when close + $ void . lift + $ R.hset (batchCounter hw batch) "status" "processing" + return (pure ()) + + Just j -> do + jobId <- UUID.toText <$> liftIO UUID.nextRandom + let ref = JobRef jobId (Just batch) + _ <- lift $ R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] + + -- Do the counting outside of the transaction, hence runRedis here. + _ <- + liftIO + $ runRedis (hworkerConnection hw) + $ R.hincrby (batchCounter hw batch) "queued" 1 + + sink + in + withBatchQueue hw batch + $ runRedis (hworkerConnection hw) + $ R.multiExec (Conduit.runConduit (producer .| sink)) -queueBatched :: Job s t => Hworker s t -> t -> BatchId -> IO Bool -queueBatched hw j batch = do - jobId <- UUID.toText <$> UUID.nextRandom - runRedis (hworkerConnection hw) $ - R.hget (batchCounter hw batch) "status" >>= - \case - Left err -> do - liftIO (hwlog hw err) - return False - Right Nothing -> do - liftIO $ hwlog hw $ "BATCH NOT FOUND: " <> show batch - return False +withBatchQueue :: + Job s t => Hworker s t -> BatchId -> IO (TxResult ()) -> IO Bool +withBatchQueue hw batch process = + runRedis (hworkerConnection hw) (batchSummary' hw batch) >>= + \case + Nothing -> do + hwlog hw $ "BATCH NOT FOUND: " <> show batch + return False + + Just summary | batchSummaryStatus summary == BatchQueueing -> + catch + ( process >>= + \case + TxSuccess () -> + return True + + TxAborted -> do + hwlog hw ("TRANSACTION ABORTED" :: String) + runRedis (hworkerConnection hw) $ resetBatchSummary hw summary + return False + + TxError err -> do + hwlog hw err + runRedis (hworkerConnection hw) $ resetBatchSummary hw summary + return False + ) + ( \(e :: SomeException) -> do + hwlog hw $ show e + runRedis (hworkerConnection hw) (resetBatchSummary hw summary) + return False + ) - Right (Just status) | status == "queueing" -> - let - ref = - JobRef jobId (Just batch) - in do - result <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] - _ <- R.hincrby (batchCounter hw batch) "queued" 1 - return $ isRight result - - Right (Just _)-> do - liftIO $ hwlog hw $ - mconcat - [ "QUEUEING COMPLETED FOR BATCH: " - , show batch - , ". CANNOT ENQUEUE NEW JOBS." - ] - return False + Just _-> do + hwlog hw $ + mconcat + [ "QUEUEING COMPLETED FOR BATCH: " + , show batch + , ". CANNOT ENQUEUE NEW JOBS." + ] + return False -- | Prevents queueing new jobs to a batch. If the number of jobs completed equals @@ -904,3 +983,20 @@ parseTime t = readMaybe :: Read a => ByteString -> Maybe a readMaybe = fmap fst . listToMaybe . reads . B8.unpack + + +resetBatchSummary :: R.RedisCtx m n => Hworker s t -> BatchSummary -> m () +resetBatchSummary hw BatchSummary{..} = + let + encode = + B8.pack . show + in + void $ + R.hmset (batchCounter hw batchSummaryID) + [ ("queued", encode batchSummaryQueued) + , ("completed", encode batchSummaryCompleted) + , ("successes", encode batchSummarySuccesses) + , ("failures", encode batchSummaryFailures) + , ("retries", encode batchSummaryRetries) + , ("status", encodeBatchStatus batchSummaryStatus) + ] diff --git a/test/Spec.hs b/test/Spec.hs index cc75963..58958f2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,10 +9,24 @@ import Control.Concurrent ( forkIO, killThread, threadDelay ) import Control.Concurrent.MVar ( MVar, modifyMVarMasked_, newMVar , readMVar, takeMVar ) -import Control.Monad ( replicateM_ ) -import Data.Aeson ( FromJSON, ToJSON ) +import Control.Monad ( replicateM_, void ) +import Control.Monad.Trans ( lift, liftIO ) +import Data.Aeson ( FromJSON(..), ToJSON(..) ) +import Data.ByteString ( ByteString ) +import Data.Conduit ( ConduitT, (.|) ) +import qualified Data.Conduit as Conduit import Data.Text ( Text ) import qualified Data.Text as T +import Database.Redis ( Redis + , RedisTx + , TxResult(..) + , Connection + , ConnectInfo + , Queued + , Reply + , runRedis + ) +import qualified Database.Redis as Redis import GHC.Generics ( Generic) import System.IO ( stdout, hFlush ) import Test.Hspec @@ -163,7 +177,7 @@ main = hspec $ do it "should set up a batch job" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) - summary <- startBatch hworker Nothing >>= expectBatchSummary hworker + summary <- startBatch hworker Nothing >>= expectBatchSummary hworker batchSummaryQueued summary `shouldBe` 0 batchSummaryCompleted summary `shouldBe` 0 batchSummarySuccesses summary `shouldBe` 0 @@ -185,7 +199,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing - queueBatched hworker SimpleJob batch + queueBatch hworker batch False [SimpleJob] summary <- expectBatchSummary hworker batch batchSummaryQueued summary `shouldBe` 1 destroy hworker @@ -195,10 +209,10 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) batch <- startBatch hworker Nothing - queueBatched hworker SimpleJob batch + queueBatch hworker batch False [SimpleJob] threadDelay 30000 stopBatchQueueing hworker batch - queueBatched hworker SimpleJob batch >>= shouldBe False + queueBatch hworker batch False [SimpleJob] >>= shouldBe False threadDelay 30000 summary <- expectBatchSummary hworker batch batchSummaryQueued summary `shouldBe` 1 @@ -210,7 +224,7 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) batch <- startBatch hworker Nothing - queueBatched hworker SimpleJob batch + queueBatch hworker batch False [SimpleJob] threadDelay 30000 summary <- expectBatchSummary hworker batch batchSummaryQueued summary `shouldBe` 1 @@ -226,7 +240,7 @@ main = hspec $ do hworker <- createWith (conf "failworker-1" (FailState mvar)) wthread <- forkIO (worker hworker) batch <- startBatch hworker Nothing - queueBatched hworker FailJob batch + queueBatch hworker batch False [FailJob] threadDelay 30000 summary <- expectBatchSummary hworker batch batchSummaryQueued summary `shouldBe` 1 @@ -241,7 +255,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing - queueBatched hworker SimpleJob batch + queueBatch hworker batch False [SimpleJob] stopBatchQueueing hworker batch summary <- expectBatchSummary hworker batch batchSummaryQueued summary `shouldBe` 1 @@ -253,7 +267,7 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) batch <- startBatch hworker Nothing - queueBatched hworker SimpleJob batch + queueBatch hworker batch False [SimpleJob] threadDelay 30000 stopBatchQueueing hworker batch Just batch <- batchSummary hworker batch @@ -267,7 +281,7 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) batch <- startBatch hworker Nothing - queueBatched hworker SimpleJob batch + queueBatch hworker batch False [SimpleJob] stopBatchQueueing hworker batch threadDelay 30000 summary <- expectBatchSummary hworker batch @@ -281,7 +295,7 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-3" (SimpleState mvar)) wthread <- forkIO (worker hworker) batch <- startBatch hworker Nothing - replicateM_ 1000 (queueBatched hworker SimpleJob batch) + queueBatch hworker batch False (replicate 1000 SimpleJob) stopBatchQueueing hworker batch threadDelay 2000000 v <- takeMVar mvar @@ -295,6 +309,80 @@ main = hspec $ do killThread wthread destroy hworker + describe "Atomicity Tests" $ do + it "should queue all jobs" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- startBatch hworker Nothing + streamBatch hworker batch True + $ replicateM_ 50 + $ Conduit.yield SimpleJob + ls <- jobs hworker + length ls `shouldBe` 50 + summary <- expectBatchSummary hworker batch + batchSummaryQueued summary `shouldBe` 50 + batchSummaryStatus summary `shouldBe` BatchProcessing + destroy hworker + + it "should not queue jobs when producer throws error" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- startBatch hworker Nothing + streamBatch hworker batch True $ do + replicateM_ 20 $ Conduit.yield SimpleJob + error "BLOW UP!" + replicateM_ 20 $ Conduit.yield SimpleJob + ls <- jobs hworker + destroy hworker + length ls `shouldBe` 0 + + it "should not queue jobs on transaction error" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- startBatch hworker Nothing + streamBatch hworker batch True $ do + replicateM_ 20 $ Conduit.yield SimpleJob + _ <- lift $ Redis.lpush "" [] + replicateM_ 20 $ Conduit.yield SimpleJob + ls <- jobs hworker + destroy hworker + length ls `shouldBe` 0 + + it "should not queue jobs when transaction is aborted" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- startBatch hworker Nothing + _ <- runRedis (hworkerConnection hworker) $ Redis.watch [batchCounter hworker batch] + streamBatch hworker batch True $ replicateM_ 20 $ Conduit.yield SimpleJob + ls <- jobs hworker + destroy hworker + length ls `shouldBe` 0 + + it "should increment summary but then reset after failure" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + batch <- startBatch hworker Nothing + + thread <- + forkIO . void . streamBatch hworker batch True $ do + replicateM_ 5 $ + Conduit.yield SimpleJob >> liftIO (threadDelay 50000) + error "BLOW UP!" + replicateM_ 5 $ + Conduit.yield SimpleJob >> liftIO (threadDelay 50000) + + threadDelay 190000 + summary1 <- expectBatchSummary hworker batch + batchSummaryQueued summary1 `shouldBe` 4 + ls <- jobs hworker + length ls `shouldBe` 0 + threadDelay 100000 + summary2 <- expectBatchSummary hworker batch + batchSummaryQueued summary2 `shouldBe` 0 + killThread thread + destroy hworker + + describe "Monitor" $ do it "should add job back after timeout" $ do -- NOTE(dbp 2015-07-12): The timing on this test is somewhat @@ -321,8 +409,10 @@ main = hspec $ do killThread wthread1 wthread2 <- forkIO (worker hworker) threadDelay 10000000 - destroy hworker v <- takeMVar mvar + killThread wthread2 + killThread mthread + destroy hworker assertEqual "State should be 1, since first failed" 1 v it "should add back multiple jobs after timeout" $ do @@ -345,6 +435,8 @@ main = hspec $ do threadDelay 10000000 destroy hworker v <- takeMVar mvar + killThread wthread3 + killThread mthread assertEqual "State should be 2, since first 2 failed" 2 v it "should work with multiple monitors" $ do @@ -371,6 +463,8 @@ main = hspec $ do threadDelay 30000000 destroy hworker v <- takeMVar mvar + killThread wthread3 + mapM_ killThread [mthread1, mthread2, mthread3, mthread4, mthread5, mthread6] assertEqual "State should be 2, since first 2 failed" 2 v -- NOTE(dbp 2015-07-24): It would be really great to have a -- test that went after a race between the retry logic and From 4eb0b0ec1162abd98d0ad45a79fc245316360b5d Mon Sep 17 00:00:00 2001 From: remeike Date: Mon, 12 Dec 2022 16:37:36 -0500 Subject: [PATCH 20/36] Clear up warnings --- hworker.cabal | 2 ++ src/System/Hworker.hs | 6 +++--- test/Spec.hs | 46 ++++++++++++++++--------------------------- 3 files changed, 22 insertions(+), 32 deletions(-) diff --git a/hworker.cabal b/hworker.cabal index 5c31e41..5a35c71 100644 --- a/hworker.cabal +++ b/hworker.cabal @@ -32,6 +32,8 @@ Test-Suite hworker-test hs-source-dirs: src test main-is: Spec.hs other-modules: System.Hworker + ghc-options: -Wall + -fno-warn-unused-do-bind build-depends: base >= 4.7 && < 5 , aeson , hedis >= 0.6.5 diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 46c4464..fd91a17 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -95,7 +95,7 @@ import qualified Data.Aeson as A import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB -import Data.Conduit ( ConduitT, (.|) ) +import Data.Conduit ( ConduitT ) import qualified Data.Conduit as Conduit import Data.Either ( isRight ) import Data.Maybe ( isJust, mapMaybe, listToMaybe ) @@ -430,7 +430,7 @@ queue hw j = do -- in the list will queue. queueBatch :: Job s t => Hworker s t -> BatchId -> Bool -> [t] -> IO Bool -queueBatch hw batch close js = +queueBatch hw batch close js = withBatchQueue hw batch $ runRedis (hworkerConnection hw) $ R.multiExec $ do mapM_ @@ -485,7 +485,7 @@ streamBatch hw batch close producer = in withBatchQueue hw batch $ runRedis (hworkerConnection hw) - $ R.multiExec (Conduit.runConduit (producer .| sink)) + $ R.multiExec (Conduit.connect producer sink) withBatchQueue :: diff --git a/test/Spec.hs b/test/Spec.hs index 58958f2..1bc129a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,23 +12,11 @@ import Control.Concurrent.MVar ( MVar, modifyMVarMasked_, newMVar import Control.Monad ( replicateM_, void ) import Control.Monad.Trans ( lift, liftIO ) import Data.Aeson ( FromJSON(..), ToJSON(..) ) -import Data.ByteString ( ByteString ) -import Data.Conduit ( ConduitT, (.|) ) import qualified Data.Conduit as Conduit import Data.Text ( Text ) import qualified Data.Text as T -import Database.Redis ( Redis - , RedisTx - , TxResult(..) - , Connection - , ConnectInfo - , Queued - , Reply - , runRedis - ) import qualified Database.Redis as Redis import GHC.Generics ( Generic) -import System.IO ( stdout, hFlush ) import Test.Hspec import Test.HUnit ( assertEqual ) -------------------------------------------------------------------------------- @@ -150,9 +138,9 @@ main = hspec $ do queue hworker FailJob threadDelay 30000 killThread wthread - jobs <- failed hworker + failedJobs <- failed hworker destroy hworker - assertEqual "Should have failed job" [FailJob] jobs + assertEqual "Should have failed job" [FailJob] failedJobs it "should only store failedQueueSize failed jobs" $ do mvar <- newMVar 0 @@ -167,11 +155,11 @@ main = hspec $ do queue hworker AlwaysFailJob threadDelay 100000 killThread wthread - jobs <- failed hworker + failedJobs <- failed hworker destroy hworker v <- takeMVar mvar assertEqual "State should be 4, since all jobs were run" 4 v - assertEqual "Should only have stored 2" [AlwaysFailJob,AlwaysFailJob] jobs + assertEqual "Should only have stored 2" [AlwaysFailJob,AlwaysFailJob] failedJobs describe "Batch" $ do it "should set up a batch job" $ do @@ -270,9 +258,9 @@ main = hspec $ do queueBatch hworker batch False [SimpleJob] threadDelay 30000 stopBatchQueueing hworker batch - Just batch <- batchSummary hworker batch - batchSummaryQueued batch `shouldBe` 1 - batchSummaryStatus batch `shouldBe` BatchFinished + Just batch' <- batchSummary hworker batch + batchSummaryQueued batch' `shouldBe` 1 + batchSummaryStatus batch' `shouldBe` BatchFinished killThread wthread destroy hworker @@ -352,7 +340,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing - _ <- runRedis (hworkerConnection hworker) $ Redis.watch [batchCounter hworker batch] + _ <- Redis.runRedis (hworkerConnection hworker) $ Redis.watch [batchCounter hworker batch] streamBatch hworker batch True $ replicateM_ 20 $ Conduit.yield SimpleJob ls <- jobs hworker destroy hworker @@ -487,12 +475,12 @@ main = hspec $ do wthread <- forkIO (worker hworker1) queue hworker2 SimpleJob threadDelay 100000 - jobs <- broken hworker2 + brokenJobs <- broken hworker2 killThread wthread destroy hworker1 v <- takeMVar mvar assertEqual "State should be 0, as nothing should have happened" 0 v - assertEqual "Should be one broken job, as serialization is wrong" 1 (length jobs) + assertEqual "Should be one broken job, as serialization is wrong" 1 (length brokenJobs) describe "Dump jobs" $ do it "should return the job that was queued" $ do @@ -539,7 +527,7 @@ instance ToJSON SimpleJob instance FromJSON SimpleJob newtype SimpleState = - SimpleState { unSimpleState :: MVar Int } + SimpleState (MVar Int) instance Job SimpleState SimpleJob where job (SimpleState mvar) SimpleJob = @@ -553,7 +541,7 @@ instance ToJSON ExJob instance FromJSON ExJob newtype ExState = - ExState { unExState :: MVar Int } + ExState (MVar Int) instance Job ExState ExJob where job (ExState mvar) ExJob = do @@ -571,7 +559,7 @@ instance ToJSON RetryJob instance FromJSON RetryJob newtype RetryState = - RetryState { unRetryState :: MVar Int } + RetryState (MVar Int) instance Job RetryState RetryJob where job (RetryState mvar) RetryJob = do @@ -589,7 +577,7 @@ instance ToJSON FailJob instance FromJSON FailJob newtype FailState = - FailState { unFailState :: MVar Int } + FailState (MVar Int) instance Job FailState FailJob where job (FailState mvar) FailJob = do @@ -607,7 +595,7 @@ instance ToJSON AlwaysFailJob instance FromJSON AlwaysFailJob newtype AlwaysFailState = - AlwaysFailState { unAlwaysFailState :: MVar Int } + AlwaysFailState (MVar Int) instance Job AlwaysFailState AlwaysFailJob where job (AlwaysFailState mvar) AlwaysFailJob = do @@ -622,7 +610,7 @@ instance ToJSON TimedJob instance FromJSON TimedJob newtype TimedState = - TimedState { unTimedState :: MVar Int } + TimedState (MVar Int) instance Job TimedState TimedJob where job (TimedState mvar) (TimedJob delay) = do @@ -638,7 +626,7 @@ instance ToJSON BigJob instance FromJSON BigJob newtype BigState = - BigState { unBigState :: MVar Int } + BigState (MVar Int) instance Job BigState BigJob where job (BigState mvar) (BigJob _) = From e4e2b830acfcdddf3a9a670ffe7a098e7aa870ae Mon Sep 17 00:00:00 2001 From: remeike Date: Wed, 21 Dec 2022 15:06:16 -0500 Subject: [PATCH 21/36] Add batch completed function to config type --- src/System/Hworker.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index fd91a17..8403466 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -303,6 +303,7 @@ data HworkerConfig s = , hwconfigTimeout :: NominalDiffTime , hwconfigFailedQueueSize :: Int , hwconfigDebug :: Bool + , hwconfigBatchCompleted :: BatchSummary -> IO () } @@ -320,6 +321,7 @@ defaultHworkerConfig name state = , hwconfigTimeout = 120 , hwconfigFailedQueueSize = 1000 , hwconfigDebug = False + , hwconfigBatchCompleted = const (return ()) } @@ -357,7 +359,7 @@ createWith HworkerConfig{..} = do , hworkerJobTimeout = hwconfigTimeout , hworkerFailedQueueSize = hwconfigFailedQueueSize , hworkerDebug = hwconfigDebug - , hworkerBatchCompleted = const (return ()) + , hworkerBatchCompleted = hwconfigBatchCompleted } From 5d90eb23163ba92fdc33022faf8d440aca7b95fe Mon Sep 17 00:00:00 2001 From: remeike Date: Fri, 30 Dec 2022 11:43:02 -0500 Subject: [PATCH 22/36] Add scheduled and recurring jobs --- src/System/Hworker.hs | 115 +++++++++++++++++++++++++++++++++--------- test/Spec.hs | 50 ++++++++++++++++-- 2 files changed, 137 insertions(+), 28 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 8403466..f9cb6b2 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -66,6 +66,7 @@ module System.Hworker , monitor -- * Queuing Jobs , queue + , queueScheduled , queueBatch , streamBatch , initBatch @@ -90,7 +91,7 @@ import Control.Exception ( SomeException ) import Control.Monad ( forM_, forever, void, when ) import Control.Monad.Trans ( liftIO, lift ) -import Data.Aeson ( FromJSON, ToJSON, (.=), (.:) ) +import Data.Aeson ( FromJSON, ToJSON, (.=), (.:), (.:?) ) import qualified Data.Aeson as A import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as B8 @@ -103,10 +104,11 @@ import Data.Text ( Text ) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Clock ( NominalDiffTime - , UTCTime (..) + , UTCTime(..) , diffUTCTime , getCurrentTime ) +import qualified Data.Time.Clock.POSIX as Posix import Data.UUID ( UUID ) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID @@ -178,6 +180,9 @@ data ExceptionBehavior type JobId = Text +type RecurringId = Text + + -- | A unique identifier for grouping jobs together. newtype BatchId = @@ -218,12 +223,12 @@ data BatchSummary = data JobRef = - JobRef JobId (Maybe BatchId) + JobRef JobId (Maybe BatchId) (Maybe RecurringId) deriving (Eq, Show) instance ToJSON JobRef where - toJSON (JobRef j b) = A.object ["j" .= j, "b" .= b] + toJSON (JobRef j b r) = A.object ["j" .= j, "b" .= b, "r" .= r] instance FromJSON JobRef where @@ -231,8 +236,8 @@ instance FromJSON JobRef where -- can be removed eventually. Before `JobRef`, which is encoded as -- a JSON object, there was a just a `String` representing the job ID. - parseJSON (A.String j) = pure (JobRef j Nothing) - parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b") val + parseJSON (A.String j) = pure (JobRef j Nothing Nothing) + parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b" <*> o .:? "r") val hwlog :: Show a => Hworker s t -> a -> IO () @@ -254,6 +259,7 @@ data Hworker s t = , hworkerFailedQueueSize :: Int , hworkerDebug :: Bool , hworkerBatchCompleted :: BatchSummary -> IO () + , hworkerRecurringJob :: Hworker s t -> RecurringId -> Result -> IO () } @@ -293,7 +299,7 @@ data RedisConnection -- 'hwconfigFailedQueueSize' controls how many 'failed' jobs will be -- kept. It defaults to 1000. -data HworkerConfig s = +data HworkerConfig s t = HworkerConfig { hwconfigName :: Text , hwconfigState :: s @@ -304,13 +310,14 @@ data HworkerConfig s = , hwconfigFailedQueueSize :: Int , hwconfigDebug :: Bool , hwconfigBatchCompleted :: BatchSummary -> IO () + , hwconfigRecurringJob :: Hworker s t -> RecurringId -> Result -> IO () } -- | The default worker config - it needs a name and a state (as those -- will always be unique). -defaultHworkerConfig :: Text -> s -> HworkerConfig s +defaultHworkerConfig :: Text -> s -> HworkerConfig s t defaultHworkerConfig name state = HworkerConfig { hwconfigName = name @@ -322,6 +329,7 @@ defaultHworkerConfig name state = , hwconfigFailedQueueSize = 1000 , hwconfigDebug = False , hwconfigBatchCompleted = const (return ()) + , hwconfigRecurringJob = \_ _ _ -> return () } @@ -342,7 +350,7 @@ create name state = -- the queue to actually process jobs (and for it to retry ones that -- time-out). -createWith :: Job s t => HworkerConfig s -> IO (Hworker s t) +createWith :: Job s t => HworkerConfig s t -> IO (Hworker s t) createWith HworkerConfig{..} = do conn <- case hwconfigRedisConnectInfo of @@ -360,6 +368,7 @@ createWith HworkerConfig{..} = do , hworkerFailedQueueSize = hwconfigFailedQueueSize , hworkerDebug = hwconfigDebug , hworkerBatchCompleted = hwconfigBatchCompleted + , hworkerRecurringJob = hwconfigRecurringJob } @@ -385,6 +394,7 @@ destroy hw = , progressQueue hw , brokenQueue hw , failedQueue hw + , scheduleQueue hw ] @@ -408,6 +418,11 @@ failedQueue hw = "hworker-failed-" <> hworkerName hw +scheduleQueue :: Hworker s t -> ByteString +scheduleQueue hw = + "hworker-scheduled-" <> hworkerName hw + + batchCounter :: Hworker s t -> BatchId -> ByteString batchCounter hw (BatchId batch) = "hworker-batch-" <> hworkerName hw <> ":" <> UUID.toASCIIBytes batch @@ -420,7 +435,21 @@ queue hw j = do jobId <- UUID.toText <$> UUID.nextRandom result <- runRedis (hworkerConnection hw) - $ R.lpush (jobQueue hw) [LB.toStrict $ A.encode (JobRef jobId Nothing, j)] + $ R.lpush (jobQueue hw) + $ [LB.toStrict $ A.encode (JobRef jobId Nothing Nothing, j)] + return $ isRight result + + +-- | Adds a job to be added to the queue at the specified time. +-- Returns whether the operation succeeded. + +queueScheduled :: Job s t => Hworker s t -> t -> Maybe RecurringId -> UTCTime -> IO Bool +queueScheduled hw j recurring utc = do + jobId <- UUID.toText <$> UUID.nextRandom + result <- + runRedis (hworkerConnection hw) + $ R.zadd (scheduleQueue hw) + $ [(utcToDouble utc, LB.toStrict $ A.encode (JobRef jobId Nothing recurring, j))] return $ isRight result @@ -438,7 +467,7 @@ queueBatch hw batch close js = mapM_ ( \j -> do jobId <- UUID.toText <$> liftIO UUID.nextRandom - let ref = JobRef jobId (Just batch) + let ref = JobRef jobId (Just batch) Nothing _ <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] -- Do the counting outside of the transaction, hence runRedis here. @@ -474,7 +503,7 @@ streamBatch hw batch close producer = Just j -> do jobId <- UUID.toText <$> liftIO UUID.nextRandom - let ref = JobRef jobId (Just batch) + let ref = JobRef jobId (Just batch) Nothing _ <- lift $ R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] -- Do the counting outside of the transaction, hence runRedis here. @@ -569,6 +598,11 @@ worker hw = justRun = worker hw + handleRecurring maybeRecurring result = + case maybeRecurring of + Nothing -> return () + Just recurring -> (hworkerRecurringJob hw) hw recurring result + runJob action = do eitherResult <- catchJust @@ -637,11 +671,12 @@ worker hw = delayAndRun - Just (JobRef _ maybeBatch, j) -> do + Just (JobRef _ maybeBatch maybeRecurring, j) -> do runJob (job (hworkerState hw) j) >>= \case Success -> do when (hworkerDebug hw) $ hwlog hw ("JOB COMPLETE" :: Text, t) + handleRecurring maybeRecurring Success case maybeBatch of Nothing -> do @@ -687,12 +722,11 @@ worker hw = justRun ) - Retry msg -> do hwlog hw ("RETRY: " <> msg) case maybeBatch of - Nothing -> do + Nothing -> withNil hw $ R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ @@ -703,9 +737,7 @@ worker hw = [progressQueue hw, jobQueue hw] [t] - delayAndRun - - Just batch -> do + Just batch -> withNil hw $ R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ @@ -717,13 +749,14 @@ worker hw = [progressQueue hw, jobQueue hw, batchCounter hw batch] [t] - delayAndRun + handleRecurring maybeRecurring (Retry msg) + delayAndRun Failure msg -> do hwlog hw ("Failure: " <> msg) case maybeBatch of - Nothing -> do + Nothing -> withNil hw $ R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ @@ -735,9 +768,7 @@ worker hw = [progressQueue hw, failedQueue hw] [t, B8.pack (show (hworkerFailedQueueSize hw - 1))] - delayAndRun - - Just batch -> do + Just batch -> withMaybe hw ( R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ @@ -762,7 +793,9 @@ worker hw = forM_ (decodeBatchSummary batch hm) $ hworkerBatchCompleted hw ) - delayAndRun + + handleRecurring maybeRecurring (Failure msg) + delayAndRun -- | Start a monitor. Like 'worker', this is blocking, so should be @@ -776,6 +809,25 @@ monitor hw = forever $ do now <- getCurrentTime + runRedis (hworkerConnection hw) $ do + R.zcount (scheduleQueue hw) 0 (utcToDouble now) >>= + \case + Right n | n > 0 -> + withNil' hw $ + R.eval + "local jobs = redis.call('zrangebyscore', KEYS[1], '0', ARGV[1])\n\ + \redis.call('lpush', KEYS[2], unpack(jobs))\n\ + \redis.call('zremrangebyscore', KEYS[1], '0', ARGV[1])\n\ + \return nil" + [scheduleQueue hw, jobQueue hw] + [B8.pack (show (utcToDouble now))] + + Right _ -> + return () + + Left err -> + liftIO $ hwlog hw err + withList hw (R.hkeys (progressQueue hw)) $ \js -> forM_ js $ \j -> withMaybe hw (R.hget (progressQueue hw) j) $ @@ -833,7 +885,7 @@ jobsFromQueue hw q = return [] Right xs -> - return $ mapMaybe (fmap (\(JobRef _ _, x) -> x) . A.decodeStrict) xs + return $ mapMaybe (fmap (\(JobRef _ _ _, x) -> x) . A.decodeStrict) xs -- | Returns all pending jobs. @@ -941,6 +993,15 @@ withNil hw a = Right _ -> return () +withNil' :: + Show a => Hworker s t -> Redis (Either a (Maybe ByteString)) -> Redis () +withNil' hw a = + a >>= + \case + Left err -> liftIO $ hwlog hw err + Right _ -> return () + + withInt :: Hworker s t -> Redis (Either R.Reply Integer) -> IO Integer withInt hw a = runRedis (hworkerConnection hw) a >>= @@ -1002,3 +1063,7 @@ resetBatchSummary hw BatchSummary{..} = , ("retries", encode batchSummaryRetries) , ("status", encodeBatchStatus batchSummaryStatus) ] + + +utcToDouble :: UTCTime -> Double +utcToDouble = realToFrac . Posix.utcTimeToPOSIXSeconds diff --git a/test/Spec.hs b/test/Spec.hs index 1bc129a..ace9c5e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,12 +9,13 @@ import Control.Concurrent ( forkIO, killThread, threadDelay ) import Control.Concurrent.MVar ( MVar, modifyMVarMasked_, newMVar , readMVar, takeMVar ) -import Control.Monad ( replicateM_, void ) +import Control.Monad ( replicateM_, when, void ) import Control.Monad.Trans ( lift, liftIO ) import Data.Aeson ( FromJSON(..), ToJSON(..) ) import qualified Data.Conduit as Conduit import Data.Text ( Text ) import qualified Data.Text as T +import Data.Time import qualified Database.Redis as Redis import GHC.Generics ( Generic) import Test.Hspec @@ -22,7 +23,8 @@ import Test.HUnit ( assertEqual ) -------------------------------------------------------------------------------- import System.Hworker -------------------------------------------------------------------------------- - +import Data.UUID (toText) +import Data.UUID.V4 (nextRandom) main :: IO () @@ -462,6 +464,48 @@ main = hspec $ do -- precision without adding other delay mechanisms, or -- something to make it more deterministic. + describe "Scheduled and Recurring Jobs" $ do + it "should execute job at scheduled time" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + wthread <- forkIO (worker hworker) + mthread <- forkIO (monitor hworker) + time <- getCurrentTime + queueScheduled hworker SimpleJob Nothing (addUTCTime 1 time) + queueScheduled hworker SimpleJob Nothing (addUTCTime 2 time) + queueScheduled hworker SimpleJob Nothing (addUTCTime 4 time) + threadDelay 1500000 >> readMVar mvar >>= shouldBe 1 + threadDelay 1000000 >> readMVar mvar >>= shouldBe 2 + threadDelay 1000000 >> readMVar mvar >>= shouldBe 2 + threadDelay 1000000 >> readMVar mvar >>= shouldBe 3 + killThread wthread + killThread mthread + destroy hworker + + it "should execute a recurring job" $ do + recur <- toText <$> nextRandom + mvar <- newMVar 0 + hworker <- + createWith (conf "simpleworker-1" (SimpleState mvar)) + { hwconfigRecurringJob = + \hw r _ -> do + when (r == recur) $ do + time <- getCurrentTime + void $ queueScheduled hw SimpleJob (Just r) (addUTCTime 1.99 time) + } + + wthread <- forkIO (worker hworker) + mthread <- forkIO (monitor hworker) + time <- getCurrentTime + queueScheduled hworker SimpleJob (Just recur) (addUTCTime 2 time) + threadDelay 3000000 >> readMVar mvar >>= shouldBe 1 + threadDelay 2000000 >> readMVar mvar >>= shouldBe 2 + threadDelay 2000000 >> readMVar mvar >>= shouldBe 3 + threadDelay 2000000 >> readMVar mvar >>= shouldBe 4 + destroy hworker + killThread wthread + killThread mthread + describe "Broken jobs" $ it "should store broken jobs" $ do -- NOTE(dbp 2015-08-09): The more common way this could @@ -633,7 +677,7 @@ instance Job BigState BigJob where modifyMVarMasked_ mvar (return . (+1)) >> return Success -conf :: Text -> s -> HworkerConfig s +conf :: Text -> s -> HworkerConfig s t conf n s = (defaultHworkerConfig n s) { hwconfigLogger = const (return ()) From b3f28cff699ce34a316f8ae5256f8c093e3d5abc Mon Sep 17 00:00:00 2001 From: remeike Date: Mon, 2 Jan 2023 13:03:40 -0500 Subject: [PATCH 23/36] Remove recurring job code and modify job to take entire hworker as argument --- example/src/Main.hs | 5 +- src/System/Hworker.hs | 107 ++++++++++++++++++------------------------ test/Spec.hs | 59 +++++++++++++---------- 3 files changed, 82 insertions(+), 89 deletions(-) diff --git a/example/src/Main.hs b/example/src/Main.hs index 1c27766..18baeb9 100644 --- a/example/src/Main.hs +++ b/example/src/Main.hs @@ -29,7 +29,10 @@ instance FromJSON PrintJob instance Job State PrintJob where - job (State mvar) PrintA = do + job hw PrintA = + let + State mvar = hworkerState hw + in do v <- takeMVar mvar if v == 0 then do diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index f9cb6b2..95930ef 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -29,7 +29,7 @@ also good examples): > instance FromJSON PrintJob > > instance Job State PrintJob where -> job (State mvar) Print = +> job Hworker { hworkerState = State mvar } Print = > do v <- takeMVar mvar > putMVar mvar (v + 1) > putStrLn $ "A(" ++ show v ++ ")" @@ -61,7 +61,6 @@ module System.Hworker , create , createWith , destroy - , batchSummary , worker , monitor -- * Queuing Jobs @@ -75,6 +74,7 @@ module System.Hworker , jobs , failed , broken + , batchSummary -- * Debugging Utilities , debugger , batchCounter @@ -91,7 +91,7 @@ import Control.Exception ( SomeException ) import Control.Monad ( forM_, forever, void, when ) import Control.Monad.Trans ( liftIO, lift ) -import Data.Aeson ( FromJSON, ToJSON, (.=), (.:), (.:?) ) +import Data.Aeson ( FromJSON, ToJSON, (.=), (.:) ) import qualified Data.Aeson as A import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as B8 @@ -164,7 +164,7 @@ instance FromJSON Result -- possible and could be likely depending on your use. class (FromJSON t, ToJSON t, Show t) => Job s t | s -> t where - job :: s -> t -> IO Result + job :: Hworker s t -> t -> IO Result -- | What should happen when an unexpected exception is thrown in a @@ -180,9 +180,6 @@ data ExceptionBehavior type JobId = Text -type RecurringId = Text - - -- | A unique identifier for grouping jobs together. newtype BatchId = @@ -223,12 +220,12 @@ data BatchSummary = data JobRef = - JobRef JobId (Maybe BatchId) (Maybe RecurringId) + JobRef JobId (Maybe BatchId) deriving (Eq, Show) instance ToJSON JobRef where - toJSON (JobRef j b r) = A.object ["j" .= j, "b" .= b, "r" .= r] + toJSON (JobRef j b) = A.object ["j" .= j, "b" .= b] instance FromJSON JobRef where @@ -236,8 +233,8 @@ instance FromJSON JobRef where -- can be removed eventually. Before `JobRef`, which is encoded as -- a JSON object, there was a just a `String` representing the job ID. - parseJSON (A.String j) = pure (JobRef j Nothing Nothing) - parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b" <*> o .:? "r") val + parseJSON (A.String j) = pure (JobRef j Nothing) + parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b") val hwlog :: Show a => Hworker s t -> a -> IO () @@ -259,7 +256,6 @@ data Hworker s t = , hworkerFailedQueueSize :: Int , hworkerDebug :: Bool , hworkerBatchCompleted :: BatchSummary -> IO () - , hworkerRecurringJob :: Hworker s t -> RecurringId -> Result -> IO () } @@ -299,7 +295,7 @@ data RedisConnection -- 'hwconfigFailedQueueSize' controls how many 'failed' jobs will be -- kept. It defaults to 1000. -data HworkerConfig s t = +data HworkerConfig s = HworkerConfig { hwconfigName :: Text , hwconfigState :: s @@ -310,14 +306,13 @@ data HworkerConfig s t = , hwconfigFailedQueueSize :: Int , hwconfigDebug :: Bool , hwconfigBatchCompleted :: BatchSummary -> IO () - , hwconfigRecurringJob :: Hworker s t -> RecurringId -> Result -> IO () } -- | The default worker config - it needs a name and a state (as those -- will always be unique). -defaultHworkerConfig :: Text -> s -> HworkerConfig s t +defaultHworkerConfig :: Text -> s -> HworkerConfig s defaultHworkerConfig name state = HworkerConfig { hwconfigName = name @@ -329,7 +324,6 @@ defaultHworkerConfig name state = , hwconfigFailedQueueSize = 1000 , hwconfigDebug = False , hwconfigBatchCompleted = const (return ()) - , hwconfigRecurringJob = \_ _ _ -> return () } @@ -350,7 +344,7 @@ create name state = -- the queue to actually process jobs (and for it to retry ones that -- time-out). -createWith :: Job s t => HworkerConfig s t -> IO (Hworker s t) +createWith :: Job s t => HworkerConfig s -> IO (Hworker s t) createWith HworkerConfig{..} = do conn <- case hwconfigRedisConnectInfo of @@ -368,7 +362,6 @@ createWith HworkerConfig{..} = do , hworkerFailedQueueSize = hwconfigFailedQueueSize , hworkerDebug = hwconfigDebug , hworkerBatchCompleted = hwconfigBatchCompleted - , hworkerRecurringJob = hwconfigRecurringJob } @@ -436,20 +429,20 @@ queue hw j = do result <- runRedis (hworkerConnection hw) $ R.lpush (jobQueue hw) - $ [LB.toStrict $ A.encode (JobRef jobId Nothing Nothing, j)] + $ [LB.toStrict $ A.encode (JobRef jobId Nothing, j)] return $ isRight result -- | Adds a job to be added to the queue at the specified time. -- Returns whether the operation succeeded. -queueScheduled :: Job s t => Hworker s t -> t -> Maybe RecurringId -> UTCTime -> IO Bool -queueScheduled hw j recurring utc = do +queueScheduled :: Job s t => Hworker s t -> t -> UTCTime -> IO Bool +queueScheduled hw j utc = do jobId <- UUID.toText <$> UUID.nextRandom result <- runRedis (hworkerConnection hw) $ R.zadd (scheduleQueue hw) - $ [(utcToDouble utc, LB.toStrict $ A.encode (JobRef jobId Nothing recurring, j))] + $ [(utcToDouble utc, LB.toStrict $ A.encode (JobRef jobId Nothing, j))] return $ isRight result @@ -467,7 +460,7 @@ queueBatch hw batch close js = mapM_ ( \j -> do jobId <- UUID.toText <$> liftIO UUID.nextRandom - let ref = JobRef jobId (Just batch) Nothing + let ref = JobRef jobId (Just batch) _ <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] -- Do the counting outside of the transaction, hence runRedis here. @@ -503,7 +496,7 @@ streamBatch hw batch close producer = Just j -> do jobId <- UUID.toText <$> liftIO UUID.nextRandom - let ref = JobRef jobId (Just batch) Nothing + let ref = JobRef jobId (Just batch) _ <- lift $ R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] -- Do the counting outside of the transaction, hence runRedis here. @@ -598,11 +591,6 @@ worker hw = justRun = worker hw - handleRecurring maybeRecurring result = - case maybeRecurring of - Nothing -> return () - Just recurring -> (hworkerRecurringJob hw) hw recurring result - runJob action = do eitherResult <- catchJust @@ -659,7 +647,7 @@ worker hw = hwlog hw ("BROKEN JOB" :: Text, t) now' <- getCurrentTime - withNil hw $ + runWithNil hw $ R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ \if del == 1 then\n\ @@ -671,12 +659,11 @@ worker hw = delayAndRun - Just (JobRef _ maybeBatch maybeRecurring, j) -> do - runJob (job (hworkerState hw) j) >>= + Just (JobRef _ maybeBatch, j) -> do + runJob (job hw j) >>= \case Success -> do when (hworkerDebug hw) $ hwlog hw ("JOB COMPLETE" :: Text, t) - handleRecurring maybeRecurring Success case maybeBatch of Nothing -> do @@ -692,7 +679,7 @@ worker hw = delayAndRun Just batch -> - withMaybe hw + runWithMaybe hw ( R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ \if del == 1 then\n\ @@ -727,7 +714,7 @@ worker hw = case maybeBatch of Nothing -> - withNil hw $ + runWithNil hw $ R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ \if del == 1 then\n\ @@ -738,7 +725,7 @@ worker hw = [t] Just batch -> - withNil hw $ + runWithNil hw $ R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ \if del == 1 then\n\ @@ -749,7 +736,6 @@ worker hw = [progressQueue hw, jobQueue hw, batchCounter hw batch] [t] - handleRecurring maybeRecurring (Retry msg) delayAndRun Failure msg -> do @@ -757,7 +743,7 @@ worker hw = case maybeBatch of Nothing -> - withNil hw $ + runWithNil hw $ R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ \if del == 1 then\n\ @@ -769,7 +755,7 @@ worker hw = [t, B8.pack (show (hworkerFailedQueueSize hw - 1))] Just batch -> - withMaybe hw + runWithMaybe hw ( R.eval "local del = redis.call('hdel', KEYS[1], ARGV[1])\n\ \if del == 1 then\n\ @@ -794,14 +780,14 @@ worker hw = $ hworkerBatchCompleted hw ) - handleRecurring maybeRecurring (Failure msg) delayAndRun -- | Start a monitor. Like 'worker', this is blocking, so should be -- started in a thread. This is responsible for retrying jobs that -- time out (which can happen if the processing thread is killed, for --- example). You need to have at least one of these running to have +-- example) and for pushing scheduled jobs to the queue at the expected time. +-- You need to have at least one of these running to have -- the retry happen, but it is safe to have any number running. monitor :: Job s t => Hworker s t -> IO () @@ -813,7 +799,7 @@ monitor hw = R.zcount (scheduleQueue hw) 0 (utcToDouble now) >>= \case Right n | n > 0 -> - withNil' hw $ + withNil hw $ R.eval "local jobs = redis.call('zrangebyscore', KEYS[1], '0', ARGV[1])\n\ \redis.call('lpush', KEYS[2], unpack(jobs))\n\ @@ -828,9 +814,9 @@ monitor hw = Left err -> liftIO $ hwlog hw err - withList hw (R.hkeys (progressQueue hw)) $ \js -> + runWithList hw (R.hkeys (progressQueue hw)) $ \js -> forM_ js $ \j -> - withMaybe hw (R.hget (progressQueue hw) j) $ + runWithMaybe hw (R.hget (progressQueue hw) j) $ \start -> let duration = @@ -839,7 +825,7 @@ monitor hw = in when (duration > hworkerJobTimeout hw) $ do n <- - withInt hw $ + runWithInt hw $ R.eval "local del = redis.call('hdel', KEYS[2], ARGV[1])\n\ \if del == 1 then\ @@ -885,7 +871,7 @@ jobsFromQueue hw q = return [] Right xs -> - return $ mapMaybe (fmap (\(JobRef _ _ _, x) -> x) . A.decodeStrict) xs + return $ mapMaybe (fmap (\(JobRef _ _, x) -> x) . A.decodeStrict) xs -- | Returns all pending jobs. @@ -911,9 +897,9 @@ failed hw = debugger :: Job s t => Int -> Hworker s t -> IO () debugger microseconds hw = forever $ do - withList hw (R.hkeys (progressQueue hw)) $ + runWithList hw (R.hkeys (progressQueue hw)) $ \running -> - withList hw (R.lrange (jobQueue hw) 0 (-1)) + runWithList hw (R.lrange (jobQueue hw) 0 (-1)) $ \queued -> hwlog hw ("DEBUG" :: Text, queued, running) threadDelay microseconds @@ -965,9 +951,9 @@ batchSummary' hw batch = do -- Redis helpers follow -withList :: +runWithList :: Show a => Hworker s t -> Redis (Either a [b]) -> ([b] -> IO ()) -> IO () -withList hw a f = +runWithList hw a f = runRedis (hworkerConnection hw) a >>= \case Left err -> hwlog hw err @@ -975,9 +961,9 @@ withList hw a f = Right xs -> f xs -withMaybe :: +runWithMaybe :: Show a => Hworker s t -> Redis (Either a (Maybe b)) -> (b -> IO ()) -> IO () -withMaybe hw a f = do +runWithMaybe hw a f = do runRedis (hworkerConnection hw) a >>= \case Left err -> hwlog hw err @@ -985,25 +971,22 @@ withMaybe hw a f = do Right (Just v) -> f v -withNil :: Show a => Hworker s t -> Redis (Either a (Maybe ByteString)) -> IO () -withNil hw a = - runRedis (hworkerConnection hw) a >>= - \case - Left err -> hwlog hw err - Right _ -> return () +runWithNil :: Show a => Hworker s t -> Redis (Either a (Maybe ByteString)) -> IO () +runWithNil hw a = + runRedis (hworkerConnection hw) $ withNil hw a -withNil' :: +withNil :: Show a => Hworker s t -> Redis (Either a (Maybe ByteString)) -> Redis () -withNil' hw a = +withNil hw a = a >>= \case Left err -> liftIO $ hwlog hw err Right _ -> return () -withInt :: Hworker s t -> Redis (Either R.Reply Integer) -> IO Integer -withInt hw a = +runWithInt :: Hworker s t -> Redis (Either R.Reply Integer) -> IO Integer +runWithInt hw a = runRedis (hworkerConnection hw) a >>= \case Left err -> hwlog hw err >> return (-1) diff --git a/test/Spec.hs b/test/Spec.hs index ace9c5e..f4144fb 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,7 +9,7 @@ import Control.Concurrent ( forkIO, killThread, threadDelay ) import Control.Concurrent.MVar ( MVar, modifyMVarMasked_, newMVar , readMVar, takeMVar ) -import Control.Monad ( replicateM_, when, void ) +import Control.Monad ( replicateM_, void ) import Control.Monad.Trans ( lift, liftIO ) import Data.Aeson ( FromJSON(..), ToJSON(..) ) import qualified Data.Conduit as Conduit @@ -23,8 +23,7 @@ import Test.HUnit ( assertEqual ) -------------------------------------------------------------------------------- import System.Hworker -------------------------------------------------------------------------------- -import Data.UUID (toText) -import Data.UUID.V4 (nextRandom) + main :: IO () @@ -266,7 +265,7 @@ main = hspec $ do killThread wthread destroy hworker - it "should change job status finished when last processed" $ do + it "should change job status to finished when last processed" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) @@ -471,9 +470,9 @@ main = hspec $ do wthread <- forkIO (worker hworker) mthread <- forkIO (monitor hworker) time <- getCurrentTime - queueScheduled hworker SimpleJob Nothing (addUTCTime 1 time) - queueScheduled hworker SimpleJob Nothing (addUTCTime 2 time) - queueScheduled hworker SimpleJob Nothing (addUTCTime 4 time) + queueScheduled hworker SimpleJob (addUTCTime 1 time) + queueScheduled hworker SimpleJob (addUTCTime 2 time) + queueScheduled hworker SimpleJob (addUTCTime 4 time) threadDelay 1500000 >> readMVar mvar >>= shouldBe 1 threadDelay 1000000 >> readMVar mvar >>= shouldBe 2 threadDelay 1000000 >> readMVar mvar >>= shouldBe 2 @@ -483,21 +482,12 @@ main = hspec $ do destroy hworker it "should execute a recurring job" $ do - recur <- toText <$> nextRandom mvar <- newMVar 0 - hworker <- - createWith (conf "simpleworker-1" (SimpleState mvar)) - { hwconfigRecurringJob = - \hw r _ -> do - when (r == recur) $ do - time <- getCurrentTime - void $ queueScheduled hw SimpleJob (Just r) (addUTCTime 1.99 time) - } - + hworker <- createWith (conf "recurringworker-1" (RecurringState mvar)) wthread <- forkIO (worker hworker) mthread <- forkIO (monitor hworker) time <- getCurrentTime - queueScheduled hworker SimpleJob (Just recur) (addUTCTime 2 time) + queueScheduled hworker RecurringJob (addUTCTime 2 time) threadDelay 3000000 >> readMVar mvar >>= shouldBe 1 threadDelay 2000000 >> readMVar mvar >>= shouldBe 2 threadDelay 2000000 >> readMVar mvar >>= shouldBe 3 @@ -574,7 +564,7 @@ newtype SimpleState = SimpleState (MVar Int) instance Job SimpleState SimpleJob where - job (SimpleState mvar) SimpleJob = + job Hworker { hworkerState = SimpleState mvar } SimpleJob = modifyMVarMasked_ mvar (return . (+1)) >> return Success @@ -588,7 +578,7 @@ newtype ExState = ExState (MVar Int) instance Job ExState ExJob where - job (ExState mvar) ExJob = do + job Hworker { hworkerState = ExState mvar } ExJob = do modifyMVarMasked_ mvar (return . (+1)) v <- readMVar mvar if v > 1 @@ -606,7 +596,7 @@ newtype RetryState = RetryState (MVar Int) instance Job RetryState RetryJob where - job (RetryState mvar) RetryJob = do + job Hworker { hworkerState = RetryState mvar } RetryJob = do modifyMVarMasked_ mvar (return . (+1)) v <- readMVar mvar if v > 1 @@ -624,7 +614,7 @@ newtype FailState = FailState (MVar Int) instance Job FailState FailJob where - job (FailState mvar) FailJob = do + job Hworker { hworkerState = FailState mvar } FailJob = do modifyMVarMasked_ mvar (return . (+1)) v <- readMVar mvar if v > 1 @@ -642,7 +632,7 @@ newtype AlwaysFailState = AlwaysFailState (MVar Int) instance Job AlwaysFailState AlwaysFailJob where - job (AlwaysFailState mvar) AlwaysFailJob = do + job Hworker { hworkerState = AlwaysFailState mvar} AlwaysFailJob = do modifyMVarMasked_ mvar (return . (+1)) return (Failure "AlwaysFailJob fails") @@ -657,7 +647,7 @@ newtype TimedState = TimedState (MVar Int) instance Job TimedState TimedJob where - job (TimedState mvar) (TimedJob delay) = do + job Hworker { hworkerState = TimedState mvar } (TimedJob delay) = do threadDelay delay modifyMVarMasked_ mvar (return . (+1)) return Success @@ -673,11 +663,28 @@ newtype BigState = BigState (MVar Int) instance Job BigState BigJob where - job (BigState mvar) (BigJob _) = + job Hworker { hworkerState = BigState mvar } (BigJob _) = modifyMVarMasked_ mvar (return . (+1)) >> return Success -conf :: Text -> s -> HworkerConfig s t +data RecurringJob = + RecurringJob deriving (Generic, Show, Eq) + +instance ToJSON RecurringJob +instance FromJSON RecurringJob + +newtype RecurringState = + RecurringState (MVar Int) + +instance Job RecurringState RecurringJob where + job hw@Hworker{ hworkerState = RecurringState mvar} RecurringJob = do + modifyMVarMasked_ mvar (return . (+1)) + time <- getCurrentTime + queueScheduled hw RecurringJob (addUTCTime 1.99 time) + return Success + + +conf :: Text -> s -> HworkerConfig s conf n s = (defaultHworkerConfig n s) { hwconfigLogger = const (return ()) From ecc1e1c8eef68aae0ac813c8c2f62a6a9c89f206 Mon Sep 17 00:00:00 2001 From: remeike Date: Mon, 27 Feb 2023 07:39:56 -0500 Subject: [PATCH 24/36] Return more information when queueing fails --- src/System/Hworker.hs | 42 +++++++++++++++++++++--------------------- test/Spec.hs | 8 +++++--- 2 files changed, 26 insertions(+), 24 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 95930ef..2b3b9ca 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -57,6 +57,7 @@ module System.Hworker , BatchId(..) , BatchStatus(..) , BatchSummary(..) + , QueueingResult(..) -- * Managing Workers , create , createWith @@ -453,7 +454,7 @@ queueScheduled hw j utc = do -- so that if a single job fails to queue then then none of the jobs -- in the list will queue. -queueBatch :: Job s t => Hworker s t -> BatchId -> Bool -> [t] -> IO Bool +queueBatch :: Job s t => Hworker s t -> BatchId -> Bool -> [t] -> IO QueueingResult queueBatch hw batch close js = withBatchQueue hw batch $ runRedis (hworkerConnection hw) $ R.multiExec $ do @@ -477,12 +478,21 @@ queueBatch hw batch close js = return (pure ()) +data QueueingResult + = BatchNotFound BatchId + | TransactionAborted BatchSummary + | QueueingSuccess BatchSummary + | QueueingFailed Text BatchSummary + | AlreadyQueued BatchSummary + deriving (Eq, Show) + + -- | Like 'queueBatch', but instead of a list of jobs, it takes a conduit -- that streams jobs in. streamBatch :: Job s t => - Hworker s t -> BatchId -> Bool -> ConduitT () t RedisTx () -> IO Bool + Hworker s t -> BatchId -> Bool -> ConduitT () t RedisTx () -> IO QueueingResult streamBatch hw batch close producer = let sink = @@ -513,45 +523,35 @@ streamBatch hw batch close producer = withBatchQueue :: - Job s t => Hworker s t -> BatchId -> IO (TxResult ()) -> IO Bool + Job s t => Hworker s t -> BatchId -> IO (TxResult ()) -> IO QueueingResult withBatchQueue hw batch process = runRedis (hworkerConnection hw) (batchSummary' hw batch) >>= \case - Nothing -> do - hwlog hw $ "BATCH NOT FOUND: " <> show batch - return False + Nothing -> + return $ BatchNotFound batch Just summary | batchSummaryStatus summary == BatchQueueing -> catch ( process >>= \case TxSuccess () -> - return True + return $ QueueingSuccess summary TxAborted -> do - hwlog hw ("TRANSACTION ABORTED" :: String) runRedis (hworkerConnection hw) $ resetBatchSummary hw summary - return False + return $ TransactionAborted summary TxError err -> do - hwlog hw err runRedis (hworkerConnection hw) $ resetBatchSummary hw summary - return False + return $ QueueingFailed (T.pack err) summary ) ( \(e :: SomeException) -> do - hwlog hw $ show e runRedis (hworkerConnection hw) (resetBatchSummary hw summary) - return False + return $ QueueingFailed (T.pack (show e)) summary ) - Just _-> do - hwlog hw $ - mconcat - [ "QUEUEING COMPLETED FOR BATCH: " - , show batch - , ". CANNOT ENQUEUE NEW JOBS." - ] - return False + Just summary -> + return $ AlreadyQueued summary -- | Prevents queueing new jobs to a batch. If the number of jobs completed equals diff --git a/test/Spec.hs b/test/Spec.hs index f4144fb..3490012 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -201,10 +201,12 @@ main = hspec $ do queueBatch hworker batch False [SimpleJob] threadDelay 30000 stopBatchQueueing hworker batch - queueBatch hworker batch False [SimpleJob] >>= shouldBe False - threadDelay 30000 summary <- expectBatchSummary hworker batch - batchSummaryQueued summary `shouldBe` 1 + queueBatch hworker batch False [SimpleJob] + >>= shouldBe (AlreadyQueued summary) + threadDelay 30000 + summary' <- expectBatchSummary hworker batch + batchSummaryQueued summary' `shouldBe` 1 killThread wthread destroy hworker From 3e5ee88270304695b269b2a75bf86addc1ae5faf Mon Sep 17 00:00:00 2001 From: remeike Date: Mon, 27 Feb 2023 17:28:23 -0500 Subject: [PATCH 25/36] Add failed as a status --- src/System/Hworker.hs | 44 +++++++++++++++++++++---------------------- test/Spec.hs | 5 +++-- 2 files changed, 24 insertions(+), 25 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 2b3b9ca..5840923 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -197,6 +197,7 @@ newtype BatchId = data BatchStatus = BatchQueueing + | BatchFailed | BatchProcessing | BatchFinished deriving (Eq, Show) @@ -480,9 +481,9 @@ queueBatch hw batch close js = data QueueingResult = BatchNotFound BatchId - | TransactionAborted BatchSummary + | TransactionAborted BatchId Int | QueueingSuccess BatchSummary - | QueueingFailed Text BatchSummary + | QueueingFailed BatchId Int Text | AlreadyQueued BatchSummary deriving (Eq, Show) @@ -538,16 +539,16 @@ withBatchQueue hw batch process = return $ QueueingSuccess summary TxAborted -> do - runRedis (hworkerConnection hw) $ resetBatchSummary hw summary - return $ TransactionAborted summary + n <- runRedis (hworkerConnection hw) $ failBatchSummary hw batch + return $ TransactionAborted batch n TxError err -> do - runRedis (hworkerConnection hw) $ resetBatchSummary hw summary - return $ QueueingFailed (T.pack err) summary + n <- runRedis (hworkerConnection hw) $ failBatchSummary hw batch + return $ QueueingFailed batch n (T.pack err) ) ( \(e :: SomeException) -> do - runRedis (hworkerConnection hw) (resetBatchSummary hw summary) - return $ QueueingFailed (T.pack (show e)) summary + n <- runRedis (hworkerConnection hw) (failBatchSummary hw batch) + return $ QueueingFailed batch n (T.pack (show e)) ) Just summary -> @@ -997,12 +998,14 @@ runWithInt hw a = encodeBatchStatus :: BatchStatus -> ByteString encodeBatchStatus BatchQueueing = "queueing" +encodeBatchStatus BatchFailed = "failed" encodeBatchStatus BatchProcessing = "processing" encodeBatchStatus BatchFinished = "finished" decodeBatchStatus :: ByteString -> Maybe BatchStatus decodeBatchStatus "queueing" = Just BatchQueueing +decodeBatchStatus "failed" = Just BatchFailed decodeBatchStatus "processing" = Just BatchProcessing decodeBatchStatus "finished" = Just BatchFinished decodeBatchStatus _ = Nothing @@ -1031,21 +1034,16 @@ readMaybe = fmap fst . listToMaybe . reads . B8.unpack -resetBatchSummary :: R.RedisCtx m n => Hworker s t -> BatchSummary -> m () -resetBatchSummary hw BatchSummary{..} = - let - encode = - B8.pack . show - in - void $ - R.hmset (batchCounter hw batchSummaryID) - [ ("queued", encode batchSummaryQueued) - , ("completed", encode batchSummaryCompleted) - , ("successes", encode batchSummarySuccesses) - , ("failures", encode batchSummaryFailures) - , ("retries", encode batchSummaryRetries) - , ("status", encodeBatchStatus batchSummaryStatus) - ] +failBatchSummary :: Hworker s t -> BatchId -> Redis Int +failBatchSummary hw batch = do + void + $ R.hset (batchCounter hw batch) "status" + $ encodeBatchStatus BatchFailed + + batchSummary' hw batch >>= + \case + Just summary -> return $ batchSummaryQueued summary + _ -> return 0 utcToDouble :: UTCTime -> Double diff --git a/test/Spec.hs b/test/Spec.hs index 3490012..95d3d5a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -349,7 +349,7 @@ main = hspec $ do destroy hworker length ls `shouldBe` 0 - it "should increment summary but then reset after failure" $ do + it "should increment summary up until failure" $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing @@ -369,7 +369,8 @@ main = hspec $ do length ls `shouldBe` 0 threadDelay 100000 summary2 <- expectBatchSummary hworker batch - batchSummaryQueued summary2 `shouldBe` 0 + batchSummaryQueued summary2 `shouldBe` 5 + batchSummaryStatus summary2 `shouldBe` BatchFailed killThread thread destroy hworker From 8970b740576bc8686ea01d7199de6d969a0d057d Mon Sep 17 00:00:00 2001 From: remeike Date: Thu, 2 Mar 2023 22:24:26 -0500 Subject: [PATCH 26/36] Short circuit queueing --- src/System/Hworker.hs | 72 +++++++++++++++++++++++++++++++------------ test/Spec.hs | 19 ++++++------ 2 files changed, 63 insertions(+), 28 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 5840923..00bae76 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -58,6 +58,7 @@ module System.Hworker , BatchStatus(..) , BatchSummary(..) , QueueingResult(..) + , QueueJob(..) -- * Managing Workers , create , createWith @@ -85,6 +86,8 @@ module System.Hworker import Control.Arrow ( second) import Control.Concurrent ( threadDelay) import Control.Exception ( SomeException + , Exception + , throw , catch , catchJust , asyncExceptionFromException @@ -491,21 +494,46 @@ data QueueingResult -- | Like 'queueBatch', but instead of a list of jobs, it takes a conduit -- that streams jobs in. + +data QueueJob a + = QueueJob a + | AbortQueueing Text + + +data AbortException = + AbortException Text + deriving Show + + +instance Exception AbortException + + streamBatch :: Job s t => - Hworker s t -> BatchId -> Bool -> ConduitT () t RedisTx () -> IO QueueingResult + Hworker s t -> BatchId -> Bool -> ConduitT () (QueueJob t) RedisTx () -> + IO QueueingResult streamBatch hw batch close producer = let sink = Conduit.await >>= \case - Nothing -> do - when close - $ void . lift - $ R.hset (batchCounter hw batch) "status" "processing" - return (pure ()) + Nothing -> + liftIO (batchSummary hw batch) >>= + \case + Just summary | batchSummaryQueued summary == 0 -> do + void . lift $ R.hset (batchCounter hw batch) "status" "finished" + return (pure ()) + + _ -> do + when close + $ void . lift + $ R.hset (batchCounter hw batch) "status" "processing" + return (pure ()) + + Just (AbortQueueing message) -> do + throw (AbortException message) - Just j -> do + Just (QueueJob j) -> do jobId <- UUID.toText <$> liftIO UUID.nextRandom let ref = JobRef jobId (Just batch) _ <- lift $ R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] @@ -533,18 +561,24 @@ withBatchQueue hw batch process = Just summary | batchSummaryStatus summary == BatchQueueing -> catch - ( process >>= - \case - TxSuccess () -> - return $ QueueingSuccess summary - - TxAborted -> do - n <- runRedis (hworkerConnection hw) $ failBatchSummary hw batch - return $ TransactionAborted batch n - - TxError err -> do - n <- runRedis (hworkerConnection hw) $ failBatchSummary hw batch - return $ QueueingFailed batch n (T.pack err) + ( catch + ( process >>= + \case + TxSuccess () -> + return $ QueueingSuccess summary + + TxAborted -> do + n <- runRedis (hworkerConnection hw) $ failBatchSummary hw batch + return $ TransactionAborted batch n + + TxError err -> do + n <- runRedis (hworkerConnection hw) $ failBatchSummary hw batch + return $ QueueingFailed batch n (T.pack err) + ) + ( \(AbortException msg :: AbortException) -> do + n <- runRedis (hworkerConnection hw) (failBatchSummary hw batch) + return $ QueueingFailed batch n msg + ) ) ( \(e :: SomeException) -> do n <- runRedis (hworkerConnection hw) (failBatchSummary hw batch) diff --git a/test/Spec.hs b/test/Spec.hs index 95d3d5a..1862dc1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -307,7 +307,7 @@ main = hspec $ do batch <- startBatch hworker Nothing streamBatch hworker batch True $ replicateM_ 50 - $ Conduit.yield SimpleJob + $ Conduit.yield (QueueJob SimpleJob) ls <- jobs hworker length ls `shouldBe` 50 summary <- expectBatchSummary hworker batch @@ -320,10 +320,11 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing streamBatch hworker batch True $ do - replicateM_ 20 $ Conduit.yield SimpleJob - error "BLOW UP!" - replicateM_ 20 $ Conduit.yield SimpleJob + replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) + Conduit.yield (AbortQueueing "abort") + replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) ls <- jobs hworker + expectBatchSummary hworker batch destroy hworker length ls `shouldBe` 0 @@ -332,9 +333,9 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing streamBatch hworker batch True $ do - replicateM_ 20 $ Conduit.yield SimpleJob + replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) _ <- lift $ Redis.lpush "" [] - replicateM_ 20 $ Conduit.yield SimpleJob + replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) ls <- jobs hworker destroy hworker length ls `shouldBe` 0 @@ -344,7 +345,7 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing _ <- Redis.runRedis (hworkerConnection hworker) $ Redis.watch [batchCounter hworker batch] - streamBatch hworker batch True $ replicateM_ 20 $ Conduit.yield SimpleJob + streamBatch hworker batch True $ replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) ls <- jobs hworker destroy hworker length ls `shouldBe` 0 @@ -357,10 +358,10 @@ main = hspec $ do thread <- forkIO . void . streamBatch hworker batch True $ do replicateM_ 5 $ - Conduit.yield SimpleJob >> liftIO (threadDelay 50000) + Conduit.yield (QueueJob SimpleJob) >> liftIO (threadDelay 50000) error "BLOW UP!" replicateM_ 5 $ - Conduit.yield SimpleJob >> liftIO (threadDelay 50000) + Conduit.yield (QueueJob SimpleJob) >> liftIO (threadDelay 50000) threadDelay 190000 summary1 <- expectBatchSummary hworker batch From f108172104b557ab6d06d6d9366e049212c0937d Mon Sep 17 00:00:00 2001 From: remeike Date: Tue, 14 Mar 2023 15:35:44 -0400 Subject: [PATCH 27/36] Separate streamBatch functions --- src/System/Hworker.hs | 76 ++++++++++++++++++++++++++----------------- test/Spec.hs | 27 ++++++++------- 2 files changed, 62 insertions(+), 41 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 00bae76..bd037f2 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -58,7 +58,7 @@ module System.Hworker , BatchStatus(..) , BatchSummary(..) , QueueingResult(..) - , QueueJob(..) + , StreamingResult(..) -- * Managing Workers , create , createWith @@ -70,6 +70,7 @@ module System.Hworker , queueScheduled , queueBatch , streamBatch + , streamBatchTx , initBatch , stopBatchQueueing -- * Inspecting Workers @@ -191,6 +192,26 @@ newtype BatchId = deriving (ToJSON, FromJSON, Eq, Show) +-- | The result of a batch of jobs queued atomically. + +data QueueingResult + = BatchNotFound BatchId + | TransactionAborted BatchId Int + | QueueingSuccess BatchSummary + | QueueingFailed BatchId Int Text + | AlreadyQueued BatchSummary + deriving (Eq, Show) + + +-- | The return value of a batch of jobs that are streamed in. + +data StreamingResult + = StreamingOk -- End the stream successfully + | StreamingAborted Text -- Close the stream with the given error message, + -- reverting all previously added jobs + + + -- | Represents the current status of a batch. A batch is considered to be -- "queueing" if jobs can still be added to the batch. While jobs are -- queueing it is possible for them to be "processing" during that time. @@ -482,24 +503,6 @@ queueBatch hw batch close js = return (pure ()) -data QueueingResult - = BatchNotFound BatchId - | TransactionAborted BatchId Int - | QueueingSuccess BatchSummary - | QueueingFailed BatchId Int Text - | AlreadyQueued BatchSummary - deriving (Eq, Show) - - --- | Like 'queueBatch', but instead of a list of jobs, it takes a conduit --- that streams jobs in. - - -data QueueJob a - = QueueJob a - | AbortQueueing Text - - data AbortException = AbortException Text deriving Show @@ -508,11 +511,24 @@ data AbortException = instance Exception AbortException +-- | TODO + streamBatch :: Job s t => - Hworker s t -> BatchId -> Bool -> ConduitT () (QueueJob t) RedisTx () -> + Hworker s t -> BatchId -> Bool -> ConduitT () t IO StreamingResult -> IO QueueingResult streamBatch hw batch close producer = + streamBatchTx hw batch close $ Conduit.transPipe liftIO producer + + +-- | Like 'queueBatch', but instead of a list of jobs, it takes a conduit +-- that streams jobs in within a Redis transaction. + +streamBatchTx :: + Job s t => + Hworker s t -> BatchId -> Bool -> ConduitT () t RedisTx StreamingResult -> + IO QueueingResult +streamBatchTx hw batch close producer = let sink = Conduit.await >>= @@ -520,20 +536,15 @@ streamBatch hw batch close producer = Nothing -> liftIO (batchSummary hw batch) >>= \case - Just summary | batchSummaryQueued summary == 0 -> do + Just summary | batchSummaryQueued summary == 0 -> void . lift $ R.hset (batchCounter hw batch) "status" "finished" - return (pure ()) - _ -> do + _ -> when close $ void . lift $ R.hset (batchCounter hw batch) "status" "processing" - return (pure ()) - Just (AbortQueueing message) -> do - throw (AbortException message) - - Just (QueueJob j) -> do + Just j -> do jobId <- UUID.toText <$> liftIO UUID.nextRandom let ref = JobRef jobId (Just batch) _ <- lift $ R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] @@ -545,10 +556,17 @@ streamBatch hw batch close producer = $ R.hincrby (batchCounter hw batch) "queued" 1 sink + + run = + Conduit.runConduit (Conduit.fuseUpstream producer sink) >>= + \case + StreamingOk -> return (pure ()) + StreamingAborted err -> throw (AbortException err) in withBatchQueue hw batch $ runRedis (hworkerConnection hw) - $ R.multiExec (Conduit.connect producer sink) + $ R.multiExec run + withBatchQueue :: diff --git a/test/Spec.hs b/test/Spec.hs index 1862dc1..617a023 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -305,9 +305,9 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing - streamBatch hworker batch True - $ replicateM_ 50 - $ Conduit.yield (QueueJob SimpleJob) + streamBatch hworker batch True $ do + replicateM_ 50 $ Conduit.yield SimpleJob + return StreamingOk ls <- jobs hworker length ls `shouldBe` 50 summary <- expectBatchSummary hworker batch @@ -320,9 +320,8 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing streamBatch hworker batch True $ do - replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) - Conduit.yield (AbortQueueing "abort") - replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) + replicateM_ 20 $ Conduit.yield SimpleJob + return (StreamingAborted "abort") ls <- jobs hworker expectBatchSummary hworker batch destroy hworker @@ -332,10 +331,11 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing - streamBatch hworker batch True $ do - replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) + streamBatchTx hworker batch True $ do + replicateM_ 20 $ Conduit.yield SimpleJob _ <- lift $ Redis.lpush "" [] - replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) + replicateM_ 20 $ Conduit.yield SimpleJob + return StreamingOk ls <- jobs hworker destroy hworker length ls `shouldBe` 0 @@ -345,7 +345,9 @@ main = hspec $ do hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) batch <- startBatch hworker Nothing _ <- Redis.runRedis (hworkerConnection hworker) $ Redis.watch [batchCounter hworker batch] - streamBatch hworker batch True $ replicateM_ 20 $ Conduit.yield (QueueJob SimpleJob) + streamBatch hworker batch True $ do + replicateM_ 20 $ Conduit.yield SimpleJob + return StreamingOk ls <- jobs hworker destroy hworker length ls `shouldBe` 0 @@ -358,10 +360,11 @@ main = hspec $ do thread <- forkIO . void . streamBatch hworker batch True $ do replicateM_ 5 $ - Conduit.yield (QueueJob SimpleJob) >> liftIO (threadDelay 50000) + Conduit.yield SimpleJob >> liftIO (threadDelay 50000) error "BLOW UP!" replicateM_ 5 $ - Conduit.yield (QueueJob SimpleJob) >> liftIO (threadDelay 50000) + Conduit.yield SimpleJob >> liftIO (threadDelay 50000) + return StreamingOk threadDelay 190000 summary1 <- expectBatchSummary hworker batch From a6fa84d2a61188d0895859dd9c1d2afd20241c10 Mon Sep 17 00:00:00 2001 From: remeike Date: Tue, 14 Mar 2023 15:36:43 -0400 Subject: [PATCH 28/36] Add documentation for streamBatch functions --- src/System/Hworker.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index bd037f2..2c57e59 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -511,7 +511,8 @@ data AbortException = instance Exception AbortException --- | TODO +-- | Like 'queueBatch', but instead of a list of jobs, it takes a conduit +-- that streams jobs within IO. streamBatch :: Job s t => @@ -521,8 +522,8 @@ streamBatch hw batch close producer = streamBatchTx hw batch close $ Conduit.transPipe liftIO producer --- | Like 'queueBatch', but instead of a list of jobs, it takes a conduit --- that streams jobs in within a Redis transaction. +-- | Like 'streamBatch', but instead of IO, jobs are streamed directly within +-- a Redis transaction. streamBatchTx :: Job s t => From 88e0b2d39d916558199ed0b8012c1cd0878ca48c Mon Sep 17 00:00:00 2001 From: remeike Date: Thu, 13 Jul 2023 13:38:18 -0400 Subject: [PATCH 29/36] Create separate scheduler thread --- src/System/Hworker.hs | 28 ++++++++++++++++++++-------- test/Spec.hs | 8 ++++---- 2 files changed, 24 insertions(+), 12 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 2c57e59..0c9c98b 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -64,6 +64,7 @@ module System.Hworker , createWith , destroy , worker + , scheduler , monitor -- * Queuing Jobs , queue @@ -837,15 +838,12 @@ worker hw = delayAndRun --- | Start a monitor. Like 'worker', this is blocking, so should be --- started in a thread. This is responsible for retrying jobs that --- time out (which can happen if the processing thread is killed, for --- example) and for pushing scheduled jobs to the queue at the expected time. --- You need to have at least one of these running to have --- the retry happen, but it is safe to have any number running. +-- | Start a scheduler. Like 'worker', this is blocking, so should be +-- started in a thread. This is responsible for pushing scheduled jobs +-- to the queue at the expected time. -monitor :: Job s t => Hworker s t -> IO () -monitor hw = +scheduler :: Job s t => Hworker s t -> IO () +scheduler hw = forever $ do now <- getCurrentTime @@ -868,6 +866,20 @@ monitor hw = Left err -> liftIO $ hwlog hw err + threadDelay 500000 >> scheduler hw + + +-- | Start a monitor. Like 'worker', this is blocking, so should be +-- started in a thread. This is responsible for retrying jobs that +-- time out (which can happen if the processing thread is killed, for +-- example). You need to have at least one of these running to have +-- the retry happen, but it is safe to have any number running. + +monitor :: Job s t => Hworker s t -> IO () +monitor hw = + forever $ do + now <- getCurrentTime + runWithList hw (R.hkeys (progressQueue hw)) $ \js -> forM_ js $ \j -> runWithMaybe hw (R.hget (progressQueue hw) j) $ diff --git a/test/Spec.hs b/test/Spec.hs index 617a023..020a834 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -475,7 +475,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) wthread <- forkIO (worker hworker) - mthread <- forkIO (monitor hworker) + sthread <- forkIO (scheduler hworker) time <- getCurrentTime queueScheduled hworker SimpleJob (addUTCTime 1 time) queueScheduled hworker SimpleJob (addUTCTime 2 time) @@ -485,14 +485,14 @@ main = hspec $ do threadDelay 1000000 >> readMVar mvar >>= shouldBe 2 threadDelay 1000000 >> readMVar mvar >>= shouldBe 3 killThread wthread - killThread mthread + killThread sthread destroy hworker it "should execute a recurring job" $ do mvar <- newMVar 0 hworker <- createWith (conf "recurringworker-1" (RecurringState mvar)) wthread <- forkIO (worker hworker) - mthread <- forkIO (monitor hworker) + sthread <- forkIO (scheduler hworker) time <- getCurrentTime queueScheduled hworker RecurringJob (addUTCTime 2 time) threadDelay 3000000 >> readMVar mvar >>= shouldBe 1 @@ -501,7 +501,7 @@ main = hspec $ do threadDelay 2000000 >> readMVar mvar >>= shouldBe 4 destroy hworker killThread wthread - killThread mthread + killThread sthread describe "Broken jobs" $ it "should store broken jobs" $ do From bbbb0e236a044388a30c546816f68cc1f1aa16a0 Mon Sep 17 00:00:00 2001 From: remeike Date: Tue, 15 Aug 2023 17:33:22 -0400 Subject: [PATCH 30/36] Add cron jobs --- .gitignore | 2 + example/hworker-example.cabal | 3 +- example/src/Main.hs | 20 +++ hworker.cabal | 4 +- src/System/Hworker.hs | 285 ++++++++++++++++++++++++++++------ test/Spec.hs | 70 ++++++++- 6 files changed, 336 insertions(+), 48 deletions(-) diff --git a/.gitignore b/.gitignore index 9e7f383..bc2b1be 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ cabal.sandbox.config dist-stack stack.yaml.lock +dist-newstyle +cabal.project.local diff --git a/example/hworker-example.cabal b/example/hworker-example.cabal index c86c8ef..519024d 100644 --- a/example/hworker-example.cabal +++ b/example/hworker-example.cabal @@ -23,4 +23,5 @@ executable hworker-example , attoparsec , uuid >= 1.2.6 , hworker - default-language: Haskell2010 \ No newline at end of file + , saturn + default-language: Haskell2010 diff --git a/example/src/Main.hs b/example/src/Main.hs index 18baeb9..32566ca 100644 --- a/example/src/Main.hs +++ b/example/src/Main.hs @@ -8,7 +8,9 @@ import Control.Concurrent ( forkIO, threadDelay ) import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar ) import Control.Monad ( forever ) import Data.Aeson ( FromJSON, ToJSON ) +import Data.Time.Clock ( getCurrentTime ) import GHC.Generics ( Generic ) +import qualified Saturn as Schedule -------------------------------------------------------------------------------- import System.Hworker -------------------------------------------------------------------------------- @@ -17,6 +19,7 @@ import System.Hworker data PrintJob = PrintA | PrintB + | PrintC deriving (Generic, Show) @@ -45,6 +48,9 @@ instance Job State PrintJob where job _ PrintB = putStrLn "B" >> return Success + job _ PrintC = + putStrLn "C" >> getCurrentTime >>= print >> return Success + main :: IO () main = do @@ -55,3 +61,17 @@ main = do _ <- forkIO (forever $ queue hworker PrintA >> threadDelay 1000000) _ <- forkIO (forever $ queue hworker PrintB >> threadDelay 500000) forever (threadDelay 1000000) + + +runCron :: IO () +runCron = do + print ("Starting" :: String) + mvar <- newMVar 3 + hworker <- + createWith + (defaultHworkerConfig "printer" (State mvar)) + { hwconfigCronJobs = [CronJob "per-minute" PrintB Schedule.everyMinute] } + _ <- forkIO (worker hworker) + _ <- forkIO (monitor hworker) + _ <- forkIO (scheduler hworker) + forever (threadDelay 1000000) diff --git a/hworker.cabal b/hworker.cabal index 5a35c71..eb0b091 100644 --- a/hworker.cabal +++ b/hworker.cabal @@ -1,3 +1,4 @@ +cabal-version: 3.0 name: hworker version: 0.3.0 synopsis: A reliable at-least-once job queue built on top of redis. @@ -9,7 +10,6 @@ author: Daniel Patterson maintainer: dbp@dbpmail.net build-type: Simple extra-source-files: README.md CHANGELOG.md -cabal-version: >=1.10 library exposed-modules: System.Hworker @@ -23,6 +23,7 @@ library , uuid >= 1.2.6 , mtl , conduit + , saturn hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -47,3 +48,4 @@ Test-Suite hworker-test , HUnit , mtl , conduit + , saturn diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 0c9c98b..43dd3b2 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -57,6 +57,7 @@ module System.Hworker , BatchId(..) , BatchStatus(..) , BatchSummary(..) + , CronJob(..) , QueueingResult(..) , StreamingResult(..) -- * Managing Workers @@ -74,9 +75,15 @@ module System.Hworker , streamBatchTx , initBatch , stopBatchQueueing + -- * Cron Jobs + , initCron + , queueCron + , requeueCron + , checkCron -- * Inspecting Workers , jobs , failed + , scheduled , broken , batchSummary -- * Debugging Utilities @@ -97,7 +104,7 @@ import Control.Exception ( SomeException ) import Control.Monad ( forM_, forever, void, when ) import Control.Monad.Trans ( liftIO, lift ) -import Data.Aeson ( FromJSON, ToJSON, (.=), (.:) ) +import Data.Aeson ( FromJSON, ToJSON, (.=), (.:), (.:?) ) import qualified Data.Aeson as A import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as B8 @@ -127,6 +134,8 @@ import Database.Redis ( Redis ) import qualified Database.Redis as R import GHC.Generics ( Generic ) +import Saturn ( Schedule ) +import qualified Saturn as Schedule -------------------------------------------------------------------------------- @@ -211,6 +220,10 @@ data StreamingResult | StreamingAborted Text -- Close the stream with the given error message, -- reverting all previously added jobs +-- | Represents a recurring job that executes on a particular schedule. + +data CronJob t = + CronJob Text t Schedule -- | Represents the current status of a batch. A batch is considered to be @@ -247,12 +260,13 @@ data BatchSummary = data JobRef = - JobRef JobId (Maybe BatchId) + JobRef JobId (Maybe BatchId) (Maybe Text) deriving (Eq, Show) instance ToJSON JobRef where - toJSON (JobRef j b) = A.object ["j" .= j, "b" .= b] + toJSON (JobRef j b s) = + A.object ["j" .= j, "b" .= b, "s" .= s] instance FromJSON JobRef where @@ -260,8 +274,8 @@ instance FromJSON JobRef where -- can be removed eventually. Before `JobRef`, which is encoded as -- a JSON object, there was a just a `String` representing the job ID. - parseJSON (A.String j) = pure (JobRef j Nothing) - parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b") val + parseJSON (A.String j) = pure (JobRef j Nothing Nothing) + parseJSON val = A.withObject "JobRef" (\o -> JobRef <$> o .: "j" <*> o .: "b" <*> o .:? "s") val hwlog :: Show a => Hworker s t -> a -> IO () @@ -322,7 +336,7 @@ data RedisConnection -- 'hwconfigFailedQueueSize' controls how many 'failed' jobs will be -- kept. It defaults to 1000. -data HworkerConfig s = +data HworkerConfig s t = HworkerConfig { hwconfigName :: Text , hwconfigState :: s @@ -333,13 +347,14 @@ data HworkerConfig s = , hwconfigFailedQueueSize :: Int , hwconfigDebug :: Bool , hwconfigBatchCompleted :: BatchSummary -> IO () + , hwconfigCronJobs :: [CronJob t] } -- | The default worker config - it needs a name and a state (as those -- will always be unique). -defaultHworkerConfig :: Text -> s -> HworkerConfig s +defaultHworkerConfig :: Text -> s -> HworkerConfig s t defaultHworkerConfig name state = HworkerConfig { hwconfigName = name @@ -351,6 +366,7 @@ defaultHworkerConfig name state = , hwconfigFailedQueueSize = 1000 , hwconfigDebug = False , hwconfigBatchCompleted = const (return ()) + , hwconfigCronJobs = [] } @@ -371,25 +387,30 @@ create name state = -- the queue to actually process jobs (and for it to retry ones that -- time-out). -createWith :: Job s t => HworkerConfig s -> IO (Hworker s t) +createWith :: Job s t => HworkerConfig s t -> IO (Hworker s t) createWith HworkerConfig{..} = do conn <- case hwconfigRedisConnectInfo of RedisConnectInfo c -> R.connect c RedisConnection c -> return c - return $ - Hworker - { hworkerName = T.encodeUtf8 hwconfigName - , hworkerState = hwconfigState - , hworkerConnection = conn - , hworkerExceptionBehavior = hwconfigExceptionBehavior - , hworkerLogger = hwconfigLogger - , hworkerJobTimeout = hwconfigTimeout - , hworkerFailedQueueSize = hwconfigFailedQueueSize - , hworkerDebug = hwconfigDebug - , hworkerBatchCompleted = hwconfigBatchCompleted - } + let + hworker = + Hworker + { hworkerName = T.encodeUtf8 hwconfigName + , hworkerState = hwconfigState + , hworkerConnection = conn + , hworkerExceptionBehavior = hwconfigExceptionBehavior + , hworkerLogger = hwconfigLogger + , hworkerJobTimeout = hwconfigTimeout + , hworkerFailedQueueSize = hwconfigFailedQueueSize + , hworkerDebug = hwconfigDebug + , hworkerBatchCompleted = hwconfigBatchCompleted + } + + time <- getCurrentTime + initCron hworker time hwconfigCronJobs + return hworker -- | Destroy a worker. This will delete all the queues, clearing out @@ -415,6 +436,8 @@ destroy hw = , brokenQueue hw , failedQueue hw , scheduleQueue hw + , cronSchedule hw + , cronProcessing hw ] @@ -448,6 +471,16 @@ batchCounter hw (BatchId batch) = "hworker-batch-" <> hworkerName hw <> ":" <> UUID.toASCIIBytes batch +cronSchedule :: Hworker s t -> ByteString +cronSchedule hw = + "hworker-cron-schedule-" <> hworkerName hw + + +cronProcessing :: Hworker s t -> ByteString +cronProcessing hw = + "hworker-cron-processing-" <> hworkerName hw + + -- | Adds a job to the queue. Returns whether the operation succeeded. queue :: Job s t => Hworker s t -> t -> IO Bool @@ -456,10 +489,119 @@ queue hw j = do result <- runRedis (hworkerConnection hw) $ R.lpush (jobQueue hw) - $ [LB.toStrict $ A.encode (JobRef jobId Nothing, j)] + $ [LB.toStrict $ A.encode (JobRef jobId Nothing Nothing, j)] return $ isRight result +-- | Initializes all cron jobs. This is will add all of the cron schedules +-- if not already present or update the schedules if they are. + +initCron :: Job s t => Hworker s t -> UTCTime -> [CronJob t] -> IO () +initCron hw time cronJobs = do + void + $ runRedis (hworkerConnection hw) + $ R.hmset (cronSchedule hw) + $ fmap + ( \(CronJob cron _ schedule) -> + (T.encodeUtf8 cron, T.encodeUtf8 $ Schedule.toText schedule) + ) + cronJobs + + mapM_ + ( \cron@(CronJob name _ _) -> do + exists <- checkCron hw name + when (not exists) $ void $ queueCron hw time cron + ) + cronJobs + + +-- | Queues a cron job for the first time, adding it to the schedule queue +-- at its next scheduled time. + +queueCron :: Job s t => Hworker s t -> UTCTime -> CronJob t -> IO Bool +queueCron hw time (CronJob cron j schedule) = do + jobId <- UUID.toText <$> UUID.nextRandom + case Schedule.nextMatch time schedule of + Nothing -> + return False + + Just utc -> do + result <- + runRedis (hworkerConnection hw) $ R.zadd (scheduleQueue hw) $ + [ ( utcToDouble utc + , LB.toStrict $ A.encode (JobRef jobId Nothing (Just cron), j) + ) + ] + return $ isRight result + + +-- | Re-enqueues cron job, removing the record from the cron processing hash +-- and adding it back to the schedule queue at its next scheduled time. + +requeueCron :: Job s t => Hworker s t -> Text -> t -> IO () +requeueCron hw cron j = do + jobId <- UUID.toText <$> UUID.nextRandom + runRedis (hworkerConnection hw) $ do + void $ withInt hw $ R.hdel (cronProcessing hw) [T.encodeUtf8 cron] + R.hget (cronSchedule hw) (T.encodeUtf8 cron) >>= + \case + Left err -> + liftIO $ hwlog hw err + + Right Nothing -> + -- This can happen if the scheduled changed between the job + -- being queued for execution and then being requeued + liftIO $ hwlog hw $ "CRON NOT FOUND: " <> cron + + Right (Just field) -> + case Schedule.fromText (T.decodeUtf8 field) of + Left err -> + liftIO $ hwlog hw err + + Right schedule -> do + time <- liftIO getCurrentTime + + case Schedule.nextMatch time schedule of + Nothing -> + liftIO $ hwlog hw $ "CRON SCHEDULE NOT FOUND: " <> field + + Just utc -> + void $ withInt hw $ R.zadd (scheduleQueue hw) $ + [ ( utcToDouble utc + , LB.toStrict $ A.encode (JobRef jobId Nothing (Just cron), j) + ) + ] + + +-- | Checks if the there is a already a job for a particular cron process +-- which is either scheduled or currently being processed. + +checkCron :: forall s t. Job s t => Hworker s t -> Text -> IO Bool +checkCron hw cron = + runRedis (hworkerConnection hw) $ do + R.hget (cronProcessing hw) (T.encodeUtf8 cron) >>= + \case + Right (Just _) -> + return True + + _ -> + R.zrange (scheduleQueue hw) 0 (-1) >>= + \case + Left err -> do + liftIO $ hwlog hw err + return False + + Right ls -> + case traverse A.decodeStrict ls :: Maybe [(JobRef, t)] of + Just scheduledJobs -> + return + $ any (\(JobRef _ _ c, _) -> c == Just cron) + $ scheduledJobs + + Nothing -> + return False + + -- | Adds a job to be added to the queue at the specified time. -- Returns whether the operation succeeded. @@ -469,7 +611,7 @@ queueScheduled hw j utc = do result <- runRedis (hworkerConnection hw) $ R.zadd (scheduleQueue hw) - $ [(utcToDouble utc, LB.toStrict $ A.encode (JobRef jobId Nothing, j))] + $ [(utcToDouble utc, LB.toStrict $ A.encode (JobRef jobId Nothing Nothing, j))] return $ isRight result @@ -487,7 +629,7 @@ queueBatch hw batch close js = mapM_ ( \j -> do jobId <- UUID.toText <$> liftIO UUID.nextRandom - let ref = JobRef jobId (Just batch) + let ref = JobRef jobId (Just batch) Nothing _ <- R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] -- Do the counting outside of the transaction, hence runRedis here. @@ -548,7 +690,7 @@ streamBatchTx hw batch close producer = Just j -> do jobId <- UUID.toText <$> liftIO UUID.nextRandom - let ref = JobRef jobId (Just batch) + let ref = JobRef jobId (Just batch) Nothing _ <- lift $ R.lpush (jobQueue hw) [LB.toStrict $ A.encode (ref, j)] -- Do the counting outside of the transaction, hence runRedis here. @@ -570,7 +712,6 @@ streamBatchTx hw batch close producer = $ R.multiExec run - withBatchQueue :: Job s t => Hworker s t -> BatchId -> IO (TxResult ()) -> IO QueueingResult withBatchQueue hw batch process = @@ -714,18 +855,23 @@ worker hw = delayAndRun - Just (JobRef _ maybeBatch, j) -> do + Just (JobRef _ maybeBatch maybeCron, j) -> + let + nextCron = + case maybeCron of + Just cron -> requeueCron hw cron j + Nothing -> return () + in do runJob (job hw j) >>= \case Success -> do when (hworkerDebug hw) $ hwlog hw ("JOB COMPLETE" :: Text, t) - case maybeBatch of Nothing -> do deletionResult <- runRedis (hworkerConnection hw) $ R.hdel (progressQueue hw) [t] - + nextCron case deletionResult of Left err -> hwlog hw err >> delayAndRun Right 1 -> justRun @@ -752,7 +898,8 @@ worker hw = [progressQueue hw, batchCounter hw batch] [t] ) - ( \hm -> + ( \hm -> do + nextCron case decodeBatchSummary batch hm of Nothing -> do hwlog hw ("Job done: did not delete 1" :: Text) @@ -835,6 +982,7 @@ worker hw = $ hworkerBatchCompleted hw ) + nextCron delayAndRun @@ -842,23 +990,49 @@ worker hw = -- started in a thread. This is responsible for pushing scheduled jobs -- to the queue at the expected time. -scheduler :: Job s t => Hworker s t -> IO () -scheduler hw = +scheduler :: forall s t . Job s t => Hworker s t -> IO () +scheduler hw = forever $ do now <- getCurrentTime runRedis (hworkerConnection hw) $ do - R.zcount (scheduleQueue hw) 0 (utcToDouble now) >>= + R.zrangebyscoreLimit (scheduleQueue hw) 0 (utcToDouble now) 0 5 >>= \case - Right n | n > 0 -> - withNil hw $ - R.eval - "local jobs = redis.call('zrangebyscore', KEYS[1], '0', ARGV[1])\n\ - \redis.call('lpush', KEYS[2], unpack(jobs))\n\ - \redis.call('zremrangebyscore', KEYS[1], '0', ARGV[1])\n\ - \return nil" - [scheduleQueue hw, jobQueue hw] - [B8.pack (show (utcToDouble now))] + Right ls | length ls > 0 -> + mapM_ + ( \l -> do + case A.decodeStrict l :: Maybe (JobRef, t) of + Nothing -> + liftIO + $ hwlog hw + $ "FAILED TO PARSE SCHEDULED JOB" <> show l + + Just j@(JobRef _ _ (Just cron), _) -> + withNil hw $ + R.eval + "redis.call('hset', KEYS[3], ARGV[2], ARGV[3])\n\ + \redis.call('lpush', KEYS[2], ARGV[1])\n\ + \redis.call('zrem', KEYS[1], ARGV[1])\n\ + \return nil" + [ scheduleQueue hw + , jobQueue hw + , cronProcessing hw + ] + [ LB.toStrict $ A.encode j + , T.encodeUtf8 cron + , LB.toStrict $ A.encode now + ] + + Just j -> + withNil hw $ + R.eval + "redis.call('lpush', KEYS[2], ARGV[1])\n\ + \redis.call('zrem', KEYS[1], ARGV[1])\n\ + \return nil" + [ scheduleQueue hw, jobQueue hw ] + [ LB.toStrict $ A.encode j ] + ) + ls Right _ -> return () @@ -937,7 +1111,7 @@ jobsFromQueue hw q = return [] Right xs -> - return $ mapMaybe (fmap (\(JobRef _ _, x) -> x) . A.decodeStrict) xs + return $ mapMaybe (fmap (\(JobRef _ _ _, x) -> x) . A.decodeStrict) xs -- | Returns all pending jobs. @@ -947,6 +1121,22 @@ jobs hw = jobsFromQueue hw (jobQueue hw) +-- | Returns all scheduled jobs + +scheduled :: Job s t => Hworker s t -> IO [t] +scheduled hw = + runRedis (hworkerConnection hw) (R.zrange (scheduleQueue hw) 0 (-1)) >>= + \case + Left err -> + hwlog hw err >> return [] + + Right [] -> + return [] + + Right xs -> + return $ mapMaybe (fmap (\(JobRef _ _ _, x) -> x) . A.decodeStrict) xs + + -- | Returns all failed jobs. This is capped at the most recent -- 'hworkerconfigFailedQueueSize' jobs that returned 'Failure' (or -- threw an exception when 'hworkerconfigExceptionBehavior' is @@ -1047,15 +1237,20 @@ withNil :: withNil hw a = a >>= \case - Left err -> liftIO $ hwlog hw err + Left err -> liftIO (hwlog hw err) Right _ -> return () runWithInt :: Hworker s t -> Redis (Either R.Reply Integer) -> IO Integer runWithInt hw a = - runRedis (hworkerConnection hw) a >>= + runRedis (hworkerConnection hw) $ withInt hw a + + +withInt :: Hworker s t -> Redis (Either R.Reply Integer) -> Redis Integer +withInt hw a = + a >>= \case - Left err -> hwlog hw err >> return (-1) + Left err -> liftIO (hwlog hw err) >> return (-1) Right n -> return n diff --git a/test/Spec.hs b/test/Spec.hs index 020a834..3cc6fa1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -18,6 +18,7 @@ import qualified Data.Text as T import Data.Time import qualified Database.Redis as Redis import GHC.Generics ( Generic) +import Saturn ( everyMinute ) import Test.Hspec import Test.HUnit ( assertEqual ) -------------------------------------------------------------------------------- @@ -503,6 +504,73 @@ main = hspec $ do killThread wthread killThread sthread + it "should queue cron on start up" $ do + mvar <- newMVar 0 + hworker <- + createWith + (conf "simpleworker-1" (SimpleState mvar)) + { hwconfigCronJobs = [CronJob "cron-test" SimpleJob everyMinute] } + + checkCron hworker "cron-test" >>= shouldBe True + ls <- scheduled hworker + length ls `shouldBe` 1 + destroy hworker + + it "should not enqueue the same job multiple times" $ do + mvar <- newMVar 0 + hworker <- + createWith + (conf "simpleworker-1" (SimpleState mvar)) + { hwconfigCronJobs = [CronJob "cron-test" SimpleJob everyMinute] } + + time <- getCurrentTime + initCron hworker time [CronJob "cron-test" SimpleJob everyMinute] + initCron hworker time [CronJob "cron-test" SimpleJob everyMinute] + initCron hworker time [CronJob "cron-test" SimpleJob everyMinute] + ls <- scheduled hworker + length ls `shouldBe` 1 + destroy hworker + + it "should add to processing hash once a cron job is pushed to the jobs queue" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + destroy hworker + sthread <- forkIO (scheduler hworker) + time <- getCurrentTime + initCron hworker (addUTCTime (-60) time) [CronJob "cron-test" SimpleJob everyMinute] + threadDelay 1000000 + s <- scheduled hworker + length s `shouldBe` 0 + j <- jobs hworker + length j `shouldBe` 1 + checkCron hworker "cron-test" >>= shouldBe True + destroy hworker + killThread sthread + + it "should remove from processing hash and re-enqueue once a cron job is executed" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + destroy hworker + time <- getCurrentTime + initCron hworker (addUTCTime (-60) time) [CronJob "cron-test" SimpleJob everyMinute] + wthread <- forkIO (worker hworker) + sthread <- forkIO (scheduler hworker) + threadDelay 1000000 + j <- jobs hworker + length j `shouldBe` 0 + s <- scheduled hworker + length s `shouldBe` 1 + liftIO + ( Redis.runRedis (hworkerConnection hworker) + $ Redis.hget "hworker-cron-processing-simpleworker-1" "cron-test" + ) >>= + \case + Right result -> result `shouldBe` Nothing + Left _ -> fail "cron prossessing not found" + destroy hworker + killThread wthread + killThread sthread + describe "Broken jobs" $ it "should store broken jobs" $ do -- NOTE(dbp 2015-08-09): The more common way this could @@ -691,7 +759,7 @@ instance Job RecurringState RecurringJob where return Success -conf :: Text -> s -> HworkerConfig s +conf :: Text -> s -> HworkerConfig s t conf n s = (defaultHworkerConfig n s) { hwconfigLogger = const (return ()) From 53a21429f399b731c703adaeaa72bb057a7ffac2 Mon Sep 17 00:00:00 2001 From: remeike Date: Tue, 15 Aug 2023 17:41:19 -0400 Subject: [PATCH 31/36] Fix example --- example/src/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/example/src/Main.hs b/example/src/Main.hs index 32566ca..c1f7dba 100644 --- a/example/src/Main.hs +++ b/example/src/Main.hs @@ -70,7 +70,7 @@ runCron = do hworker <- createWith (defaultHworkerConfig "printer" (State mvar)) - { hwconfigCronJobs = [CronJob "per-minute" PrintB Schedule.everyMinute] } + { hwconfigCronJobs = [CronJob "per-minute" PrintC Schedule.everyMinute] } _ <- forkIO (worker hworker) _ <- forkIO (monitor hworker) _ <- forkIO (scheduler hworker) From be3279cabe13301a9711240867e7020cf468a383 Mon Sep 17 00:00:00 2001 From: remeike Date: Tue, 15 Aug 2023 18:35:20 -0400 Subject: [PATCH 32/36] Add functions for reporting the state of queues --- src/System/Hworker.hs | 75 +++++++++++++++++++++++++++++++------------ test/Spec.hs | 63 +++++++++++++++++++++++------------- 2 files changed, 95 insertions(+), 43 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 43dd3b2..274af9e 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -81,9 +81,10 @@ module System.Hworker , requeueCron , checkCron -- * Inspecting Workers - , jobs - , failed - , scheduled + , listJobs + , listFailed + , listScheduled + , getCronProcessing , broken , batchSummary -- * Debugging Utilities @@ -1100,9 +1101,21 @@ broken hw = Right xs -> return (map (second parseTime) xs) -jobsFromQueue :: Job s t => Hworker s t -> ByteString -> IO [t] -jobsFromQueue hw q = - runRedis (hworkerConnection hw) (R.lrange q 0 (-1)) >>= +-- | Returns pending jobs. + +listJobs :: Job s t => Hworker s t -> Integer -> Integer -> IO [t] +listJobs hw offset limit = + listJobsFromQueue hw (jobQueue hw) offset limit + + +listJobsFromQueue :: + Job s t => Hworker s t -> ByteString -> Integer -> Integer -> IO [t] +listJobsFromQueue hw q offset limit = + let + a = offset * limit + b = (offset + 1) * limit - 1 + in + runRedis (hworkerConnection hw) (R.lrange q a b) >>= \case Left err -> hwlog hw err >> return [] @@ -1114,18 +1127,16 @@ jobsFromQueue hw q = return $ mapMaybe (fmap (\(JobRef _ _ _, x) -> x) . A.decodeStrict) xs --- | Returns all pending jobs. - -jobs :: Job s t => Hworker s t -> IO [t] -jobs hw = - jobsFromQueue hw (jobQueue hw) - - -- | Returns all scheduled jobs -scheduled :: Job s t => Hworker s t -> IO [t] -scheduled hw = - runRedis (hworkerConnection hw) (R.zrange (scheduleQueue hw) 0 (-1)) >>= +listScheduled :: + Job s t => Hworker s t -> Integer -> Integer -> IO [(t, UTCTime)] +listScheduled hw offset limit = + let + a = offset * limit + b = (offset + 1) * limit - 1 + in + runRedis (hworkerConnection hw) (R.zrangeWithscores (scheduleQueue hw) a b) >>= \case Left err -> hwlog hw err >> return [] @@ -1134,17 +1145,35 @@ scheduled hw = return [] Right xs -> - return $ mapMaybe (fmap (\(JobRef _ _ _, x) -> x) . A.decodeStrict) xs + return $ + mapMaybe + ( \(bytes, s) -> + case A.decodeStrict bytes of + Just (JobRef _ _ _, j) -> Just (j, doubleToUtc s) + Nothing -> Nothing + ) + xs --- | Returns all failed jobs. This is capped at the most recent +-- | Returns timestamp of active cron job. + +getCronProcessing :: + Job s t => Hworker s t -> Text -> IO (Maybe UTCTime) +getCronProcessing hw cron = + runRedis (hworkerConnection hw) (R.hget (cronProcessing hw) (T.encodeUtf8 cron)) >>= + \case + Right mbytes -> return $ mbytes >>= A.decodeStrict + Left _ -> return Nothing + + +-- | Returns failed jobs. This is capped at the most recent -- 'hworkerconfigFailedQueueSize' jobs that returned 'Failure' (or -- threw an exception when 'hworkerconfigExceptionBehavior' is -- 'FailOnException'). -failed :: Job s t => Hworker s t -> IO [t] -failed hw = - jobsFromQueue hw (failedQueue hw) +listFailed :: Job s t => Hworker s t -> Integer -> Integer -> IO [t] +listFailed hw offset limit = + listJobsFromQueue hw (failedQueue hw) offset limit -- | Logs the contents of the jobqueue and the inprogress queue at @@ -1308,3 +1337,7 @@ failBatchSummary hw batch = do utcToDouble :: UTCTime -> Double utcToDouble = realToFrac . Posix.utcTimeToPOSIXSeconds + + +doubleToUtc :: Double -> UTCTime +doubleToUtc = Posix.posixSecondsToUTCTime . realToFrac diff --git a/test/Spec.hs b/test/Spec.hs index 3cc6fa1..89d1de6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -140,7 +140,7 @@ main = hspec $ do queue hworker FailJob threadDelay 30000 killThread wthread - failedJobs <- failed hworker + failedJobs <- listFailed hworker 0 100 destroy hworker assertEqual "Should have failed job" [FailJob] failedJobs @@ -157,7 +157,7 @@ main = hspec $ do queue hworker AlwaysFailJob threadDelay 100000 killThread wthread - failedJobs <- failed hworker + failedJobs <- listFailed hworker 0 100 destroy hworker v <- takeMVar mvar assertEqual "State should be 4, since all jobs were run" 4 v @@ -309,7 +309,7 @@ main = hspec $ do streamBatch hworker batch True $ do replicateM_ 50 $ Conduit.yield SimpleJob return StreamingOk - ls <- jobs hworker + ls <- listJobs hworker 0 100 length ls `shouldBe` 50 summary <- expectBatchSummary hworker batch batchSummaryQueued summary `shouldBe` 50 @@ -323,7 +323,7 @@ main = hspec $ do streamBatch hworker batch True $ do replicateM_ 20 $ Conduit.yield SimpleJob return (StreamingAborted "abort") - ls <- jobs hworker + ls <- listJobs hworker 0 100 expectBatchSummary hworker batch destroy hworker length ls `shouldBe` 0 @@ -337,7 +337,7 @@ main = hspec $ do _ <- lift $ Redis.lpush "" [] replicateM_ 20 $ Conduit.yield SimpleJob return StreamingOk - ls <- jobs hworker + ls <- listJobs hworker 0 100 destroy hworker length ls `shouldBe` 0 @@ -349,7 +349,7 @@ main = hspec $ do streamBatch hworker batch True $ do replicateM_ 20 $ Conduit.yield SimpleJob return StreamingOk - ls <- jobs hworker + ls <- listJobs hworker 0 100 destroy hworker length ls `shouldBe` 0 @@ -370,7 +370,7 @@ main = hspec $ do threadDelay 190000 summary1 <- expectBatchSummary hworker batch batchSummaryQueued summary1 `shouldBe` 4 - ls <- jobs hworker + ls <- listJobs hworker 0 100 length ls `shouldBe` 0 threadDelay 100000 summary2 <- expectBatchSummary hworker batch @@ -512,7 +512,7 @@ main = hspec $ do { hwconfigCronJobs = [CronJob "cron-test" SimpleJob everyMinute] } checkCron hworker "cron-test" >>= shouldBe True - ls <- scheduled hworker + ls <- listScheduled hworker 0 100 length ls `shouldBe` 1 destroy hworker @@ -527,7 +527,7 @@ main = hspec $ do initCron hworker time [CronJob "cron-test" SimpleJob everyMinute] initCron hworker time [CronJob "cron-test" SimpleJob everyMinute] initCron hworker time [CronJob "cron-test" SimpleJob everyMinute] - ls <- scheduled hworker + ls <- listScheduled hworker 0 100 length ls `shouldBe` 1 destroy hworker @@ -539,11 +539,12 @@ main = hspec $ do time <- getCurrentTime initCron hworker (addUTCTime (-60) time) [CronJob "cron-test" SimpleJob everyMinute] threadDelay 1000000 - s <- scheduled hworker + s <- listScheduled hworker 0 100 length s `shouldBe` 0 - j <- jobs hworker + j <- listJobs hworker 0 100 length j `shouldBe` 1 checkCron hworker "cron-test" >>= shouldBe True + liftIO (getCronProcessing hworker "cron-test") >>= shouldNotBe Nothing destroy hworker killThread sthread @@ -556,21 +557,39 @@ main = hspec $ do wthread <- forkIO (worker hworker) sthread <- forkIO (scheduler hworker) threadDelay 1000000 - j <- jobs hworker + j <- listJobs hworker 0 100 length j `shouldBe` 0 - s <- scheduled hworker + s <- listScheduled hworker 0 100 length s `shouldBe` 1 - liftIO - ( Redis.runRedis (hworkerConnection hworker) - $ Redis.hget "hworker-cron-processing-simpleworker-1" "cron-test" - ) >>= - \case - Right result -> result `shouldBe` Nothing - Left _ -> fail "cron prossessing not found" + liftIO (getCronProcessing hworker "cron-test") >>= shouldBe Nothing destroy hworker killThread wthread killThread sthread + describe "Listing jobs" $ do + it "should list pending jobs" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + replicateM_ 45 (queue hworker SimpleJob) + listJobs hworker 0 10 >>= shouldBe 10 . length + listJobs hworker 1 10 >>= shouldBe 10 . length + listJobs hworker 2 10 >>= shouldBe 10 . length + listJobs hworker 3 10 >>= shouldBe 10 . length + listJobs hworker 4 10 >>= shouldBe 5 . length + destroy hworker + + it "should list scheduled jobs" $ do + mvar <- newMVar 0 + hworker <- createWith (conf "simpleworker-1" (SimpleState mvar)) + time <- getCurrentTime + replicateM_ 45 (queueScheduled hworker SimpleJob (addUTCTime 1 time)) + listScheduled hworker 0 10 >>= shouldBe 10 . length + listScheduled hworker 1 10 >>= shouldBe 10 . length + listScheduled hworker 2 10 >>= shouldBe 10 . length + listScheduled hworker 3 10 >>= shouldBe 10 . length + listScheduled hworker 4 10 >>= shouldBe 5 . length + destroy hworker + describe "Broken jobs" $ it "should store broken jobs" $ do -- NOTE(dbp 2015-08-09): The more common way this could @@ -596,7 +615,7 @@ main = hspec $ do mvar <- newMVar 0 hworker <- createWith (conf "dump-1" (SimpleState mvar)) { hwconfigTimeout = 5 } queue hworker SimpleJob - res <- jobs hworker + res <- listJobs hworker 0 100 destroy hworker assertEqual "Should be [SimpleJob]" [SimpleJob] res @@ -605,7 +624,7 @@ main = hspec $ do hworker <- createWith (conf "dump-2" (TimedState mvar)) { hwconfigTimeout = 5 } queue hworker (TimedJob 1) queue hworker (TimedJob 2) - res <- jobs hworker + res <- listJobs hworker 0 100 destroy hworker assertEqual "Should by [TimedJob 2, TimedJob 1]" [TimedJob 2, TimedJob 1] res From 0550461d66db0ea572c8b79a946728bf5b638d18 Mon Sep 17 00:00:00 2001 From: remeike Date: Mon, 22 Jul 2024 14:12:48 -0400 Subject: [PATCH 33/36] Use the same Job ID on recurring jobs to prevent duplication --- .gitignore | 1 + src/System/Hworker.hs | 56 ++++++++++++++++++++++--------------------- 2 files changed, 30 insertions(+), 27 deletions(-) diff --git a/.gitignore b/.gitignore index bc2b1be..3e91d5a 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ dist-stack stack.yaml.lock dist-newstyle cabal.project.local +.DS_Store diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 274af9e..ddbd2d2 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -482,6 +482,11 @@ cronProcessing hw = "hworker-cron-processing-" <> hworkerName hw +cronId :: Text -> Text +cronId cron = + "cron:" <> cron + + -- | Adds a job to the queue. Returns whether the operation succeeded. queue :: Job s t => Hworker s t -> t -> IO Bool @@ -508,20 +513,14 @@ initCron hw time cronJobs = do ) cronJobs - mapM_ - ( \cron@(CronJob name _ _) -> do - exists <- checkCron hw name - when (not exists) $ void $ queueCron hw time cron - ) - cronJobs + mapM_ (queueCron hw time) cronJobs -- | Queues a cron job for the first time, adding it to the schedule queue -- at its next scheduled time. queueCron :: Job s t => Hworker s t -> UTCTime -> CronJob t -> IO Bool -queueCron hw time (CronJob cron j schedule) = do - jobId <- UUID.toText <$> UUID.nextRandom +queueCron hw time (CronJob cron j schedule) = case Schedule.nextMatch time schedule of Nothing -> return False @@ -530,7 +529,7 @@ queueCron hw time (CronJob cron j schedule) = do result <- runRedis (hworkerConnection hw) $ R.zadd (scheduleQueue hw) $ [ ( utcToDouble utc - , LB.toStrict $ A.encode (JobRef jobId Nothing (Just cron), j) + , LB.toStrict $ A.encode (JobRef (cronId cron) Nothing (Just cron), j) ) ] return $ isRight result @@ -540,8 +539,7 @@ queueCron hw time (CronJob cron j schedule) = do -- and adding it back to the schedule queue at its next scheduled time. requeueCron :: Job s t => Hworker s t -> Text -> t -> IO () -requeueCron hw cron j = do - jobId <- UUID.toText <$> UUID.nextRandom +requeueCron hw cron j = runRedis (hworkerConnection hw) $ do void $ withInt hw $ R.hdel (cronProcessing hw) [T.encodeUtf8 cron] R.hget (cronSchedule hw) (T.encodeUtf8 cron) >>= @@ -569,7 +567,7 @@ requeueCron hw cron j = do Just utc -> void $ withInt hw $ R.zadd (scheduleQueue hw) $ [ ( utcToDouble utc - , LB.toStrict $ A.encode (JobRef jobId Nothing (Just cron), j) + , LB.toStrict $ A.encode (JobRef (cronId cron) Nothing (Just cron), j) ) ] @@ -1008,21 +1006,25 @@ scheduler hw = $ hwlog hw $ "FAILED TO PARSE SCHEDULED JOB" <> show l - Just j@(JobRef _ _ (Just cron), _) -> - withNil hw $ - R.eval - "redis.call('hset', KEYS[3], ARGV[2], ARGV[3])\n\ - \redis.call('lpush', KEYS[2], ARGV[1])\n\ - \redis.call('zrem', KEYS[1], ARGV[1])\n\ - \return nil" - [ scheduleQueue hw - , jobQueue hw - , cronProcessing hw - ] - [ LB.toStrict $ A.encode j - , T.encodeUtf8 cron - , LB.toStrict $ A.encode now - ] + Just j@(JobRef ref _ (Just cron), _) -> + -- TODO: deprecate this eventually + if ref == cronId cron then + withNil hw $ + R.eval + "redis.call('hset', KEYS[3], ARGV[2], ARGV[3])\n\ + \redis.call('lpush', KEYS[2], ARGV[1])\n\ + \redis.call('zrem', KEYS[1], ARGV[1])\n\ + \return nil" + [ scheduleQueue hw + , jobQueue hw + , cronProcessing hw + ] + [ LB.toStrict $ A.encode j + , T.encodeUtf8 cron + , LB.toStrict $ A.encode now + ] + else + return () Just j -> withNil hw $ From edb30130c9993907d39605b896a833cb82a9e4f1 Mon Sep 17 00:00:00 2001 From: remeike Date: Tue, 23 Jul 2024 14:35:32 -0400 Subject: [PATCH 34/36] Remove unused scheduled items --- src/System/Hworker.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index ddbd2d2..9497651 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -1024,7 +1024,7 @@ scheduler hw = , LB.toStrict $ A.encode now ] else - return () + void $ R.zrem (scheduleQueue hw) [LB.toStrict $ A.encode j] Just j -> withNil hw $ From 6e9c2305556f91f819210659067a4799e7916feb Mon Sep 17 00:00:00 2001 From: remeike Date: Tue, 23 Jul 2024 16:40:29 -0400 Subject: [PATCH 35/36] Run the scheduler inside a single lua script --- src/System/Hworker.hs | 70 +++++++++++++------------------------------ 1 file changed, 20 insertions(+), 50 deletions(-) diff --git a/src/System/Hworker.hs b/src/System/Hworker.hs index 9497651..83c26cd 100644 --- a/src/System/Hworker.hs +++ b/src/System/Hworker.hs @@ -994,54 +994,25 @@ scheduler hw = forever $ do now <- getCurrentTime - runRedis (hworkerConnection hw) $ do - R.zrangebyscoreLimit (scheduleQueue hw) 0 (utcToDouble now) 0 5 >>= - \case - Right ls | length ls > 0 -> - mapM_ - ( \l -> do - case A.decodeStrict l :: Maybe (JobRef, t) of - Nothing -> - liftIO - $ hwlog hw - $ "FAILED TO PARSE SCHEDULED JOB" <> show l - - Just j@(JobRef ref _ (Just cron), _) -> - -- TODO: deprecate this eventually - if ref == cronId cron then - withNil hw $ - R.eval - "redis.call('hset', KEYS[3], ARGV[2], ARGV[3])\n\ - \redis.call('lpush', KEYS[2], ARGV[1])\n\ - \redis.call('zrem', KEYS[1], ARGV[1])\n\ - \return nil" - [ scheduleQueue hw - , jobQueue hw - , cronProcessing hw - ] - [ LB.toStrict $ A.encode j - , T.encodeUtf8 cron - , LB.toStrict $ A.encode now - ] - else - void $ R.zrem (scheduleQueue hw) [LB.toStrict $ A.encode j] - - Just j -> - withNil hw $ - R.eval - "redis.call('lpush', KEYS[2], ARGV[1])\n\ - \redis.call('zrem', KEYS[1], ARGV[1])\n\ - \return nil" - [ scheduleQueue hw, jobQueue hw ] - [ LB.toStrict $ A.encode j ] - ) - ls - - Right _ -> - return () - - Left err -> - liftIO $ hwlog hw err + runRedis (hworkerConnection hw) $ + withNil hw $ + R.eval + "local job = redis.call('zrangebyscore', KEYS[1], 0, ARGV[1], 'limit', 0, 1)[1]\n\ + \if job ~= nil then\n\ + \ redis.call('lpush', KEYS[2], tostring(job))\n\ + \ redis.call('zrem', KEYS[1], tostring(job))\n\ + \ local cron = cjson.decode(job)[1]['s']\n\ + \ if cron ~= cjson.null then\n\ + \ redis.call('hset', KEYS[3], tostring(cron), ARGV[1])\n\ + \ return tostring(cron) \n\ + \ end\n\ + \end\n\ + \return nil" + [ scheduleQueue hw + , jobQueue hw + , cronProcessing hw + ] + [ B8.pack $ show (utcToDouble now) ] threadDelay 500000 >> scheduler hw @@ -1159,8 +1130,7 @@ listScheduled hw offset limit = -- | Returns timestamp of active cron job. -getCronProcessing :: - Job s t => Hworker s t -> Text -> IO (Maybe UTCTime) +getCronProcessing :: Job s t => Hworker s t -> Text -> IO (Maybe Double) getCronProcessing hw cron = runRedis (hworkerConnection hw) (R.hget (cronProcessing hw) (T.encodeUtf8 cron)) >>= \case From f344dcc8ab7dded04ce7ae5e615f0b7b47b73295 Mon Sep 17 00:00:00 2001 From: Libby Horacek Date: Mon, 30 Dec 2024 15:47:26 -0500 Subject: [PATCH 36/36] Bump version --- CHANGELOG.md | 4 ++++ hworker.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3f81095..f06068f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +* 0.4.0 Libby Horacek 2024-12-30 + + Bump version due to breaking changes + * 0.3.0 Remeike Forbes 2022-11-23 Introduce batched jobs diff --git a/hworker.cabal b/hworker.cabal index eb0b091..66d1f19 100644 --- a/hworker.cabal +++ b/hworker.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hworker -version: 0.3.0 +version: 0.4.0 synopsis: A reliable at-least-once job queue built on top of redis. description: See README. homepage: http://github.com/positiondev/hworker