diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,202 +1,19 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS - - APPENDIX: How to apply the Apache License to your work. - - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. - - Copyright [yyyy] [name of copyright owner] +Copyright (c) 2014 Alexander Thiemann - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: - http://www.apache.org/licenses/LICENSE-2.0 +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Spock-worker.cabal b/Spock-worker.cabal --- a/Spock-worker.cabal +++ b/Spock-worker.cabal @@ -1,48 +1,51 @@ name: Spock-worker -version: 0.2.1.0 +version: 0.2.1.2 synopsis: Background workers for Spock description: Adds a background-job queue to Spock homepage: http://github.com/agrafix/Spock-worker -license: Apache-2.0 +license: MIT license-file: LICENSE -author: Alexander Thiemann -maintainer: mail@agrafix.net +author: Alexander Thiemann +maintainer: mail@athiemann.net copyright: (c) 2014 Alexander Thiemann category: Web build-type: Simple cabal-version: >=1.10 +tested-with: GHC==7.6.3, GHC==7.8.3 library - exposed-modules: Web.Spock.Worker - other-modules: Web.Spock.Worker.Queue + exposed-modules: + Web.Spock.Worker, + Web.Spock.Worker.Internal.Queue + other-modules: hs-source-dirs: src default-language: Haskell2010 - 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, - containers ==0.5.*, + build-depends: + Spock >=0.7.2, + base >=4.6 && < 5, + containers >=0.5, + lifted-base, mtl, + stm >=2.4, + text >=0.11.3.1, + time >=1.4, transformers, - lifted-base + vector >=0.10 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 + main-is: Tests.hs + hs-source-dirs: test default-language: Haskell2010 - 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, - containers ==0.5.*, - mtl, - transformers, - lifted-base + build-depends: + HTF >=0.12.2.1, + Spock-worker, + base >=4.6 && < 5, + containers, + stm, + vector + +source-repository head + type: git + location: git://github.com/agrafix/Spock-worker.git 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 @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} {-# LANGUAGE RankNTypes, ScopedTypeVariables, OverloadedStrings #-} module Web.Spock.Worker ( -- * Worker @@ -12,24 +11,18 @@ , WorkResult (..) -- * Error Handeling , ErrorHandler(..), InternalError - -- * Tests - , htf_thisModulesTests ) where -import Test.Framework - import Control.Concurrent import Control.Concurrent.STM - import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Error import Control.Exception.Lifted as EX - import Data.Time import Web.Spock.Shared -import qualified Web.Spock.Worker.Queue as Q +import qualified Web.Spock.Worker.Internal.Queue as Q type InternalError = String diff --git a/src/Web/Spock/Worker/Internal/Queue.hs b/src/Web/Spock/Worker/Internal/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Web/Spock/Worker/Internal/Queue.hs @@ -0,0 +1,109 @@ +module Web.Spock.Worker.Internal.Queue where + +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Data.Maybe +import qualified Data.Map.Strict as M +import qualified Data.Vector as V + +data PureQueue p v + = PureQueue + { pq_container :: !(M.Map p (V.Vector v)) + , pq_maxSize :: !Int + } deriving (Show, Eq) + +emptyPQ :: Int -> PureQueue p v +emptyPQ maxQueueSize = + PureQueue M.empty maxQueueSize + +sizePQ :: PureQueue p v -> Int +sizePQ (PureQueue m _) = + M.size m + +isFullPQ :: PureQueue p v -> Bool +isFullPQ pq = + sizePQ pq >= (pq_maxSize pq) + +toListPQ :: Ord p => PureQueue p v -> [(p, [v])] +toListPQ (PureQueue m _) = + map (\(k, v) -> (k, V.toList v)) (M.toList m) + +fromListPQ :: Ord p => Int -> [(p, [v])] -> Maybe (PureQueue p v) +fromListPQ limit kv + | length kv > limit = Nothing + | otherwise = + Just $ + foldl (\(PureQueue content _) (k, v) -> + (PureQueue (M.insert k (V.fromList v) content) limit) + ) (emptyPQ limit) kv + +maxPrioPQ :: Ord p => PureQueue p v -> p +maxPrioPQ (PureQueue m _) = + fst (M.findMax m) + +enqueuePQ :: Ord p => p -> v -> PureQueue p v -> (Bool, PureQueue p v) +enqueuePQ prio value pq@(PureQueue m _) = + if isFullPQ pq + then ( False, pq ) + else ( True + , pq + { pq_container = + M.insertWith (V.++) prio (V.singleton value) m + } + ) + +dequeuePQ :: Ord p => p -> PureQueue p v -> (Maybe v, PureQueue p v) +dequeuePQ bound pq = + removePrio $ dequeuePQ' bound pq + where + removePrio (Nothing, q) = (Nothing, 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 _) + | M.null m = (Nothing, pq) + | minK > prioBound = (Nothing, pq) + | otherwise = + case V.toList vec of + [workEl] -> + (Just (minK, workEl), updatePQ (M.delete minK)) + (workEl:xs) -> + (Just (minK, workEl), updatePQ (M.adjust (const (V.fromList xs)) minK)) + [] -> + error "Library-Error: This should never happen." + where + (minK, vec) = + M.findMin m + updatePQ fun = + pq { pq_container = fun (pq_container pq) } + +newtype WorkerQueue p v = + WorkerQueue (TVar (PureQueue p v)) + +newQueue :: Int -> IO (WorkerQueue p v) +newQueue limit = + WorkerQueue <$> newTVarIO (emptyPQ limit) + +size :: WorkerQueue p v -> STM Int +size (WorkerQueue qVar) = + readTVar qVar >>= (return . sizePQ) + +isFull :: WorkerQueue p v -> STM Bool +isFull (WorkerQueue qVar) = + readTVar qVar >>= (return . isFullPQ) + +enqueue :: Ord p => p -> v -> WorkerQueue p v -> STM () +enqueue prio value (WorkerQueue qVar) = + do q <- readTVar qVar + let (ok, newQ) = enqueuePQ prio value q + if ok + then writeTVar qVar newQ + else retry + +dequeue :: Ord p => p -> WorkerQueue p v -> STM (Maybe v) +dequeue minP (WorkerQueue qVar) = + do q <- readTVar qVar + let (mVal, newQ) = dequeuePQ minP q + when (isJust mVal) $ writeTVar qVar newQ + return mVal diff --git a/src/Web/Spock/Worker/Queue.hs b/src/Web/Spock/Worker/Queue.hs deleted file mode 100644 --- a/src/Web/Spock/Worker/Queue.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Web.Spock.Worker.Queue - ( WorkerQueue, newQueue, size, enqueue, dequeue, isFull - , toListPQ, fromListPQ - , htf_thisModulesTests - ) -where - -import Test.Framework - -import Control.Monad -import Control.Concurrent.STM -import Control.Applicative -import Data.Maybe - -import qualified Data.Map.Strict as M -import qualified Data.Vector as V - -data PureQueue p v - = PureQueue - { pq_container :: !(M.Map p (V.Vector v)) - , pq_maxSize :: !Int - } deriving (Show, Eq) - -emptyPQ :: Int -> PureQueue p v -emptyPQ maxQueueSize = - PureQueue M.empty maxQueueSize - -sizePQ :: PureQueue p v -> Int -sizePQ (PureQueue m _) = - M.size m - -isFullPQ :: PureQueue p v -> Bool -isFullPQ pq = - sizePQ pq >= (pq_maxSize pq) - -toListPQ :: Ord p => PureQueue p v -> [(p, [v])] -toListPQ (PureQueue m _) = - map (\(k, v) -> (k, V.toList v)) (M.toList m) - -fromListPQ :: Ord p => Int -> [(p, [v])] -> Maybe (PureQueue p v) -fromListPQ limit kv - | length kv > limit = Nothing - | otherwise = - Just $ - foldl (\(PureQueue content _) (k, v) -> - (PureQueue (M.insert k (V.fromList v) content) limit) - ) (emptyPQ limit) kv - -maxPrioPQ :: Ord p => PureQueue p v -> p -maxPrioPQ (PureQueue m _) = - fst (M.findMax m) - -enqueuePQ :: Ord p => p -> v -> PureQueue p v -> (Bool, PureQueue p v) -enqueuePQ prio value pq@(PureQueue m _) = - if isFullPQ pq - then ( False, pq ) - else ( True - , pq - { pq_container = - M.insertWith (V.++) prio (V.singleton value) m - } - ) - -dequeuePQ :: Ord p => p -> PureQueue p v -> (Maybe v, PureQueue p v) -dequeuePQ bound pq = - removePrio $ dequeuePQ' bound pq - where - removePrio (Nothing, q) = (Nothing, 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 _) - | M.null m = (Nothing, pq) - | minK > prioBound = (Nothing, pq) - | otherwise = - case V.toList vec of - [workEl] -> - (Just (minK, workEl), updatePQ (M.delete minK)) - (workEl:xs) -> - (Just (minK, workEl), updatePQ (M.adjust (const (V.fromList xs)) minK)) - [] -> - error "Library-Error: This should never happen." - where - (minK, vec) = - M.findMin m - updatePQ fun = - pq { pq_container = fun (pq_container pq) } - -newtype WorkerQueue p v = - WorkerQueue (TVar (PureQueue p v)) - -newQueue :: Int -> IO (WorkerQueue p v) -newQueue limit = - WorkerQueue <$> newTVarIO (emptyPQ limit) - -size :: WorkerQueue p v -> STM Int -size (WorkerQueue qVar) = - readTVar qVar >>= (return . sizePQ) - -isFull :: WorkerQueue p v -> STM Bool -isFull (WorkerQueue qVar) = - readTVar qVar >>= (return . isFullPQ) - -enqueue :: Ord p => p -> v -> WorkerQueue p v -> STM () -enqueue prio value (WorkerQueue qVar) = - do q <- readTVar qVar - let (ok, newQ) = enqueuePQ prio value q - if ok - then writeTVar qVar newQ - else retry - -dequeue :: Ord p => p -> WorkerQueue p v -> STM (Maybe v) -dequeue minP (WorkerQueue qVar) = - do q <- readTVar qVar - let (mVal, newQ) = dequeuePQ minP q - when (isJust mVal) $ writeTVar qVar newQ - return mVal - --- ------------- --- 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 - | otherwise = - let (mVal, newQ) = dequeuePQ' maxP q - in case mVal of - Nothing -> - 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 - in if ok then newPQ else (error "Failed to enqueue!") - ) (emptyPQ (length xs)) xs - 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 - mPq = fromListPQ limit (xs' :: [(Int, [Int])]) - in case mPq of - Just pq -> - if limit == (length xs') - then isFullPQ pq - else limit > (length xs') - Nothing -> - limit < (length xs') - -test_dontEnqueueIfFull :: IO () -test_dontEnqueueIfFull = - let pq = emptyPQ 0 - (ok, newPQ) = enqueuePQ (0 :: Int) False pq - in do assertBool (not ok) - assertEqual pq newPQ diff --git a/src/Web/Spock/Worker/Tests.hs b/src/Web/Spock/Worker/Tests.hs deleted file mode 100644 --- a/src/Web/Spock/Worker/Tests.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF htfpp #-} - -module Main where - -import Test.Framework -import {-@ HTF_TESTS @-} Web.Spock.Worker.Queue -import {-@ HTF_TESTS @-} Web.Spock.Worker - -main = htfMain htf_importedTests diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +module Main where + +import Test.Framework +import {-@ HTF_TESTS @-} Web.Spock.Worker.Internal.QueueTests + +main = htfMain htf_importedTests