Spock-worker 0.2.0.0 → 0.2.1.0
raw patch · 3 files changed
+38/−29 lines, 3 filesdep ~HTFdep ~Spockdep ~text
Dependency ranges changed: HTF, Spock, text
Files
- Spock-worker.cabal +10/−9
- src/Web/Spock/Worker.hs +7/−7
- src/Web/Spock/Worker/Queue.hs +21/−13
Spock-worker.cabal view
@@ -1,5 +1,5 @@ name: Spock-worker-version: 0.2.0.0+version: 0.2.1.0 synopsis: Background workers for Spock description: Adds a background-job queue to Spock homepage: http://github.com/agrafix/Spock-worker@@ -17,10 +17,10 @@ other-modules: Web.Spock.Worker.Queue hs-source-dirs: src default-language: Haskell2010- build-depends: base >=4.6 && <4.7,- Spock >=0.4.2.4 && <0.7,- HTF ==0.11.2.*,- text >=0.11.3.1 && <1.2,+ build-depends: base >=4.6 && <4.8,+ Spock >=0.7.2 && <0.8,+ HTF >=0.12.2.1 && <0.13,+ text >=0.11.3.1 && <1.3, time >=1.4 && <1.5, stm >=2.4 && <2.5, vector >=0.10 && <0.11,@@ -28,16 +28,17 @@ mtl, transformers, lifted-base+ ghc-options: -Wall -fno-warn-orphans test-suite SpockWorkerTests type: exitcode-stdio-1.0 main-is: Web/Spock/Worker/Tests.hs hs-source-dirs: src default-language: Haskell2010- build-depends: base >=4.6 && <4.7,- Spock >=0.4.2.4 && <0.7,- HTF ==0.11.2.*,- text >=0.11.3.1 && <1.2,+ build-depends: base >=4.6 && <4.8,+ Spock >=0.7.2 && <0.8,+ HTF >=0.12.2.1 && <0.13,+ text >=0.11.3.1 && <1.3, time >=1.4 && <1.5, stm >=2.4 && <2.5, vector >=0.10 && <0.11,
src/Web/Spock/Worker.hs view
@@ -26,10 +26,9 @@ import Control.Monad.Trans import Control.Monad.Trans.Error import Control.Exception.Lifted as EX-import Control.Exception import Data.Time-import Web.Spock+import Web.Spock.Shared import qualified Web.Spock.Worker.Queue as Q type InternalError = String@@ -46,7 +45,7 @@ -- | The queue containing scheduled jobs newtype WorkQueue a- = WorkQueue { unWorkQueue :: Q.WorkerQueue UTCTime a }+ = WorkQueue { _unWorkQueue :: Q.WorkerQueue UTCTime a } -- | Describes when a job should be executed data WorkExecution@@ -77,14 +76,15 @@ } -- | Create a new background worker and limit the size of the job queue.-newWorker :: WorkerConfig+newWorker :: (MonadTrans t, Monad (t (WebStateM conn sess st)))+ => WorkerConfig -> WorkHandler conn sess st a -> ErrorHandler conn sess st a- -> SpockM conn sess st (WorkQueue a)+ -> t (WebStateM conn sess st) (WorkQueue a) newWorker wc workHandler errorHandler = do heart <- getSpockHeart- q <- liftIO $ Q.newQueue (wc_queueLimit wc)- _ <- liftIO $ forkIO (workProcessor q workHandler errorHandler heart (wc_concurrent wc))+ q <- lift . liftIO $ Q.newQueue (wc_queueLimit wc)+ _ <- lift . liftIO $ forkIO (workProcessor q workHandler errorHandler heart (wc_concurrent wc)) return (WorkQueue q) workProcessor :: Q.WorkerQueue UTCTime a
src/Web/Spock/Worker/Queue.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Web.Spock.Worker.Queue ( WorkerQueue, newQueue, size, enqueue, dequeue, isFull+ , toListPQ, fromListPQ , htf_thisModulesTests ) where@@ -9,11 +10,8 @@ import Test.Framework import Control.Monad-import Control.Concurrent import Control.Concurrent.STM import Control.Applicative-import Data.List (sortBy)-import Data.Ord (comparing) import Data.Maybe import qualified Data.Map.Strict as M@@ -21,24 +19,24 @@ data PureQueue p v = PureQueue- { pq_container :: M.Map p (V.Vector v)- , pq_maxSize :: Int- }+ { pq_container :: !(M.Map p (V.Vector v))+ , pq_maxSize :: !Int+ } deriving (Show, Eq) emptyPQ :: Int -> PureQueue p v-emptyPQ maxSize =- PureQueue M.empty maxSize+emptyPQ maxQueueSize =+ PureQueue M.empty maxQueueSize sizePQ :: PureQueue p v -> Int sizePQ (PureQueue m _) = M.size m isFullPQ :: PureQueue p v -> Bool-isFullPQ pq@(PureQueue _ maxSize) =- sizePQ pq >= maxSize+isFullPQ pq =+ sizePQ pq >= (pq_maxSize pq) toListPQ :: Ord p => PureQueue p v -> [(p, [v])]-toListPQ pq@(PureQueue m _) =+toListPQ (PureQueue m _) = map (\(k, v) -> (k, V.toList v)) (M.toList m) fromListPQ :: Ord p => Int -> [(p, [v])] -> Maybe (PureQueue p v)@@ -70,7 +68,7 @@ removePrio $ dequeuePQ' bound pq where removePrio (Nothing, q) = (Nothing, q)- removePrio (Just (p, v), q) = (Just v, q)+ removePrio (Just (_, v), q) = (Just v, q) dequeuePQ' :: Ord p => p -> PureQueue p v -> (Maybe (p, v), PureQueue p v) dequeuePQ' prioBound pq@(PureQueue m _)@@ -124,8 +122,11 @@ -- TESTS -- ------------- +tAddToMap :: Ord k => k -> a -> M.Map k [a] -> M.Map k [a] tAddToMap k val m = M.insertWith (++) k [val] m++tDeq :: Ord k => k -> PureQueue k a -> M.Map k [a] tDeq maxP q | sizePQ q == 0 = M.empty@@ -136,11 +137,14 @@ M.empty Just (k, val) -> tAddToMap k val (tDeq maxP newQ)++tMappifyInput :: Ord k => [(k, a)] -> M.Map k [a] tMappifyInput xs = foldl (\m (k, v) -> tAddToMap k v m ) M.empty xs +prop_enqueueDequeuePQ :: [(Int, Int)] -> Bool prop_enqueueDequeuePQ xs = let pq = foldl (\q (prio :: Int, el :: Int) -> let (ok, newPQ) = enqueuePQ prio el q@@ -149,12 +153,14 @@ maxP = maxPrioPQ pq in (tMappifyInput xs == tDeq maxP pq) +prop_onlyDequeueBelowPrio :: Int -> [(Int, Int)] -> Bool prop_onlyDequeueBelowPrio prio xs = let xs' = M.toList $ tMappifyInput xs Just pq = fromListPQ (length xs) (xs' :: [(Int, [Int])]) filtered = filter (\(p, _) -> p <= prio) xs in (tMappifyInput filtered == tDeq prio pq) +prop_isFull :: Int -> [(Int, Int)] -> Property prop_isFull limit xs = limit > 0 ==> let xs' = M.toList $ tMappifyInput xs@@ -167,7 +173,9 @@ Nothing -> limit < (length xs') +test_dontEnqueueIfFull :: IO () test_dontEnqueueIfFull = let pq = emptyPQ 0 (ok, newPQ) = enqueuePQ (0 :: Int) False pq- in assertBool (not ok)+ in do assertBool (not ok)+ assertEqual pq newPQ