diff --git a/Spock-worker.cabal b/Spock-worker.cabal --- a/Spock-worker.cabal +++ b/Spock-worker.cabal @@ -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, diff --git a/src/Web/Spock/Worker.hs b/src/Web/Spock/Worker.hs --- a/src/Web/Spock/Worker.hs +++ b/src/Web/Spock/Worker.hs @@ -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 diff --git a/src/Web/Spock/Worker/Queue.hs b/src/Web/Spock/Worker/Queue.hs --- a/src/Web/Spock/Worker/Queue.hs +++ b/src/Web/Spock/Worker/Queue.hs @@ -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