├── .gitignore ├── .travis.yml ├── README.md ├── jobqueue-examples ├── LICENSE ├── fibonacci.hs ├── hello.hs ├── jobqueue-examples.cabal ├── priority.hs └── suspend.hs ├── jobqueue ├── LICENSE ├── Setup.hs ├── jobqueue.cabal ├── src │ └── Network │ │ ├── JobQueue.hs │ │ └── JobQueue │ │ ├── Action.hs │ │ ├── AuxClass.hs │ │ ├── Backend.hs │ │ ├── Backend │ │ ├── Class.hs │ │ ├── Sqlite3.hs │ │ ├── Types.hs │ │ ├── Zookeeper.hs │ │ └── Zookeeper │ │ │ └── ZookeeperQueue.hs │ │ ├── Class.hs │ │ ├── Job.hs │ │ ├── Job │ │ └── Internal.hs │ │ ├── JobQueue.hs │ │ ├── JobQueue │ │ └── Internal.hs │ │ ├── Logger.hs │ │ ├── Param.hs │ │ ├── Types.hs │ │ └── Util.hs └── test │ ├── Action.hs │ ├── BackendQueue.hs │ ├── JobQueue.hs │ └── Main.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.sandbox.config 2 | .cabal-sandbox 3 | dist 4 | cabal-dev 5 | .stack-work/ 6 | *.o 7 | *.hi 8 | *.chi 9 | *.chs.h 10 | *~ 11 | \#*\# 12 | .\#* 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | env: 2 | - GHCVER=7.6.3 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="sqlite3://test.sqlite3" MONAD_CONTROL_VERSION="<= 0.3.3.0" 3 | - GHCVER=7.6.3 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="zookeeper://localhost:2181" MONAD_CONTROL_VERSION="<= 0.3.3.0" 4 | - GHCVER=7.6.3 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="sqlite3://test.sqlite3" 5 | - GHCVER=7.6.3 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="zookeeper://localhost:2181" 6 | - GHCVER=7.8.2 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="sqlite3://test.sqlite3" 7 | - GHCVER=7.8.2 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="zookeeper://localhost:2181" 8 | - GHCVER=7.8.3 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="sqlite3://test.sqlite3" MONAD_CONTROL_VERSION="<= 0.3.3.0" 9 | - GHCVER=7.8.3 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="zookeeper://localhost:2181" MONAD_CONTROL_VERSION="<= 0.3.3.0" 10 | - GHCVER=7.8.3 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="sqlite3://test.sqlite3" 11 | - GHCVER=7.8.3 CABALVER=1.18 JOBQUEUE_TEST_BACKEND="zookeeper://localhost:2181" 12 | - GHCVER=7.10.2 CABALVER=1.22 JOBQUEUE_TEST_BACKEND="sqlite3://test.sqlite3" MONAD_CONTROL_VERSION="<= 0.3.3.0" 13 | - GHCVER=7.10.2 CABALVER=1.22 JOBQUEUE_TEST_BACKEND="zookeeper://localhost:2181" MONAD_CONTROL_VERSION="<= 0.3.3.0" 14 | - GHCVER=7.10.2 CABALVER=1.22 JOBQUEUE_TEST_BACKEND="sqlite3://test.sqlite3" 15 | - GHCVER=7.10.2 CABALVER=1.22 JOBQUEUE_TEST_BACKEND="zookeeper://localhost:2181" 16 | 17 | before_install: 18 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 19 | - travis_retry sudo apt-add-repository ppa:nikicat/zookeeper -y 20 | - travis_retry sudo apt-get update 21 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER 22 | - travis_retry sudo apt-get install libzookeeper-mt-dev 23 | - travis_retry sudo apt-get install zookeeperd 24 | - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 25 | - cd jobqueue 26 | 27 | install: 28 | - cabal update 29 | - cabal sandbox init 30 | - cabal install hpc-coveralls --bindir=$HOME/.cabal/bin/ 31 | - cabal sandbox delete 32 | - cabal install happy 33 | - cabal install 'double-conversion < 1' 34 | - cabal install "monad-control ${MONAD_CONTROL_VERSION}" 35 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --extra-include-dirs=/usr/include/zookeeper 36 | 37 | script: 38 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 39 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 40 | - cabal test 41 | - cat dist/test/*.log 42 | - cabal check 43 | - cabal sdist # tests that a source-distribution can be generated 44 | 45 | - export SRC_TGZ=$(cabal-$CABALVER info . | awk '{print $2 ".tar.gz";exit}') ; 46 | cd dist/; 47 | if [ -f "$SRC_TGZ" ]; then 48 | cabal install "$SRC_TGZ"; 49 | else 50 | echo "expected '$SRC_TGZ' not found"; 51 | exit 1; 52 | fi 53 | 54 | after_script: 55 | - cd .. 56 | - cabal clean 57 | - cabal configure --enable-tests -v2 --enable-library-coverage # -v2 provides useful information for debugging 58 | - cabal build 59 | - cabal test 60 | - hpc-coveralls --exclude-dir=test test 61 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | Haskell JobQueue 3 | ================ 4 | 5 | JobQueue is a simple job queue library based on prioritized FCFS scheduling. 6 | This is useful when you want to write a reliable batch system. 7 | 8 | How to install 9 | -------------- 10 | 11 | Execute the cabal install command and the library and example programs will be placed into your .cabal directory. 12 | 13 | > cd haskell-jobqueue/ 14 | > cabal install jobqueue/ --only-dependencies --extra-include-dirs=/usr/local/include/zookeeper # if you use brew on Mac OSX 15 | > cabal install jobqueue/ jobqueue-examples/ 16 | 17 | How to use 18 | ---------- 19 | 20 | ### Backend 21 | 22 | Various backends can be plugged in for use with this library. You can select the backend you wish to use depending on your needs. For example, one may choose Zookeeper for the backend if high availability is a requirement, or one may choose sqlite3 as their backend for a standalone tool. 23 | 24 | * Zookeeper 25 | * Sqlite3 26 | 27 | ### Hello, world 28 | 29 | Import JobQueue module in your source file. 30 | 31 | ```haskell 32 | {-# LANGUAGE LambdaCase #-} 33 | 34 | import Control.Monad 35 | import System.Environment hiding (getEnv) 36 | import Network.JobQueue 37 | ``` 38 | 39 | Define your environment data type. 40 | 41 | ```haskell 42 | data JobEnv = JobEnv { 43 | jeHello :: String 44 | } deriving (Eq, Show) 45 | 46 | instance Env JobEnv where -- You need Env instance when you define environment. 47 | instance Aux JobEnv where -- You need Aux instance when you run the job queue. 48 | ``` 49 | 50 | Define states that describe your state machine. 51 | 52 | ```haskell 53 | data JobUnit = HelloStep | WorldStep deriving (Show, Read, Eq, Ord) 54 | 55 | instance Unit JobUnit where 56 | getPriority _ju = 1 57 | getRecovery _ju = HelloStep 58 | 59 | instance Desc JobUnit where 60 | ``` 61 | 62 | Define actions and run the state machine. 63 | 64 | ```haskell 65 | main :: IO () 66 | main = do 67 | args <- getArgs 68 | case args of 69 | (loc:name:args') -> do 70 | let withJobQueue = buildJobQueue loc name $ process $ \case 71 | WorldStep -> commitIO (putStrLn "world") >> fin 72 | HelloStep -> do 73 | env <- getEnv 74 | commitIO (putStr $ (jeHello env) ++ ", ") 75 | next WorldStep 76 | case args' of 77 | ("run":[]) -> withJobQueue $ loop (JobEnv "hello") 78 | ("init":[]) -> withJobQueue $ \jq -> scheduleJob jq HelloStep 79 | [] -> putStrLn $ "command not specified." 80 | (cmd:_) -> putStrLn $ "unknown command: " ++ cmd 81 | _ -> return () 82 | where 83 | loop env jq = do 84 | executeJob jq env 85 | count <- countJobQueue jq 86 | when (count > 0) $ loop env jq 87 | ``` 88 | 89 | Examples 90 | -------- 91 | 92 | ### Example 1. Hello, World 93 | 94 | The "hello" example demonstrates a simple sequential state transition. It consists of just two states, a "Hello" step and a "World" step. 95 | 96 | To initialize the state machine, execute it with the "init" command. 97 | 98 | > jobqueue-sample-hello sqlite3://hello.sqlite3 test init 99 | 100 | To run the state machine, execute it with the "run" command. 101 | 102 | > jobqueue-sample-hello sqlite3://hello.sqlite3 test run 103 | hello, world 104 | 105 | If you wish to use a Zookeeper cluster, you can specify a Zookeeper address (e.g. "zookeeper://localhost:2181/") instead of the sqlite3 address. 106 | 107 | ### Example 2. Fibonacci 108 | 109 | The "fibonacci" example demonstrates a slightly more complex case with a loop in the state machine. It consists of an initialization step and a computation step. 110 | 111 | To initialize the state machine, execute it with the "init" command. 112 | 113 | > jobqueue-sample-fibonacci sqlite3://fibonacci.sqlite3 test init 114 | 115 | To run the state machine, execute it with the "run" command. 116 | 117 | > jobqueue-sample-fibonacci sqlite3://fibonacci.sqlite3 test run 118 | [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181,6765,10946,17711,28657,46368,75025,121393,196418,317811,514229,832040,1346269,2178309,3524578,5702887,9227465,14930352,24157817,39088169,63245986,102334155,165580141,267914296,433494437,701408733,1134903170,1836311903,2971215073,4807526976,7778742049,12586269025,20365011074,32951280099,53316291173,86267571272,139583862445,225851433717,365435296162,591286729879,956722026041,1548008755920,2504730781961,4052739537881,6557470319842,10610209857723,17167680177565,27777890035288,44945570212853,72723460248141,117669030460994,190392490709135,308061521170129,498454011879264,806515533049393,1304969544928657,2111485077978050,3416454622906707,5527939700884757,8944394323791464,14472334024676221,23416728348467685,37889062373143906,61305790721611591,99194853094755497,160500643816367088,259695496911122585,420196140727489673,679891637638612258,1100087778366101931,1779979416004714189,2880067194370816120,4660046610375530309,7540113804746346429,12200160415121876738,19740274219868223167,31940434634990099905,51680708854858323072,83621143489848422977,135301852344706746049,218922995834555169026,354224848179261915075] 119 | 120 | -------------------------------------------------------------------------------- /jobqueue-examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 GREE, Inc. 2 | 3 | MIT License 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining 6 | a copy of this software and associated documentation files (the 7 | "Software"), to deal in the Software without restriction, including 8 | without limitation the rights to use, copy, modify, merge, publish, 9 | distribute, sublicense, and/or sell copies of the Software, and to 10 | permit persons to whom the Software is furnished to do so, subject to 11 | the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be 14 | included in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /jobqueue-examples/fibonacci.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | import Control.Monad 5 | import Control.Monad.IO.Class 6 | import System.Environment hiding (getEnv) 7 | import Network.JobQueue 8 | 9 | data JobEnv = JobEnv { 10 | jeLimit :: Int 11 | } deriving (Eq, Show) 12 | 13 | instance Env JobEnv where 14 | instance Aux JobEnv where 15 | 16 | data JobUnit = 17 | InitialStep 18 | | ComputationStep Integer Integer [Integer] 19 | deriving (Show, Read, Eq, Ord) 20 | 21 | instance Unit JobUnit where 22 | getPriority _ju = 1 23 | getRecovery _ju = InitialStep 24 | 25 | instance Desc JobUnit where 26 | 27 | main :: IO () 28 | main = do 29 | args <- getArgs 30 | case args of 31 | (loc:name:args') -> do 32 | let withJobQueue = buildJobQueue loc name $ process $ \case 33 | InitialStep -> next $ ComputationStep 0 1 [] 34 | (ComputationStep a b r) -> do 35 | env <- getEnv 36 | if length r > jeLimit env 37 | then liftIO (print (reverse r)) >> fin 38 | else next $ ComputationStep b (a+b) (a:r) 39 | case args' of 40 | ("run":[]) -> withJobQueue $ loop (JobEnv 100) 41 | ("init":[]) -> withJobQueue $ \jq -> scheduleJob jq InitialStep 42 | [] -> putStrLn $ "command not specified." 43 | (cmd:_) -> putStrLn $ "unknown command: " ++ cmd 44 | _ -> return () 45 | where 46 | loop env jq = do 47 | executeJob jq env 48 | count <- countJobQueue jq 49 | when (count > 0) $ loop env jq 50 | -------------------------------------------------------------------------------- /jobqueue-examples/hello.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | import Control.Monad 7 | import System.Log.Logger 8 | import System.Log.Handler.Syslog 9 | import System.Environment hiding (getEnv) 10 | import Network.JobQueue 11 | 12 | data JobEnv = JobEnv { 13 | jeHello :: String 14 | } deriving (Eq, Show) 15 | 16 | instance Env JobEnv where 17 | instance Aux JobEnv where 18 | 19 | data JobUnit = HelloStep | WorldStep deriving (Show, Read, Eq, Ord) 20 | 21 | instance Unit JobUnit where 22 | getPriority _ju = 1 23 | getRecovery _ju = HelloStep 24 | 25 | instance Desc JobUnit where 26 | 27 | main :: IO () 28 | main = do 29 | h <- openlog "hello" [] USER INFO 30 | updateGlobalLogger rootLoggerName (setHandlers [h]) 31 | args <- getArgs 32 | case args of 33 | (loc:name:args') -> do 34 | let withJobQueue = buildJobQueue loc name $ process $ \case 35 | WorldStep -> do 36 | $(logWarn) "running {}" ["WorldStep" :: String] 37 | commitIO (putStrLn "world") >> fin 38 | HelloStep -> do 39 | $(logWarn) "running {}" ["HelloStep" :: String] 40 | env <- getEnv 41 | commitIO (putStr $ (jeHello env) ++ ", ") 42 | next WorldStep 43 | case args' of 44 | ("run":[]) -> withJobQueue $ loop (JobEnv "hello") 45 | ("init":[]) -> withJobQueue $ \jq -> scheduleJob jq HelloStep 46 | [] -> putStrLn $ "command not specified." 47 | (cmd:_) -> putStrLn $ "unknown command: " ++ cmd 48 | _ -> return () 49 | where 50 | loop env jq = do 51 | executeJob jq env 52 | count <- countJobQueue jq 53 | when (count > 0) $ loop env jq 54 | -------------------------------------------------------------------------------- /jobqueue-examples/jobqueue-examples.cabal: -------------------------------------------------------------------------------- 1 | Name: jobqueue-examples 2 | Version: 0.0.2 3 | Synopsis: A job queue library 4 | License: MIT 5 | License-File: LICENSE 6 | Author: Kiyoshi Ikehara 7 | Maintainer: kiyoshi.ikehara at gree.net 8 | Copyright: GREE, Inc. 9 | Build-Type: Simple 10 | Category: Network, Client 11 | Cabal-Version: >=1.8 12 | Description: 13 | Haskell JobQueue is a library used for building a job scheduler with priority queues. 14 | The state of jobs is stored in a backend database such as Apache Zookeeper or other 15 | highly reliable message queue systems. 16 | 17 | Source-Repository head 18 | type: git 19 | location: https://github.com/gree/haskell-jobqueue.git 20 | 21 | Executable jobqueue-sample-hello 22 | Ghc-Options: -threaded -Wall -rtsopts 23 | Build-Depends: base >=4 && <5 24 | , jobqueue 25 | , network 26 | , bytestring 27 | , containers 28 | , transformers 29 | , data-default 30 | , hslogger 31 | Main-is: hello.hs 32 | Extensions: DeriveDataTypeable 33 | 34 | Executable jobqueue-sample-fibonacci 35 | Ghc-Options: -threaded -Wall -rtsopts 36 | Build-Depends: base >=4 && <5 37 | , jobqueue 38 | , network 39 | , bytestring 40 | , containers 41 | , transformers 42 | , data-default 43 | Main-is: fibonacci.hs 44 | Extensions: DeriveDataTypeable 45 | 46 | Executable jobqueue-sample-priority 47 | Ghc-Options: -threaded -Wall -rtsopts 48 | Build-Depends: base >=4 && <5 49 | , jobqueue 50 | , network 51 | , bytestring 52 | , containers 53 | , transformers 54 | , data-default 55 | Main-is: priority.hs 56 | Extensions: DeriveDataTypeable 57 | 58 | Executable jobqueue-sample-suspend 59 | Ghc-Options: -threaded -Wall -rtsopts 60 | Build-Depends: base >=4 && <5 61 | , jobqueue 62 | , bytestring 63 | , containers 64 | , data-default 65 | Main-is: suspend.hs 66 | Extensions: DeriveDataTypeable 67 | 68 | -------------------------------------------------------------------------------- /jobqueue-examples/priority.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | import Control.Monad 5 | import System.Environment hiding (getEnv) 6 | import Network.JobQueue 7 | 8 | data JobEnv = JobEnv { 9 | } deriving (Eq, Show) 10 | 11 | instance Env JobEnv where 12 | instance Aux JobEnv where 13 | 14 | data JobUnit = Priority0 | Priority1 Int | Priority1' Int | Priority2 | Failed deriving (Show, Read, Eq, Ord) 15 | 16 | instance Unit JobUnit where 17 | getPriority Priority0 = -1 18 | getPriority Priority1 {} = 0 19 | getPriority Priority1' {} = 0 20 | getPriority Priority2 = 1 21 | getPriority Failed = -2 22 | getRecovery _ju = Failed 23 | 24 | instance Desc JobUnit where 25 | 26 | main :: IO () 27 | main = do 28 | args <- getArgs 29 | case args of 30 | (loc:name:args') -> do 31 | let withJobQueue = buildJobQueue loc name $ do 32 | process $ \case 33 | Priority0 -> commitIO (putStrLn "0") >> fin 34 | (Priority1 ttl) -> commitIO (putStrLn "1") >> if ttl > 0 then fork $ Priority1 (ttl-1) else fin 35 | (Priority1' ttl) -> commitIO (putStrLn "1'") >> if ttl > 0 then fork $ Priority1' (ttl-1) else fin 36 | _ -> none 37 | process $ \case 38 | Priority2 -> commitIO (putStrLn "2") >> fin 39 | Failed -> commitIO (putStrLn "failed.") >> fin 40 | _ -> none 41 | case args' of 42 | ("run":[]) -> withJobQueue $ loop (JobEnv) 43 | ("init":[]) -> withJobQueue $ \jq -> mapM_ (scheduleJob jq) [Priority1 10, Priority1' 10, Priority2, Priority0] 44 | ("show":[]) -> withJobQueue $ loop (JobEnv) 45 | [] -> putStrLn $ "command not specified." 46 | (cmd:_) -> putStrLn $ "unknown command: " ++ cmd 47 | _ -> return () 48 | where 49 | loop env jq = do 50 | executeJob jq env 51 | count <- countJobQueue jq 52 | when (count > 0) $ loop env jq 53 | -------------------------------------------------------------------------------- /jobqueue-examples/suspend.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Concurrent 3 | import Control.Monad 4 | import System.Environment hiding (getEnv) 5 | import Network.JobQueue 6 | import Network.JobQueue.Util 7 | import System.IO 8 | 9 | data JobEnv = JobEnv { 10 | jeLimit :: Integer 11 | } deriving (Eq, Show) 12 | 13 | instance Env JobEnv where 14 | instance Aux JobEnv where 15 | 16 | data JobUnit = ExecuteStep Integer deriving (Show, Read, Eq, Ord) 17 | 18 | instance Unit JobUnit where 19 | getPriority _ju = 1 20 | getRecovery _ju = ExecuteStep 0 21 | 22 | instance Desc JobUnit where 23 | 24 | main :: IO () 25 | main = do 26 | args <- getArgs 27 | case args of 28 | (loc:name:args') -> do 29 | let withJobQueue = buildJobQueue loc name $ do 30 | process $ \(ExecuteStep r) -> do 31 | commitIO $ do 32 | hPutStr stdout " executing" 33 | hFlush stdout 34 | liftIO $ threadDelay 1000000 35 | env <- getEnv 36 | if r < jeLimit env 37 | then next $ ExecuteStep (r+1) 38 | else fin 39 | case args' of 40 | ("run":[]) -> withJobQueue $ loop (JobEnv 30) 41 | ("init":[]) -> withJobQueue $ \jq -> scheduleJob jq $ ExecuteStep 0 42 | ("suspend":[]) -> withJobQueue $ \jq -> void $ suspendJobQueue jq 43 | ("resume":[]) -> withJobQueue $ \jq -> void $ resumeJobQueue jq 44 | ("monitor":[]) -> withJobQueue $ \jq -> void $ waitForAllJobs jq 100 $ \mjob count -> case mjob of 45 | Just job -> hPutStr stderr $ "(" ++ ((shortDesc $ jobUnit job) ++ " " ++ (show $ jobState job)) ++ "/" ++ show count ++ ")" 46 | Nothing -> hPutStr stderr $ "(" ++ (show count) ++ " ticks)" 47 | (cmd:_) -> putStrLn $ "unknown command: " ++ cmd 48 | _ -> putStrLn $ "invalid operation" 49 | _ -> return () 50 | where 51 | loop env jq = do 52 | executeJob jq env 53 | count <- countJobQueue jq 54 | when (count > 0) $ loop env jq 55 | -------------------------------------------------------------------------------- /jobqueue/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 GREE, Inc. 2 | 3 | MIT License 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining 6 | a copy of this software and associated documentation files (the 7 | "Software"), to deal in the Software without restriction, including 8 | without limitation the rights to use, copy, modify, merge, publish, 9 | distribute, sublicense, and/or sell copies of the Software, and to 10 | permit persons to whom the Software is furnished to do so, subject to 11 | the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be 14 | included in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /jobqueue/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /jobqueue/jobqueue.cabal: -------------------------------------------------------------------------------- 1 | Name: jobqueue 2 | Version: 0.1.6 3 | Synopsis: A job queue library 4 | License: MIT 5 | License-File: LICENSE 6 | Author: Kiyoshi Ikehara 7 | Maintainer: kiyoshi.ikehara at gree.net 8 | Stability: experimental 9 | Copyright: GREE, Inc. 10 | Build-Type: Simple 11 | Category: Network, Client 12 | Cabal-Version: >=1.8 13 | Homepage: https://github.com/gree/haskell-jobqueue 14 | Description: 15 | Haskell JobQueue is a library used for building a job scheduler with priority queues. 16 | The state of jobs is stored in a backend database such as Apache Zookeeper or other 17 | highly reliable message queue systems. 18 | 19 | Source-Repository head 20 | type: git 21 | location: https://github.com/gree/haskell-jobqueue.git 22 | 23 | Library 24 | Ghc-Options: -Wall 25 | Build-Depends: base >= 4 && < 5 26 | , mtl > 2.2 27 | , network >= 2.3.2 28 | , hslogger 29 | , text 30 | , bytestring 31 | , containers 32 | , split 33 | , time 34 | , data-default 35 | , stm >= 2.4 36 | , hzk >= 2.0.0 37 | , attoparsec 38 | , data-default 39 | , HDBC 40 | , HDBC-sqlite3 41 | , fast-logger 42 | , monad-logger 43 | , template-haskell 44 | , text-format 45 | , monad-control 46 | , transformers-base 47 | , lifted-base 48 | , regex-posix 49 | , aeson 50 | Hs-source-dirs: src 51 | Exposed-modules: Network.JobQueue 52 | , Network.JobQueue.Class 53 | , Network.JobQueue.Types 54 | , Network.JobQueue.Action 55 | , Network.JobQueue.AuxClass 56 | , Network.JobQueue.Job 57 | , Network.JobQueue.Job.Internal 58 | , Network.JobQueue.JobQueue 59 | , Network.JobQueue.JobQueue.Internal 60 | , Network.JobQueue.Backend 61 | , Network.JobQueue.Backend.Class 62 | , Network.JobQueue.Backend.Types 63 | , Network.JobQueue.Backend.Zookeeper 64 | , Network.JobQueue.Backend.Sqlite3 65 | , Network.JobQueue.Logger 66 | , Network.JobQueue.Util 67 | , Network.JobQueue.Param 68 | Other-modules: Network.JobQueue.Backend.Zookeeper.ZookeeperQueue 69 | Extensions: DeriveDataTypeable 70 | 71 | Test-Suite test 72 | Ghc-Options: -threaded -O2 73 | Build-depends: base 74 | , bytestring 75 | , network >= 2.3.2 76 | , directory 77 | , QuickCheck < 3 78 | , hspec 79 | , async 80 | , jobqueue 81 | , data-default 82 | , stm 83 | Type: exitcode-stdio-1.0 84 | Hs-source-dirs: test 85 | Other-modules: Action 86 | , BackendQueue 87 | , JobQueue 88 | Main-is: Main.hs 89 | 90 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : Network.JobQueue 3 | Copyright : (c) Gree, Inc. 2013 4 | License : MIT-style 5 | 6 | Maintainer : Kiyoshi Ikehara 7 | Stability : experimental 8 | Portability : portable 9 | 10 | Haskell JobQueue is a library used for building a job scheduler with a priority queue. 11 | The state of a job is stored in a backend database such as Apache Zookeeper or other 12 | highly reliable mesage queue systems. 13 | 14 | [@Unit@] 15 | 16 | Unit represents each state in an entire state machine. Units are described as value 17 | constructors in Haskell code. 18 | Unit itself is not executable. To execute using job queue system, extra information such 19 | as job identifier, scheduled time is needed. An instance of a unit is wrapped by a 'job' 20 | and stored into the job queue with those information. 21 | 22 | The code shown below describes how to define a Unit. 23 | 24 | > data JobUnit = HelloStep | WorldStep deriving (Show, Read) 25 | > 26 | > instance Unit JobUnit where 27 | 28 | In this case, you define JobUnit type with 2 states, HelloStep and WorldStep. 29 | This is the entire state machine of your job queue system. 30 | You can define nested or child state machines by defining more complex data types as 31 | long as they are serializable with read and show functions. 32 | 33 | For more information, see "Network.JobQueue.Class". 34 | 35 | [@Job@] 36 | 37 | Each task executed by state machines (such as checking server state or repairing a 38 | cluster) is called a 'job'. 39 | 40 | A job is described as a particular state of a state machine. Each state only does one 41 | thing (especially for modifying operations). 42 | This prevents jobs ending in a failure state, which the state machine is unable to handle. 43 | 44 | You don't have to know the internal data structure of a job, but need to understand 45 | its when you write action code. 46 | 47 | For more information, see "Network.JobQueue.Job". 48 | 49 | [@Environment@] 50 | 51 | Each unit can contain information used in the action of the state. But in many cases, 52 | there is some information used by almost all states and it is convenient if there is 53 | some kind of global data set that is accessible from all the state's actions. 54 | 55 | For this reason, you can define global data structures called environment. 56 | The enviroment can be retrieved using getEnv function in action monad. 57 | 58 | > env <- getEnv 59 | 60 | For more information, see "Network.JobQueue.Class". 61 | 62 | [@Action@] 63 | 64 | An action is a function that is called with a unit. You can define actions with the 65 | "process" function. 66 | 67 | > let withJobQueue = buildJobQueue loc name $ do 68 | > process $ \WorldStep -> commitIO (putStrLn "world") >> fin 69 | > process $ \HelloStep -> commitIO (putStr "hello, ") >> next WorldStep 70 | 71 | In general, an action does the following things: 72 | 73 | * check if the precondition of the state is satisfied or not 74 | 75 | * do the action associated with the state 76 | 77 | * check the postcondition and return the next state. 78 | 79 | For more information, see "Network.JobQueue.Action". 80 | 81 | -} 82 | 83 | {-# LANGUAGE ScopedTypeVariables #-} 84 | 85 | module Network.JobQueue ( 86 | buildJobQueue 87 | , runJobQueue 88 | , Job(..) 89 | , JobState(..) 90 | , Unit(..) 91 | , ActionM 92 | , JobM 93 | , JobActionState 94 | , process 95 | , createJob 96 | , fin 97 | , none 98 | , next 99 | , orNext 100 | , yield 101 | , fork 102 | , forkInTime 103 | , forkOnTime 104 | , abort 105 | , getEnv 106 | , Param 107 | , param 108 | , commitIO 109 | , liftIO 110 | , module Network.JobQueue.Class 111 | , module Network.JobQueue.AuxClass 112 | , module Network.JobQueue.JobQueue 113 | , module Network.JobQueue.Logger 114 | ) where 115 | 116 | import Prelude hiding (log) 117 | import Control.Exception 118 | import Control.Monad 119 | 120 | import Network.JobQueue.Types 121 | import Network.JobQueue.Class 122 | import Network.JobQueue.AuxClass 123 | import Network.JobQueue.JobQueue 124 | import Network.JobQueue.Job 125 | import Network.JobQueue.Logger 126 | import Network.JobQueue.Param (Param,param) 127 | 128 | {- | Build a function that takes a function (('JobQueue' a -> 'IO' ()) -> IO ()) as its first parameter. 129 | 130 | The following code executes jobs as long as the queue is not empty. 131 | 132 | > main' loc name = do 133 | > let withJobQueue = buildJobQueue loc name $ do 134 | > process $ \WorldStep -> commitIO (putStrLn "world") >> fin 135 | > process $ \HelloStep -> commitIO (putStr "hello, ") >> next WorldStep 136 | > withJobQueue $ loop (initJobEnv loc name []) 137 | > where 138 | > loop env jq = do 139 | > executeJob jq env 140 | > count <- countJobQueue jq 141 | > when (count > 0) $ loop env jq 142 | 143 | The following code registers a job with initial state. 144 | 145 | > main' loc name = do 146 | > let withJobQueue = buildJobQueue loc name $ do 147 | > process $ \WorldStep -> commitIO (putStrLn "world") >> fin 148 | > process $ \HelloStep -> commitIO (putStr "hello, ") >> next WorldStep 149 | > withJobQueue $ \jq -> scheduleJob jq HelloStep 150 | 151 | -} 152 | buildJobQueue :: (Env e, Unit a) => String -- ^ locator (ex.\"zookeeper:\/\/192.168.0.1\/myapp\") 153 | -> String -- ^ queue name (ex. \"/jobqueue\") 154 | -> JobM e a () -- ^ job construction function 155 | -> ((JobQueue e a -> IO ()) -> IO ()) -- ^ job queue executor 156 | buildJobQueue loc name jobm = \action -> do 157 | bracket (openSession loc) (closeSession) $ \session -> do 158 | jq <- openJobQueue session name jobm 159 | action jq 160 | closeJobQueue jq 161 | 162 | {- | Run a job queue while there is at least one job in the queue. 163 | -} 164 | runJobQueue :: (Aux e, Env e, Unit a) 165 | => e 166 | -> String -- ^ locator (ex.\"zookeeper:\/\/192.168.0.1\/myapp\") 167 | -> String -- ^ queue name (ex. \"/jobqueue\") 168 | -> JobM e a () -- ^ job construction function 169 | -> IO () 170 | runJobQueue env loc name jobm = buildJobQueue loc name jobm loop 171 | where 172 | loop jq = do 173 | executeJob jq env 174 | count <- countJobQueue jq 175 | when (count > 0) $ loop jq 176 | 177 | ---------------------------------------------------------------------- 178 | -- Docs 179 | ---------------------------------------------------------------------- 180 | 181 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Action.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Network.JobQueue.Action ( 8 | JobActionState 9 | , runActionState 10 | , runAction 11 | , getEnv 12 | , next 13 | , orNext 14 | , fin 15 | , none 16 | , fork 17 | , forkInTime 18 | , forkOnTime 19 | , abort 20 | , commitIO 21 | , liftIO 22 | , yield 23 | ) where 24 | 25 | import Control.Applicative 26 | import Control.Monad.Except 27 | import Control.Monad.Reader 28 | import Control.Monad.State 29 | import Control.Exception (SomeException(..), toException) 30 | import Control.Exception.Base (PatternMatchFail(..)) 31 | import Control.Monad.Logger (runLoggingT) 32 | import Control.Exception.Lifted (catch) 33 | import Control.Monad.Base () 34 | 35 | import Data.Maybe 36 | import Data.Time.Clock 37 | import Data.Default (Default, def) 38 | 39 | import Network.JobQueue.Class 40 | import Network.JobQueue.AuxClass 41 | import Network.JobQueue.Types 42 | import Network.JobQueue.Logger 43 | 44 | runActionState :: (Env e, Unit a) => JobActionState e a -> ActionFn e a 45 | runActionState (JobActionState { jobActions = actions } ) env ju = runActionState' actions 46 | where 47 | runActionState' actions' = case actions' of 48 | [] -> return $ Right Nothing 49 | (act:acts) -> do 50 | r <- act env ju 51 | case r of 52 | Right Nothing -> runActionState' acts 53 | _ -> return r 54 | 55 | runAction :: (Aux e, Env e, Unit a) => 56 | e -> a -> ActionT e a IO () -> IO (Either Break (Maybe (RuntimeState a))) 57 | runAction env ju action = do 58 | (e,r) <- flip runLoggingT (auxLogger env) 59 | $ flip runStateT Nothing 60 | $ flip runReaderT (ActionEnv env ju) 61 | $ runExceptT 62 | $ runAM $ do 63 | when (toBeLogged ju) $ $(logWarn) "{}" [desc ju] 64 | action `catch` handlePatternMatchFail `catch` handleSome 65 | return $ either Left (const $ Right r) e 66 | 67 | handlePatternMatchFail :: (Aux e, Env e, Unit a) => PatternMatchFail -> ActionT e a IO () 68 | handlePatternMatchFail e = do 69 | s <- get 70 | if getCommits (fromMaybe def s) > 0 71 | then do 72 | ju <- getJobUnit <$> ask 73 | $(logError) "pattern match fail: ! ({})" [desc ju] 74 | throwError $ Unhandled (toException e) 75 | else none 76 | 77 | handleSome :: (Aux e, Env e, Unit a) => SomeException -> ActionT e a IO b 78 | handleSome e = do 79 | $(logError) "unhandled exception: {}" [show e] 80 | throwError $ Unhandled e 81 | 82 | -------------------------------- 83 | 84 | {- | Get environment in action. 85 | -} 86 | getEnv :: (Env e, Unit a) => ActionM e a e 87 | getEnv = getJobEnv <$> ask 88 | 89 | ---------------- 90 | 91 | {- | Do a dirty I/O action with a side effect to the external system. 92 | If it doesn't change the state of the external system, you should use liftIO instead. 93 | -} 94 | commitIO :: (Env e, Unit a) => IO b -> ActionM e a b 95 | commitIO action = do 96 | do s <- get 97 | when (getCommits (fromMaybe def s) > 0) $ do 98 | ju <- getJobUnit <$> ask 99 | $(logWarn) "commitIO called twice! ({})" [desc ju] 100 | modify $ \s -> Just $ incrementCommits $ fromMaybe def s 101 | liftIO action 102 | 103 | ---------------- 104 | 105 | {- | Yield execution 106 | -} 107 | yield :: (Env e, Unit a) => ActionM e a () 108 | yield = do 109 | ju <- getJobUnit <$> ask 110 | forkWith ju Nothing 111 | 112 | {- | Create a job with a unit and schedule it. 113 | -} 114 | fork :: (Env e, Unit a) 115 | => a -- ^ a unit 116 | -> ActionM e a () 117 | fork ju = forkWith ju Nothing 118 | 119 | {- | Create a job with a unit and schedule it at a specific time. 120 | -} 121 | forkOnTime :: (Env e, Unit a) 122 | => UTCTime -- ^ absolute time in UTC 123 | -> a -- ^ a unit 124 | -> ActionM e a () 125 | forkOnTime t ju = forkWith ju (Just t) 126 | 127 | {- | Create a job with a unit and schedule it after a few micro seconds. 128 | -} 129 | forkInTime :: (Env e, Unit a) => NominalDiffTime -> a -> ActionM e a () 130 | forkInTime tDiff ju = do 131 | currentTime <- liftIO $ getCurrentTime 132 | forkWith ju (Just (addUTCTime tDiff currentTime)) 133 | 134 | {- | Move to the next state immediately. 135 | After the execution of the action the job being processed will be 136 | moved to the given state. The next action will be invoked immediately 137 | and can continue to work without being interrupted by another job. 138 | NOTE: This overrides the next state if it is already set. 139 | -} 140 | next :: (Env e, Unit a) 141 | => a -- ^ the next state 142 | -> ActionM e a () 143 | next ju = modify $ \s -> Just $ setNextJob ju $ fromMaybe def s 144 | 145 | {- | Move to the next state immediately. 146 | This is different from "next" function because this doesn't override 147 | if the next job is already set. 148 | -} 149 | orNext :: (Env e, Unit a) 150 | => a -- ^ the next state 151 | -> ActionM e a () 152 | orNext ju = modify $ \s -> Just $ setNextJobIfEmpty ju $ fromMaybe def s 153 | 154 | {- | Finish a job. 155 | -} 156 | fin :: (Env e, Unit a) => ActionM e a () 157 | fin = modify $ \s -> Just $ emptyNextJob $ fromMaybe def s 158 | 159 | {- | If the unit passed by the job queue system cannot be processed by the 160 | action function, the function should call this. 161 | -} 162 | none :: (Env e, Unit a) => ActionM e a () 163 | none = result Nothing 164 | 165 | {- | Abort the execution of a state machine. 166 | If a critical problem is found and there is a need to switch to the failure state, 167 | call this function. 168 | -} 169 | abort :: (Env e, Unit a) => ActionM e a b 170 | abort = do 171 | ju <- getJobUnit <$> ask 172 | throwError $ Failure ("aborted on " ++ desc ju) 173 | 174 | ---------------------------------------------------------------- PRIVATE 175 | 176 | {- | Set the result of the action. (for internal use) 177 | -} 178 | result :: (Env e, Unit a) => Maybe (RuntimeState a) -> ActionM e a () 179 | result = modify . setResult 180 | 181 | forkWith :: (Env e, Unit a) => a -> Maybe UTCTime -> ActionM e a () 182 | forkWith ju mt = modify $ \s -> Just $ addForkJob (ju, mt) $ fromMaybe def s 183 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/AuxClass.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2014 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Network.JobQueue.AuxClass where 7 | 8 | import Control.Monad.Logger 9 | import Control.Applicative 10 | import System.Log.FastLogger 11 | import System.Log.Logger 12 | import System.Environment (getProgName) 13 | 14 | import Network.JobQueue.Types 15 | import Network.JobQueue.Job.Internal 16 | 17 | import qualified Data.ByteString.Char8 as S8 18 | 19 | class Aux a where 20 | auxLogger :: a -> Loc -> LogSource -> LogLevel -> LogStr -> IO () 21 | auxLogger _ loc logsrc loglevel msg = do 22 | progName <- getProgName 23 | logFunc loglevel progName $ S8.unpack $ fromLogStr $ defaultLogStr loc logsrc loglevel msg 24 | where 25 | logFunc level = case level of 26 | LevelDebug -> debugM 27 | LevelInfo -> infoM 28 | LevelWarn -> warningM 29 | LevelError -> errorM 30 | LevelOther "notice" -> noticeM 31 | LevelOther "critical" -> criticalM 32 | LevelOther _ -> warningM 33 | 34 | auxHandleFailure :: (Unit b) => a -> Maybe (Job b) -> IO (Maybe (Job b)) 35 | auxHandleFailure _ mjob = do 36 | case mjob of 37 | Just job -> Just <$> createJob Runnable (getRecovery (jobUnit job)) 38 | Nothing -> return (Nothing) 39 | 40 | auxHandleAfterExecute :: (Unit b) => a -> Job b -> IO () 41 | auxHandleAfterExecute _ _job = return () 42 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Backend.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Network.JobQueue.Backend (openBackend) where 7 | 8 | import Prelude hiding (takeWhile) 9 | import Control.Exception (throwIO) 10 | import qualified Data.ByteString.Char8 as BS 11 | import Network.JobQueue.Backend.Class () 12 | import Network.JobQueue.Backend.Types 13 | import Network.JobQueue.Backend.Zookeeper 14 | import Network.JobQueue.Backend.Sqlite3 15 | 16 | import Data.Attoparsec.ByteString 17 | import Control.Applicative 18 | 19 | data Locator = Zookeeper String | Sqlite3 String 20 | 21 | 22 | {- | Open a backend database. 23 | -} 24 | openBackend :: String -- ^ locator (eg. \"zookeeper://localhost:2181/myapp\", \"sqlite3://myapp.sqlite3\") 25 | -> IO Backend -- ^ backend 26 | openBackend locator = case parseLocator locator of 27 | Just (Zookeeper connString) -> openZookeeperBackend connString 28 | Just (Sqlite3 localPath) -> openSqlite3Backend localPath 29 | _ -> throwIO $ userError "invalid locator" 30 | 31 | 32 | ---------------------------------------------------------------- PRIVATE 33 | 34 | parseLocator :: String -> Maybe Locator 35 | parseLocator v = case parse locatorParser $ BS.pack v of 36 | Done _ locator -> Just locator 37 | Partial parse' -> case parse' "" of 38 | Done _ locator -> Just locator 39 | _ -> Nothing 40 | _ -> Nothing 41 | where 42 | locatorParser :: Parser (Locator) 43 | locatorParser = do 44 | scheme <- takeWhile (/= 58) <* string "://" 45 | case scheme of 46 | "zookeeper" -> Zookeeper <$> fmap BS.unpack (takeWhile1 (\_ -> True)) 47 | "sqlite3" -> Sqlite3 <$> fmap BS.unpack (takeWhile1 (\_ -> True)) 48 | _ -> fail "unknown scheme" 49 | 50 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Backend/Class.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | module Network.JobQueue.Backend.Class (BackendQueue(..)) where 5 | 6 | import qualified Data.ByteString.Char8 as BS 7 | 8 | class BackendQueue q where 9 | readQueue :: q -> IO (Maybe (BS.ByteString, String)) 10 | peekQueue :: q -> IO (Maybe (BS.ByteString, String, String, Int)) 11 | updateQueue :: q -> String -> BS.ByteString -> Int -> IO (Bool) 12 | deleteQueue :: q -> String -> IO (Bool) 13 | writeQueue :: q -> BS.ByteString -> Int -> IO (String) 14 | listQueue :: q -> IO ([BS.ByteString]) 15 | itemsQueue :: q -> IO ([String]) 16 | countQueue :: q -> IO (Int) 17 | closeQueue :: q -> IO () 18 | closeQueue _ = return () 19 | 20 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Backend/Sqlite3.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Network.JobQueue.Backend.Sqlite3 (openSqlite3Backend, newSqlite3Backend) where 7 | 8 | import qualified Data.ByteString.Char8 as BS 9 | import Database.HDBC 10 | import Database.HDBC.Sqlite3 11 | import Network.JobQueue.Backend.Types 12 | import Network.JobQueue.Backend.Class 13 | import Control.Concurrent.MVar 14 | import Control.Exception 15 | 16 | data Sqlite3Queue = Sqlite3Queue 17 | { conn :: Connection 18 | , queueName :: String 19 | , mlock :: MVar () 20 | } 21 | 22 | instance BackendQueue Sqlite3Queue where 23 | readQueue = readDBQueue 24 | peekQueue = peekDBQueue 25 | updateQueue = updateDBQueue 26 | deleteQueue = deleteDBQueue 27 | writeQueue = writeDBQueue 28 | listQueue = listDBQueue 29 | itemsQueue = itemsDBQueue 30 | countQueue = countDBQueue 31 | closeQueue = const $ return () 32 | 33 | openSqlite3Backend :: String -> IO Backend 34 | openSqlite3Backend filePath = do 35 | c <- connectSqlite3 filePath 36 | m <- newMVar () 37 | return $ Backend { 38 | bOpenQueue = \qn -> do 39 | _ <- withLock m $ withTransaction c $ \c' -> do 40 | run c' ("CREATE TABLE IF NOT EXISTS '" ++ qn ++ "' (key INTEGER PRIMARY KEY AUTOINCREMENT, prio INTEGER, value TEXT, version INTEGER)") [] 41 | return (Sqlite3Queue c qn m) 42 | , bClose = disconnect c 43 | } 44 | 45 | newSqlite3Backend :: Connection -> IO Backend 46 | newSqlite3Backend c = do 47 | m <- newMVar () 48 | return $ Backend { 49 | bOpenQueue = \qn -> do 50 | return (Sqlite3Queue c qn m) 51 | , bClose = return () 52 | } 53 | 54 | readDBQueue :: Sqlite3Queue -> IO (Maybe (BS.ByteString, String)) 55 | readDBQueue Sqlite3Queue {..} = withLock mlock $ withTransaction conn $ \conn' -> do 56 | sqlvalues <- quickQuery' conn' ("SELECT key, value FROM '" ++ queueName ++ "' ORDER BY prio, key LIMIT 1") [] 57 | case sqlvalues of 58 | ((key:value:_):_) -> do 59 | _ <- run conn' ("DELETE FROM '" ++ queueName ++ "' WHERE key = ?") [toSql key] 60 | return (Just (fromSql value, fromSql key)) 61 | _ -> return (Nothing) 62 | 63 | peekDBQueue :: Sqlite3Queue -> IO (Maybe (BS.ByteString, String, String, Int)) 64 | peekDBQueue Sqlite3Queue {..} = withLock mlock $ withTransaction conn $ \conn' -> do 65 | sqlvalues <- quickQuery' conn' ("SELECT key, value, version FROM '" ++ queueName ++ "' ORDER BY prio, key LIMIT 1") [] 66 | case sqlvalues of 67 | ((key:value:version:_):_) -> return (Just (fromSql value, fromSql key, fromSql key, fromSql version)) 68 | _ -> return (Nothing) 69 | 70 | writeDBQueue :: Sqlite3Queue -> BS.ByteString -> Int -> IO (String) 71 | writeDBQueue Sqlite3Queue {..} value prio = do 72 | withLock mlock $ withTransaction conn $ \conn' -> do 73 | _ <- run conn' ("INSERT INTO '" ++ queueName ++ "'(prio, value, version) VALUES (?,?,0)") [toSql prio, toSql value] 74 | sqlvalues <- quickQuery' conn' ("SELECT seq FROM sqlite_sequence where name = '" ++ queueName ++ "'") [] 75 | case sqlvalues of 76 | ((key:_):_) -> do 77 | return (fromSql key) 78 | _ -> return ("") 79 | 80 | deleteDBQueue :: Sqlite3Queue -> String -> IO (Bool) 81 | deleteDBQueue Sqlite3Queue {..} key = withLock mlock $ withTransaction conn $ \conn' -> do 82 | _ <- run conn' ("DELETE FROM '" ++ queueName ++ "' WHERE key = ?") [toSql key] 83 | return (True) 84 | 85 | updateDBQueue :: Sqlite3Queue -> String -> BS.ByteString -> Int -> IO (Bool) 86 | updateDBQueue Sqlite3Queue {..} key value version = do 87 | withLock mlock $ withTransaction conn $ \conn' -> do 88 | nrows <- run conn' ("UPDATE '" ++ queueName ++ "' SET value = ?, version = ? WHERE key = ? AND version = ?") [toSql value, toSql (version+1), toSql key, toSql version] 89 | return $ if nrows > 0 then True else False 90 | 91 | countDBQueue :: Sqlite3Queue -> IO (Int) 92 | countDBQueue Sqlite3Queue {..} = withLock mlock $ withTransaction conn $ \conn' -> do 93 | sqlvalues <- quickQuery' conn' ("SELECT COUNT (*) FROM '" ++ queueName ++ "' ORDER BY prio, key LIMIT 1") [] 94 | case sqlvalues of 95 | ((count:_):_) -> return (fromSql count) 96 | _ -> return (0) 97 | 98 | itemsDBQueue :: Sqlite3Queue -> IO ([String]) 99 | itemsDBQueue Sqlite3Queue {..} = withLock mlock $ withTransaction conn $ \conn' -> do 100 | sqlvalues <- quickQuery' conn' ("SELECT key FROM '" ++ queueName ++ "' ORDER BY prio, key") [] 101 | case sqlvalues of 102 | keys -> return (map (fromSql . head) keys) 103 | 104 | listDBQueue :: Sqlite3Queue -> IO ([BS.ByteString]) 105 | listDBQueue Sqlite3Queue {..} = withLock mlock $ withTransaction conn $ \conn' -> do 106 | sqlvalues <- quickQuery' conn' ("SELECT value FROM '" ++ queueName ++ "' ORDER BY prio, key") [] 107 | case sqlvalues of 108 | keys -> return (map (fromSql . head) keys) 109 | 110 | withLock :: MVar () -> IO a -> IO a 111 | withLock m act = handleSql (\err -> throwIO $ SessionError (show err)) $ do 112 | bracket (takeMVar m) (putMVar m) $ const act 113 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Backend/Types.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | 7 | module Network.JobQueue.Backend.Types (Backend(..), BackendError(..)) where 8 | 9 | import Control.Exception 10 | import Network.JobQueue.Backend.Class 11 | import Data.Typeable 12 | 13 | data Backend where 14 | Backend :: (BackendQueue q) => { 15 | bOpenQueue :: String -> IO q 16 | , bClose :: IO () 17 | } -> Backend 18 | 19 | data BackendError = 20 | NotFound String 21 | | SessionError String 22 | deriving (Show, Typeable) 23 | 24 | instance Exception BackendError 25 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Backend/Zookeeper.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | module Network.JobQueue.Backend.Zookeeper ( 5 | openZookeeperBackend 6 | , newZookeeperBackend 7 | ) where 8 | 9 | import qualified Database.Zookeeper as Z 10 | import Control.Concurrent 11 | import Control.Concurrent.STM 12 | import Network.JobQueue.Backend.Types 13 | import Network.JobQueue.Backend.Zookeeper.ZookeeperQueue 14 | 15 | openZookeeperBackend :: String -> IO Backend 16 | openZookeeperBackend endpoint = do 17 | Z.setDebugLevel Z.ZLogError 18 | zvar <- newTVarIO Nothing 19 | stateVar <- newTVarIO Z.ConnectingState 20 | _ <- forkIO $ Z.withZookeeper endpoint 100000 (Just $ watcher stateVar) Nothing $ \z -> do 21 | atomically $ do 22 | state <- readTVar stateVar 23 | case state of 24 | Z.ConnectingState -> retry 25 | _ -> return () 26 | atomically $ writeTVar zvar (Just z) 27 | atomically $ do 28 | mz <- readTVar zvar 29 | case mz of 30 | Just _ -> retry 31 | Nothing -> return () 32 | return $ Backend { 33 | bOpenQueue = openQueue zvar 34 | , bClose = atomically $ writeTVar zvar Nothing 35 | } 36 | where 37 | openQueue :: TVar (Maybe Z.Zookeeper) -> String -> IO (ZookeeperQueue) 38 | openQueue zvar queueName = do 39 | z <- atomically $ readTVar zvar >>= maybe retry return 40 | zq <- initZQueue z (basePath queueName) Z.OpenAclUnsafe 41 | return zq 42 | 43 | watcher :: TVar Z.State -> Z.Watcher 44 | watcher stateVar _z event state _mZnode = do 45 | case event of 46 | Z.SessionEvent -> atomically $ writeTVar stateVar state 47 | _ -> return () 48 | 49 | newZookeeperBackend :: Z.Zookeeper -> Backend 50 | newZookeeperBackend zh = Backend { 51 | bOpenQueue = \queueName -> initZQueue zh (basePath queueName) Z.OpenAclUnsafe 52 | , bClose = return () 53 | } 54 | 55 | basePath :: String -> String 56 | basePath queueName = case queueName of 57 | '/':_ -> queueName 58 | _ -> '/':queueName 59 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Backend/Zookeeper/ZookeeperQueue.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | module Network.JobQueue.Backend.Zookeeper.ZookeeperQueue ( 5 | ZookeeperQueue 6 | , initZQueue 7 | , readZQueue 8 | , peekZQueue 9 | , updateZQueue 10 | , deleteZQueue 11 | , writeZQueue 12 | , destroyZQueue 13 | , listZQueue 14 | , itemsZQueue 15 | , countZQueue 16 | ) where 17 | 18 | import qualified Database.Zookeeper as Z 19 | import qualified Data.ByteString.Char8 as C 20 | import Control.Exception hiding (handle) 21 | import Data.List 22 | import Control.Monad 23 | import Data.Maybe 24 | import Data.List.Split 25 | 26 | import Network.JobQueue.Backend.Class 27 | import Network.JobQueue.Backend.Types 28 | 29 | data ZookeeperQueue = ZookeeperQueue { 30 | zqHandle :: Z.Zookeeper 31 | , zqBasePath :: String 32 | , zqNodeName :: String 33 | , zqAcls :: Z.AclList 34 | } 35 | 36 | instance BackendQueue ZookeeperQueue where 37 | readQueue = readZQueue 38 | peekQueue = peekZQueue 39 | updateQueue = updateZQueue 40 | deleteQueue = deleteZQueue 41 | writeQueue = writeZQueue 42 | listQueue = listZQueue 43 | itemsQueue = itemsZQueue 44 | countQueue = countZQueue 45 | 46 | 47 | maxPrio :: Int 48 | maxPrio = 999 49 | 50 | minPrio :: Int 51 | minPrio = -999 52 | 53 | qnPrefix :: String 54 | qnPrefix = "qn-" 55 | 56 | ---- init 57 | 58 | initZQueue :: Z.Zookeeper -> String -> Z.AclList -> IO (ZookeeperQueue) 59 | initZQueue z path acls = do 60 | e <- createZnodeRecursively z path Nothing acls [] 61 | case e of 62 | Right _ -> return () 63 | Left zkerr -> throwZKError "initZQueue" zkerr 64 | return (ZookeeperQueue z path qnPrefix acls) 65 | 66 | -- take 67 | readZQueue :: ZookeeperQueue -> IO (Maybe (C.ByteString, String)) 68 | readZQueue zkQueue = do 69 | children <- getChildren zkQueue 70 | case children of 71 | [] -> return (Nothing) 72 | _ -> takeHead (sortChildren children) 73 | where 74 | takeHead [] = return (Nothing) 75 | takeHead (nodeName:xs) = do 76 | let path = zqBasePath zkQueue ++ "/" ++ nodeName 77 | e <- Z.get (zqHandle zkQueue) path Nothing 78 | case e of 79 | Right (Just value, _stat) -> do 80 | e' <- Z.delete (zqHandle zkQueue) path Nothing 81 | case e' of 82 | Right () -> return (Just (value, nodeName)) 83 | Left _zkerr -> do 84 | r <- Z.exists (zqHandle zkQueue) path Nothing 85 | case r of 86 | Right _stat -> takeHead (nodeName:xs) 87 | Left Z.NoNodeError -> takeHead xs 88 | Left zkerr -> throwZKError "readZQueue" zkerr 89 | Right (Nothing, _stat) -> takeHead xs -- ignore if the content is empty 90 | Left Z.NoNodeError -> return (Nothing) 91 | Left zkerr -> throwZKError "readZQueue" zkerr 92 | 93 | -- peek 94 | peekZQueue :: ZookeeperQueue -> IO (Maybe (C.ByteString, String, String, Int)) 95 | peekZQueue zkQueue = do 96 | children <- getChildren zkQueue 97 | case children of 98 | [] -> return Nothing 99 | _ -> getHead (sortChildren children) 100 | where 101 | idSuffixLen :: Int 102 | idSuffixLen = 10 103 | 104 | getHead :: [String] -> IO (Maybe (C.ByteString, String, String, Int)) 105 | getHead [] = return Nothing 106 | getHead (x:xs) = do 107 | e <- Z.get (zqHandle zkQueue) (fullPath zkQueue x) Nothing 108 | case e of 109 | Right (mValue, stat) -> do 110 | case mValue of 111 | Just v -> return $ Just (v, x, drop (length x - idSuffixLen) x, fromIntegral $ Z.statVersion stat) 112 | Nothing -> getHead xs 113 | Left Z.NoNodeError -> peekZQueue zkQueue 114 | Left zkerr -> throwZKError "peekZQueue" zkerr 115 | 116 | -- update 117 | updateZQueue :: ZookeeperQueue -> String -> C.ByteString -> Int -> IO (Bool) 118 | updateZQueue zkQueue znodeName value version = do 119 | e <- Z.set (zqHandle zkQueue) (fullPath zkQueue znodeName) (Just value) (Just (fromIntegral version)) 120 | case e of 121 | Right _stat -> return (True) 122 | Left Z.BadVersionError -> return (False) 123 | Left Z.NoNodeError -> return (False) 124 | Left zkerr -> throwZKError "updateZQueue" zkerr 125 | 126 | -- delete 127 | deleteZQueue :: ZookeeperQueue -> String -> IO (Bool) 128 | deleteZQueue zkQueue nodeName = do 129 | let nodeName' = zqBasePath zkQueue ++ "/" ++ nodeName 130 | e <- Z.delete (zqHandle zkQueue) nodeName' Nothing 131 | case e of 132 | Right () -> return (True) 133 | Left Z.NoNodeError -> throwIO $ NotFound nodeName 134 | Left zkerr -> throwZKError ("deleteZQueue(nodeName=" ++ nodeName' ++ ")") zkerr 135 | 136 | -- offer 137 | writeZQueue :: ZookeeperQueue -> C.ByteString -> Int -> IO (String) 138 | writeZQueue zkQueue value prio = do 139 | r <- Z.create (zqHandle zkQueue) 140 | (zqBasePath zkQueue ++ "/" ++ (nodePrefix (zqNodeName zkQueue) prio)) 141 | (Just value) 142 | (zqAcls zkQueue) 143 | [Z.Sequence] 144 | case r of 145 | Right znode -> return $ head $ reverse (splitOn "/" znode) 146 | Left zkerr -> throwZKError "writeZQueue" zkerr 147 | 148 | -- destroy 149 | destroyZQueue :: ZookeeperQueue -> IO () 150 | destroyZQueue _zkQueue = return () 151 | 152 | -- elems 153 | listZQueue :: ZookeeperQueue -> IO ([C.ByteString]) 154 | listZQueue zkQueue = do 155 | results <- getChildren zkQueue 156 | values <- forM (sortChildren results) getItem 157 | return (catMaybes values) 158 | where 159 | getItem x = do 160 | e <- Z.get (zqHandle zkQueue) (zqBasePath zkQueue ++ "/" ++ x) Nothing 161 | case e of 162 | Right (mValue, _stat) -> return (mValue) 163 | Left Z.NoNodeError -> return (Nothing) 164 | Left zkerr -> throwZKError "listZQueue" zkerr 165 | 166 | -- items 167 | itemsZQueue :: ZookeeperQueue -> IO ([String]) 168 | itemsZQueue zkQueue = do 169 | items <- getChildren zkQueue 170 | return (sortChildren items) 171 | 172 | -- count 173 | countZQueue :: ZookeeperQueue -> IO (Int) 174 | countZQueue zkQueue = do 175 | items <- getChildren zkQueue 176 | return (length items) 177 | 178 | ---- 179 | 180 | getChildren :: ZookeeperQueue -> IO ([String]) 181 | getChildren zkQueue = do 182 | e <- Z.getChildren (zqHandle zkQueue) (zqBasePath zkQueue) Nothing 183 | case e of 184 | Right results -> return (results) 185 | Left zkerr -> throwZKError "getChildren" zkerr 186 | 187 | sortChildren :: [String] -> [String] 188 | sortChildren = sort . filter (isPrefixOf qnPrefix) 189 | 190 | fullPath :: ZookeeperQueue -> String -> String 191 | fullPath zkQueue x = (zqBasePath zkQueue ++ "/" ++ x) 192 | 193 | nodePrefix :: String -> Int -> String 194 | nodePrefix base prio = base ++ priorityPart' ++ "-" 195 | where 196 | priority = if prio > maxPrio then maxPrio else (if prio < minPrio then minPrio else prio) 197 | plus = priority >= 0 198 | priorityPart = show $ if plus then abs priority else maxPrio + 1 + priority 199 | priorityPart' = (if plus then "0" else "-") 200 | ++ (take (3 - length priorityPart) $ repeat '0') 201 | ++ priorityPart 202 | 203 | throwZKError :: String -> Z.ZKError -> IO a 204 | throwZKError func zkerr = throwIO $ SessionError (func ++ ": " ++ show zkerr) 205 | 206 | createZnodeRecursively :: Z.Zookeeper -> String -> Maybe C.ByteString -> Z.AclList -> [Z.CreateFlag] -> IO (Either Z.ZKError String) 207 | createZnodeRecursively z path mData acls flags = do 208 | createZnodeRecursively' z (reverse $ splitOn "/" path) mData acls flags 209 | 210 | createZnodeRecursively' :: Z.Zookeeper -> [String] -> Maybe C.ByteString -> Z.AclList -> [Z.CreateFlag] -> IO (Either Z.ZKError String) 211 | createZnodeRecursively' _ [] _ _ _ = return $ Right "/" 212 | createZnodeRecursively' _ ("":[]) _ _ _ = return $ Right "/" 213 | createZnodeRecursively' z revZnodes value acls cflags = do 214 | let path = intercalate "/" (reverse revZnodes) 215 | eStats <- Z.exists z path Nothing 216 | case eStats of 217 | Right _stat -> return $ Right path 218 | Left Z.NoNodeError -> do 219 | e <- createZnodeRecursively' z (tail revZnodes) Nothing acls cflags 220 | case e of 221 | Right _ -> do 222 | r <- Z.create z path value acls cflags 223 | return $ case r of 224 | Right newPath -> Right newPath 225 | Left zkerr -> Left zkerr 226 | Left zkerr -> return (Left zkerr) 227 | Left zkerr -> return (Left zkerr) 228 | 229 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Class.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {- | Class definitions 5 | -} 6 | module Network.JobQueue.Class where 7 | 8 | {- | Environment class 9 | -} 10 | class Env a where 11 | 12 | {- | Description class 13 | -} 14 | class (Show a) => Desc a where 15 | {- | Define the description of a unit. 16 | -} 17 | desc :: a -> String 18 | desc x = show x 19 | 20 | {- | Define the short description of a unit. 21 | -} 22 | shortDesc :: a -> String 23 | shortDesc x = takeWhile (/= ' ') $ show x 24 | 25 | {- | Unit class 26 | -} 27 | class (Read a, Show a, Desc a, Eq a) => Unit a where 28 | {- | Define the priority of a unit. 29 | -} 30 | getPriority :: a -> Int 31 | getPriority _ju = 1 32 | 33 | {- | Define the recovery state of a unit. 34 | -} 35 | getRecovery :: a -> a 36 | getRecovery ju = ju 37 | 38 | {- | Define the logging necessity of a unit. 39 | -} 40 | toBeLogged :: a -> Bool 41 | toBeLogged _ju = False 42 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Job.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | module Network.JobQueue.Job ( 5 | Job(jobState, jobUnit, jobCTime, jobOnTime, jobId, jobGroup, jobPriority, StopTheWorld) 6 | , JobState(..) 7 | , buildActionState 8 | , process 9 | , createJob 10 | , createOnTimeJob 11 | , printJob 12 | , module Network.JobQueue.Types 13 | , module Network.JobQueue.Action 14 | ) where 15 | 16 | import Control.Monad.State hiding (state) 17 | 18 | import Network.JobQueue.Class 19 | import Network.JobQueue.AuxClass 20 | import Network.JobQueue.Types 21 | import Network.JobQueue.Action 22 | import Network.JobQueue.Job.Internal 23 | 24 | -------------------------------- 25 | 26 | buildActionState :: (Env e, Unit a) => JobM e a () -> IO (JobActionState e a) 27 | buildActionState jobs = execStateT (runS jobs) (JobActionState []) 28 | 29 | {- | Declare a function which accepts a unit and execute the action of it if possible. 30 | -} 31 | process :: (Aux e, Env e, Unit a) => (a -> ActionM e a ()) -> JobM e a () 32 | process action = modify $ addAction $ eval action 33 | 34 | eval :: (Aux e, Env e, Unit a) => (a -> ActionM e a ()) -> ActionFn e a 35 | eval action env ju = runAction env ju (action ju) 36 | 37 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Job/Internal.hs: -------------------------------------------------------------------------------- 1 | 2 | module Network.JobQueue.Job.Internal where 3 | 4 | import Data.Time.Clock 5 | import System.Log.Logger 6 | import System.IO 7 | 8 | import Network.JobQueue.Class 9 | 10 | data JobState = Initialized | Runnable | Running | Aborted | Finished 11 | deriving (Show, Read, Eq) 12 | 13 | {- | Job control block 14 | Job consists of /State/, /Unit/, /CTime/, /OnTime/, /Id/, /Group/, and /Priority/. 15 | 16 | - State - takes one of 5 states (initialized, runnable, running, aborted and finished) 17 | 18 | - Unit - an instance of Unit class, which is specified by type parameter of Job data type 19 | 20 | - CTime - creation time 21 | 22 | - OnTime - the time at which this job starts 23 | 24 | - Id - Identifier of this job 25 | 26 | - Group - Group ID of this job 27 | 28 | - Priority - the priority of this job 29 | 30 | -} 31 | data Job a = 32 | Job { 33 | jobState :: JobState 34 | , jobUnit :: a 35 | , jobCTime :: UTCTime 36 | , jobOnTime :: UTCTime 37 | , jobId :: Int 38 | , jobGroup :: Int 39 | , jobPriority :: Int } 40 | | StopTheWorld 41 | deriving (Show, Read, Eq) 42 | 43 | createJob :: (Unit a) => JobState -> a -> IO (Job a) 44 | createJob state unit = do 45 | ctime <- getCurrentTime 46 | return (Job state unit ctime ctime (defaultId) (defaultGroup) (getPriority unit)) 47 | 48 | createOnTimeJob :: (Unit a) => JobState -> UTCTime -> a -> IO (Job a) 49 | createOnTimeJob state ontime unit = do 50 | ctime <- getCurrentTime 51 | return (Job state unit ctime ontime (defaultId) (defaultGroup) (getPriority unit)) 52 | 53 | printJob :: (Unit a) => Job a -> IO () 54 | printJob job = case job of 55 | Job {} -> do 56 | noticeM "job" $ show (jobUnit job) 57 | hPutStrLn stdout $ desc (jobUnit job) 58 | hFlush stdout 59 | StopTheWorld -> return () 60 | 61 | ---------------------------------------------------------------- PRIVATE 62 | 63 | defaultId :: Int 64 | defaultId = -1 65 | 66 | defaultGroup :: Int 67 | defaultGroup = -1 68 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/JobQueue.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Network.JobQueue.JobQueue ( 7 | JobQueue 8 | , Session 9 | , openSession 10 | , newSession 11 | , closeSession 12 | , openJobQueue 13 | , closeJobQueue 14 | , countJobQueue 15 | , resumeJobQueue 16 | , suspendJobQueue 17 | , executeJob 18 | , scheduleJob 19 | , deleteJob 20 | , clearJobs 21 | , peekJob 22 | ) where 23 | 24 | import Control.Applicative 25 | import Control.Concurrent 26 | import Control.Monad 27 | import Control.Exception 28 | import qualified Data.ByteString.Char8 as BS 29 | import Data.Maybe 30 | 31 | import Network.JobQueue.Class 32 | import Network.JobQueue.AuxClass 33 | import Network.JobQueue.Types 34 | import Network.JobQueue.Job 35 | import Network.JobQueue.Backend 36 | import Network.JobQueue.Backend.Class 37 | import Network.JobQueue.Backend.Types 38 | 39 | import Network.JobQueue.JobQueue.Internal 40 | 41 | 42 | {- | A session handler 43 | 44 | A session usually represents a database session to access job queues stored in the backend 45 | database. 46 | -} 47 | data Session = Session Bool String Backend 48 | 49 | {- | Open a queue session with a resource locator 50 | -} 51 | openSession :: String -- ^ a resource locator 52 | -> IO (Session) -- ^ a session handler 53 | openSession locator = Session True locator <$> openBackend locator 54 | 55 | {- | Create a queue session with a backend handler 56 | -} 57 | newSession :: String -- ^ a resource locator (dummy) 58 | -> Backend -> Session -- ^ a session handler 59 | newSession dummyLocator backend = Session False dummyLocator backend 60 | 61 | {- | Close a queue session if needed 62 | -} 63 | closeSession :: Session -> IO () 64 | closeSession (Session isOwner _locator backend) = when isOwner $ bClose backend 65 | 66 | {- | Open a job queue with a session. 67 | -} 68 | openJobQueue :: (Env e, Unit a) 69 | => Session -- ^ a session handler 70 | -> String -- ^ a queue name 71 | -> JobM e a () -- ^ a state machine definition 72 | -> IO (JobQueue e a) 73 | openJobQueue (Session _isOwner _locator _backend@(Backend { bOpenQueue = oq })) 74 | name 75 | jobm = do 76 | JobQueue <$> oq name <*> buildActionState jobm 77 | 78 | {- | Close a job queue. 79 | -} 80 | closeJobQueue :: (Env e, Unit a) => JobQueue e a -> IO () 81 | closeJobQueue JobQueue { jqBackendQueue = bq } = closeQueue bq 82 | 83 | {- | Count the number of jobs queued in a job queue. 84 | -} 85 | countJobQueue :: (Env e, Unit a) => JobQueue e a -> IO (Int) 86 | countJobQueue JobQueue { jqBackendQueue = bq } = countQueue bq 87 | 88 | {- | Resume a job queue 89 | -} 90 | resumeJobQueue :: (Env e, Unit a) => JobQueue e a -> IO (Bool) 91 | resumeJobQueue jobqueue = do 92 | r <- peekJob' jobqueue 93 | case r of 94 | Just (job, nodeName, idName, _version) -> case actionForJob job idName of 95 | Execute StopTheWorld -> resume jobqueue nodeName 96 | _ -> return True 97 | _ -> return True 98 | where 99 | resume JobQueue { jqBackendQueue = bq } key = deleteQueue bq key 100 | 101 | {- | Suspend a job queue 102 | -} 103 | suspendJobQueue :: forall e. forall a. (Env e, Unit a) => JobQueue e a -> IO (Bool) 104 | suspendJobQueue jobqueue = do 105 | r <- peekJob' jobqueue 106 | case r of 107 | Just (job, _nodeName, idName, _version) -> case actionForJob job idName of 108 | Execute StopTheWorld -> return False 109 | _ -> suspend jobqueue >> return True 110 | _ -> suspend jobqueue >> return True 111 | where 112 | suspend JobQueue { jqBackendQueue = bq } = writeQueue bq (pack (StopTheWorld :: Job a)) (-1) 113 | 114 | {- | Execute an action of the head job in a job queue. 115 | -} 116 | executeJob :: (Aux e, Env e, Unit a) => JobQueue e a -> e -> IO () 117 | executeJob jobqueue env = do 118 | r <- peekJob' jobqueue 119 | case r of 120 | Just (job, nodeName, idName, version) -> case actionForJob job idName of 121 | Execute StopTheWorld -> do 122 | threadDelay 1000000 123 | return () 124 | Execute job' -> do 125 | isUpdated <- updateJob jobqueue nodeName job' version 126 | when (isUpdated && jobState job == Runnable && jobState job' == Running) $ do 127 | executeJob' jobqueue env nodeName job' version >>= afterExecuteJob jobqueue env nodeName job' version 128 | auxHandleAfterExecute env job' 129 | Delete -> do 130 | void $ deleteJob jobqueue nodeName 131 | executeJob jobqueue env 132 | Skip -> return () 133 | Nothing -> return () 134 | 135 | {- | Schedule a job. 136 | -} 137 | scheduleJob :: (Unit a) 138 | => JobQueue e a -- ^ a job queue 139 | -> a -- ^ a unit 140 | -> IO () 141 | scheduleJob JobQueue { jqBackendQueue = bq } ju = do 142 | job <- createJob Initialized ju 143 | void $ writeQueue bq (pack job) (getPriority ju) 144 | 145 | {- | Delete a job from a job queue. 146 | -} 147 | deleteJob :: (Unit a) 148 | => JobQueue e a -- ^ a job queue 149 | -> String -- ^ a job identifier 150 | -> IO Bool 151 | deleteJob JobQueue { jqBackendQueue = bq } nodeName = do 152 | deleteQueue bq nodeName `catch` \e -> case e of 153 | NotFound _ -> return True 154 | _ -> throwIO e 155 | 156 | {- | Clear all jobs from a job queue. 157 | -} 158 | clearJobs :: (Unit a) 159 | => JobQueue e a -- ^ a job queue 160 | -> IO [(String, Job a)] 161 | clearJobs JobQueue { jqBackendQueue = bq } = loop [] 162 | where 163 | loop dequeued = do 164 | obj <- readQueue bq 165 | case obj of 166 | Nothing -> return dequeued 167 | Just (bs, nodeName) -> case (fmap fst . listToMaybe . reads) $ BS.unpack bs of 168 | Nothing -> return dequeued 169 | Just job -> loop ((nodeName, job):dequeued) 170 | 171 | {- | Peek a job form a job queue. 172 | -} 173 | peekJob :: (Unit a) 174 | => JobQueue e a -- ^ a job queue 175 | -> IO (Maybe (Job a)) 176 | peekJob jobqueue = do 177 | mjob <- peekJob' jobqueue 178 | return $ case mjob of 179 | Just (job, _nodeName, _idName, _version) -> Just job 180 | Nothing -> Nothing 181 | 182 | ---------------------------------------------------------------- PRIVATE 183 | 184 | 185 | 186 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/JobQueue/Internal.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE GADTs #-} 5 | 6 | module Network.JobQueue.JobQueue.Internal where 7 | 8 | import qualified Data.ByteString.Char8 as BS 9 | import Control.Exception 10 | import Data.Time.Clock 11 | import Control.Monad 12 | import Data.Maybe 13 | 14 | import Network.JobQueue.Class 15 | import Network.JobQueue.AuxClass 16 | import Network.JobQueue.Types 17 | import Network.JobQueue.Action 18 | import Network.JobQueue.Job 19 | import Network.JobQueue.Backend.Class 20 | import Network.JobQueue.Backend.Types 21 | 22 | 23 | data JobQueue e a where 24 | JobQueue :: (BackendQueue q) => { 25 | jqBackendQueue :: q 26 | , jqActionState :: JobActionState e a 27 | } -> JobQueue e a 28 | 29 | data ActionForJob a = (Unit a) => Execute (Job a) | Delete | Skip 30 | 31 | 32 | actionForJob :: Unit a => Job a -> String -> ActionForJob a 33 | actionForJob job idName = do 34 | case job of 35 | StopTheWorld -> Execute job 36 | _ -> case jobState job of 37 | Initialized -> case (fmap fst . listToMaybe . reads) idName of 38 | Just ident -> Execute $ job { jobState = Runnable, jobId = ident } 39 | Nothing -> Execute $ job { jobState = Runnable, jobId = (-1) } 40 | Runnable -> Execute $ job { jobState = Running } 41 | Running -> Skip 42 | Aborted -> Skip 43 | Finished -> Delete 44 | 45 | peekJob' :: (Unit a) => JobQueue e a -> IO (Maybe (Job a, String, String, Int)) 46 | peekJob' JobQueue { jqBackendQueue = bq } = do 47 | obj <- peekQueue bq 48 | case obj of 49 | Nothing -> return (Nothing) 50 | Just (value, nodeName, idName, version) -> do 51 | case (fmap fst . listToMaybe . reads) $ BS.unpack value of 52 | Nothing -> return (Nothing) 53 | Just job -> return (Just (job, nodeName, idName, version)) 54 | 55 | executeJob' :: (Aux e, Env e, Unit a) => JobQueue e a -> e -> String -> Job a -> Int -> IO (Either Break (Maybe (RuntimeState a))) 56 | executeJob' jqueue@JobQueue { jqBackendQueue = bq, jqActionState = actionState } env nodeName currentJob version = do 57 | currentTime <- getCurrentTime 58 | if jobOnTime currentJob < currentTime 59 | then do 60 | runActionState actionState env (jobUnit currentJob) 61 | else do 62 | r <- updateJob jqueue nodeName currentJob { jobState = Finished } (version+1) 63 | when r $ void $ writeQueue bq (pack $ currentJob { jobState = Runnable } ) (jobPriority currentJob) 64 | return $ Right Nothing 65 | 66 | afterExecuteJob :: (Aux e, Env e, Unit a) => JobQueue e a -> e -> String -> Job a -> Int -> Either Break (Maybe (RuntimeState a)) -> IO () 67 | afterExecuteJob jqueue env nodeName currentJob version mResult = case mResult of 68 | Right (Just (RS mNextJu forks _)) -> do 69 | case mNextJu of 70 | Just nextJu -> do 71 | _r <- updateJob jqueue nodeName currentJob { jobState = Runnable, jobUnit = nextJu } (version+1) 72 | return () 73 | Nothing -> do 74 | _r <- updateJob jqueue nodeName currentJob { jobState = Finished } (version+1) 75 | return () 76 | forM_ (reverse forks) $ \(forked, ontime) -> rescheduleJob jqueue ontime forked 77 | Right (Nothing) -> recover Nothing -- nothing to do anymore 78 | Left (Failure _msg) -> do 79 | n <- auxHandleFailure env (Just currentJob) 80 | recover n 81 | Left Retriable -> do 82 | _r <- updateJob jqueue nodeName currentJob { jobState = Runnable } (version+1) 83 | return () 84 | Left (Unhandled _someException) -> do 85 | _r <- updateJob jqueue nodeName currentJob { jobState = Finished } (version+1) 86 | return () 87 | where 88 | recover n = case n of 89 | Just nextJu -> do 90 | _r <- updateJob jqueue nodeName nextJu (version+1) 91 | return () 92 | Nothing -> do 93 | _r <- updateJob jqueue nodeName currentJob { jobState = Finished } (version+1) 94 | return () 95 | 96 | rescheduleJob :: (Unit a) => JobQueue e a -> Maybe UTCTime -> a -> IO () 97 | rescheduleJob JobQueue { jqBackendQueue = bq } mOntime ju = do 98 | job <- case mOntime of 99 | Just ontime -> createOnTimeJob Initialized ontime ju 100 | Nothing -> createJob Initialized ju 101 | void $ writeQueue bq (pack $ job) (getPriority ju) 102 | 103 | updateJob :: (Unit a) => JobQueue e a -> String -> Job a -> Int -> IO (Bool) 104 | updateJob JobQueue { jqBackendQueue = bq } nodeName job version = do 105 | updateQueue bq nodeName (pack job) version `catch` handleError 106 | where 107 | handleError :: BackendError -> IO (Bool) 108 | handleError _ = return (False) 109 | 110 | pack :: (Unit a) => Job a -> BS.ByteString 111 | pack = BS.pack . show 112 | 113 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Logger.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Network.JobQueue.Logger 6 | ( logDebug 7 | , logInfo 8 | , logWarn 9 | , logError 10 | , logNotice 11 | , logCritical 12 | , Only 13 | ) where 14 | 15 | import qualified Data.Text as T 16 | import qualified Data.Text.Lazy as LT 17 | import qualified Control.Monad.Logger as ML 18 | import Language.Haskell.TH.Syntax (Q, Exp, qLocation) 19 | import Data.Text.Format 20 | import Control.Applicative 21 | import Control.Monad.Reader 22 | 23 | import Network.JobQueue.Types 24 | import Network.JobQueue.Class 25 | 26 | logTH :: ML.LogLevel -> Q Exp 27 | logTH level = 28 | [|\a b -> do 29 | ju <- getJobUnit <$> ask 30 | ML.monadLoggerLog $(qLocation >>= ML.liftLoc) (T.pack "") level $ T.concat 31 | [ (LT.toStrict $ format (a :: Format) b) 32 | , " (" 33 | , T.pack $ desc ju 34 | , ")" 35 | ] 36 | |] 37 | 38 | logDebug :: Q Exp 39 | logDebug = logTH ML.LevelDebug 40 | 41 | logInfo :: Q Exp 42 | logInfo = logTH ML.LevelInfo 43 | 44 | logWarn :: Q Exp 45 | logWarn = logTH ML.LevelWarn 46 | 47 | logError :: Q Exp 48 | logError = logTH ML.LevelError 49 | 50 | logNotice :: Q Exp 51 | logNotice = logTH (ML.LevelOther "notice") 52 | 53 | logCritical :: Q Exp 54 | logCritical = logTH (ML.LevelOther "critical") 55 | 56 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Param.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | 11 | 12 | module Network.JobQueue.Param 13 | ( ParamEnv 14 | , envParameters 15 | , Param 16 | , decodeParam 17 | , encodeParam 18 | , param 19 | ) where 20 | 21 | import Data.Maybe 22 | import qualified Data.Aeson as A 23 | import qualified Data.ByteString.Lazy.Char8 as B 24 | import Network.JobQueue.Class 25 | import Network.JobQueue.Types 26 | import Network.JobQueue.Action (getEnv,abort) 27 | import Network.JobQueue.Logger 28 | 29 | {- | Environment with a parameter set 30 | -} 31 | class (Env a) => ParamEnv a where 32 | envParameters :: a -> [(String, String)] 33 | envParameters _env = [] 34 | 35 | class Param a where 36 | decodeParam :: String -> Maybe a 37 | encodeParam :: a -> String 38 | 39 | instance Param String where 40 | decodeParam str = (fmap fst . listToMaybe . reads) str 41 | encodeParam val = show val 42 | 43 | instance Param Int where 44 | decodeParam str = (fmap fst . listToMaybe . reads) str 45 | encodeParam val = show val 46 | 47 | instance Param Integer where 48 | decodeParam str = (fmap fst . listToMaybe . reads) str 49 | encodeParam val = show val 50 | 51 | instance Param Double where 52 | decodeParam str = (fmap fst . listToMaybe . reads) str 53 | encodeParam val = show val 54 | 55 | instance Param A.Value where 56 | decodeParam str = A.decode (B.pack str) 57 | encodeParam val = B.unpack $ A.encode val 58 | 59 | {- | Get a parameter value with a key from the environment in action. 60 | This is a special function for ParamEnv. 61 | -} 62 | param :: (ParamEnv e, Unit a, Param b) => (String, String) -> ActionM e a b 63 | param (key, defaultValue) = do 64 | env <- getEnv 65 | case decodeParam defaultValue of 66 | Nothing -> do 67 | $(logCritical) "internal error. no parse: " [show (key, defaultValue)] 68 | abort 69 | Just defaultValue' -> case lookup key (envParameters env) of 70 | Just value -> return (fromMaybe defaultValue' (decodeParam value)) 71 | Nothing -> return (defaultValue') 72 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Types.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances #-} 8 | {-# LANGUAGE CPP #-} 9 | 10 | module Network.JobQueue.Types 11 | ( JobActionState(..) 12 | , JobM 13 | , ActionM 14 | , ActionT 15 | , ActionFn 16 | , ActionEnv(..) 17 | , Unit(..) 18 | , RuntimeState(..) 19 | , Break(..) 20 | , LogLevel(..) 21 | , setNextJob 22 | , setNextJobIfEmpty 23 | , emptyNextJob 24 | , addForkJob 25 | , incrementCommits 26 | , getCommits 27 | , runS 28 | , runAM 29 | , addAction 30 | , setResult 31 | ) where 32 | 33 | import Data.Time.Clock 34 | 35 | import Control.Applicative 36 | import Control.Monad.Base 37 | import Control.Monad.Trans.Control 38 | import Control.Monad.Except 39 | import Control.Monad.Reader 40 | import Control.Monad.State 41 | import Control.Monad.Logger 42 | import Control.Exception 43 | import Data.Default (Default, def) 44 | 45 | import Network.JobQueue.Class 46 | 47 | -------------------------------- Types 48 | 49 | data Break = Unhandled SomeException | Failure String | Retriable deriving (Show) 50 | 51 | -------------------------------- State in Action 52 | 53 | data RuntimeState a = RS 54 | { rsNextJob :: (Maybe a) 55 | , rsNextForks :: [(a, Maybe UTCTime)] 56 | , rsCommits :: Int 57 | } deriving (Show) 58 | 59 | instance (Unit a) => Default (RuntimeState a) where 60 | def = RS Nothing [] 0 61 | 62 | setNextJob :: (Unit a) => a -> (RuntimeState a) -> (RuntimeState a) 63 | setNextJob x next@(RS _ _ _) = next { rsNextJob = Just x } 64 | 65 | setNextJobIfEmpty :: (Unit a) => a -> (RuntimeState a) -> (RuntimeState a) 66 | setNextJobIfEmpty x next@(RS mju _ _) = maybe (next { rsNextJob = Just x }) (const next) mju 67 | 68 | emptyNextJob :: (Unit a) => (RuntimeState a) -> (RuntimeState a) 69 | emptyNextJob next@(RS _ _ _) = next { rsNextJob = Nothing } 70 | 71 | addForkJob :: (Unit a) => (a, Maybe UTCTime) -> (RuntimeState a) -> (RuntimeState a) 72 | addForkJob (x, mt) next@(RS _ xs _) = next { rsNextForks = ((x, mt):xs) } 73 | 74 | incrementCommits :: (Unit a) => (RuntimeState a) -> (RuntimeState a) 75 | incrementCommits next@(RS _ _ cnt) = next { rsCommits = cnt + 1 } 76 | 77 | getCommits :: (Unit a) => (RuntimeState a) -> Int 78 | getCommits (RS _ _ cnt) = cnt 79 | 80 | -------------------------------- JobActionState 81 | 82 | type ActionFn e a = e -> a -> IO (Either Break (Maybe (RuntimeState a))) 83 | 84 | data JobActionState e a = JobActionState { jobActions :: [ActionFn e a] } 85 | 86 | addAction :: (Env e, Unit a) => ActionFn e a -> JobActionState e a -> JobActionState e a 87 | addAction action s@(JobActionState { jobActions = actions }) = s { jobActions = action:actions } 88 | 89 | instance Default (JobActionState e a) where 90 | def = JobActionState [] 91 | 92 | -------------------------------- ActionM 93 | 94 | newtype (Env e, Unit a) => JobM e a b = JobM { runS :: StateT (JobActionState e a) IO b } 95 | deriving (Monad, MonadIO, Functor, Applicative, MonadState (JobActionState e a)) 96 | 97 | data ActionEnv e a = ActionEnv 98 | { getJobEnv :: e 99 | , getJobUnit :: a 100 | } 101 | 102 | newtype ActionT e a m b = ActionT 103 | { runAM :: ExceptT Break (ReaderT (ActionEnv e a) (StateT (Maybe (RuntimeState a)) (LoggingT m))) b 104 | } deriving ( Applicative, Functor, Monad, MonadIO, MonadLogger, MonadError Break 105 | , MonadReader (ActionEnv e a), MonadState (Maybe (RuntimeState a)), MonadBase base) 106 | 107 | type ActionM e a b = ActionT e a IO b 108 | 109 | instance MonadTrans (ActionT e a) where 110 | lift = ActionT . lift . lift . lift . lift 111 | 112 | instance MonadTransControl (ActionT e a) where 113 | #if MIN_VERSION_monad_control(1,0,0) 114 | type StT (ActionT e a) b = (Either Break b, Maybe (RuntimeState a)) 115 | restoreT = ActionT . ExceptT . ReaderT . const . StateT . const 116 | . LoggingT . const 117 | liftWith f = ActionT . ExceptT . ReaderT $ \r -> StateT $ \s -> LoggingT $ \l -> 118 | liftM (\x -> (Right x, s)) 119 | (f $ \t -> (runLoggingT (runStateT (runReaderT (runExceptT (runAM t)) r) s) l)) 120 | #else 121 | newtype StT (ActionT e a) b = StAction { unStAction :: (Either Break b, Maybe (RuntimeState a)) } 122 | restoreT = ActionT . ExceptT . ReaderT . const . StateT . const 123 | . LoggingT . const . liftM unStAction 124 | liftWith f = ActionT . ExceptT . ReaderT $ \r -> StateT $ \s -> LoggingT $ \l -> 125 | liftM (\x -> (Right x, s)) 126 | (f $ \t -> liftM StAction (runLoggingT (runStateT (runReaderT (runExceptT (runAM t)) r) s) l)) 127 | #endif 128 | 129 | instance MonadBaseControl base m => MonadBaseControl base (ActionT e a m) where 130 | #if MIN_VERSION_monad_control(1,0,0) 131 | type StM (ActionT e a m) b = ComposeSt (ActionT e a) m b 132 | liftBaseWith = defaultLiftBaseWith 133 | restoreM = defaultRestoreM 134 | #else 135 | newtype StM (ActionT e a m) b = StMActionT { unStMActionT :: ComposeSt (ActionT e a) m b } 136 | liftBaseWith = defaultLiftBaseWith StMActionT 137 | restoreM = defaultRestoreM unStMActionT 138 | #endif 139 | 140 | setResult :: (Unit a) => Maybe (RuntimeState a) -> Maybe (RuntimeState a) -> Maybe (RuntimeState a) 141 | setResult result _ = result 142 | 143 | 144 | -------------------------------- 145 | -------------------------------------------------------------------------------- /jobqueue/src/Network/JobQueue/Util.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | module Network.JobQueue.Util 5 | ( waitForAllJobs 6 | , waitUntilMatch 7 | ) where 8 | 9 | import Data.Maybe 10 | import Control.Concurrent 11 | import Network.JobQueue.Types 12 | import Network.JobQueue.Class 13 | import Network.JobQueue.Job 14 | import Network.JobQueue.JobQueue 15 | import Network.JobQueue.JobQueue.Internal 16 | import Text.Regex.Posix 17 | 18 | waitForAllJobs :: (Env e, Unit a) => JobQueue e a -> Int -> ((Maybe (Job a)) -> Int -> IO ()) -> IO (Maybe (Job a)) 19 | waitForAllJobs jq timeoutCount = waitWhile jq (\mjob count -> isJust mjob && count < timeoutCount) 20 | 21 | waitUntilMatch :: (Env e, Unit a) => JobQueue e a -> String -> Int -> ((Maybe (Job a)) -> Int -> IO ()) -> IO (Maybe (Job a)) 22 | waitUntilMatch jq pattern timeoutCount = waitWhile jq (\mjob count -> not (show mjob =~ pattern) && count < timeoutCount) 23 | 24 | waitWhile :: (Env e, Unit a) 25 | => JobQueue e a 26 | -> (Maybe (Job a) -> Int -> Bool) 27 | -> (Maybe (Job a) -> Int -> IO ()) 28 | -> IO (Maybe (Job a)) 29 | waitWhile jq cond reportAct = loop 0 30 | where 31 | loop count = do 32 | mjob <- liftIO $ peekJob jq 33 | reportAct mjob count 34 | if cond mjob count 35 | then do 36 | mjob' <- innerloop jq mjob cond 37 | if mjob' == mjob then return mjob else loop (count + 1) 38 | else do 39 | return mjob 40 | 41 | innerloop :: (Env e, Unit a) => JobQueue e a -> Maybe (Job a) -> (Maybe (Job a) -> Int -> Bool) -> IO (Maybe (Job a)) 42 | innerloop jq mjob0 cond = loop 0 43 | where 44 | loop tickCount = do 45 | threadDelay 250000 46 | mjob <- liftIO $ peekJob jq 47 | if mjob0 == mjob && cond mjob tickCount then loop (tickCount + 1) else return mjob 48 | -------------------------------------------------------------------------------- /jobqueue/test/Action.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module Action (testAction) where 8 | 9 | import Control.Exception 10 | import Test.Hspec 11 | import Control.Monad 12 | import System.Directory 13 | import System.IO.Error (isDoesNotExistError) 14 | import Control.Concurrent 15 | import Control.Concurrent.Async 16 | import System.IO 17 | import Control.Concurrent.STM 18 | 19 | import Network.JobQueue 20 | 21 | data JobEnv = JobEnv { 22 | jeHello :: String 23 | } deriving (Eq, Show) 24 | 25 | instance Env JobEnv where 26 | 27 | instance Aux JobEnv where 28 | auxHandleFailure _ mjob = do 29 | case mjob of 30 | Just job -> do 31 | nextJob <- createJob Runnable (getRecovery (jobUnit job)) 32 | return (Just nextJob) 33 | Nothing -> return (Nothing) 34 | 35 | data JobUnit = Initial | Recovery deriving (Show, Read, Eq, Ord) 36 | 37 | instance Unit JobUnit where 38 | getPriority _ju = 1 39 | getRecovery _ju = Recovery 40 | toBeLogged _ = False 41 | 42 | instance Desc JobUnit where 43 | 44 | newMarker val = do 45 | var <- liftIO $ newTVarIO val 46 | return (liftIO $ readTVarIO var, liftIO . atomically . (writeTVar var)) 47 | 48 | testAction :: String -> Spec 49 | testAction backend = do 50 | describe "action" $ do 51 | it "unhandled error" $ do 52 | (get, set) <- newMarker 0 53 | go $ buildJobQueue backend "/unhandled_error_1" $ do 54 | process $ \Initial -> do 55 | set 1 56 | $(logWarn) "Throw an IOError." () 57 | liftIO $ throwIO $ userError "an IOError" 58 | $(logError) "Never reach here." () 59 | set 2 60 | fin 61 | process $ \Recovery -> do 62 | set 3 63 | fin 64 | get `shouldReturn` 1 65 | 66 | it "abort and recover" $ do 67 | (get, set) <- newMarker 0 68 | go $ buildJobQueue backend "/abort_and_recover_1" $ do 69 | process $ \Initial -> do 70 | set 1 71 | $(logWarn) "Abort" () 72 | abort 73 | $(logError) "Never reach here." () 74 | set 2 75 | fin 76 | process $ \Recovery -> do 77 | set 3 78 | fin 79 | get `shouldReturn` 3 80 | 81 | where 82 | go withJobQueue = withJobQueue $ \jq -> do 83 | scheduleJob jq Initial 84 | countJobQueue jq `shouldReturn` 1 85 | let loop = \env jq' -> do 86 | executeJob jq' env 87 | count <- countJobQueue jq' 88 | when (count > 0) $ loop env jq' 89 | loop (JobEnv "hello") jq 90 | countJobQueue jq `shouldReturn` 0 91 | 92 | -------------------------------------------------------------------------------- /jobqueue/test/BackendQueue.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module BackendQueue (testJobQueueBackend) where 7 | 8 | import Control.Exception 9 | import Test.Hspec 10 | import System.Directory 11 | import System.IO.Error (isDoesNotExistError) 12 | import System.Environment (lookupEnv) 13 | 14 | import qualified Data.ByteString.Char8 as BS 15 | import Network.JobQueue.Backend 16 | import Network.JobQueue.Backend.Types 17 | import Network.JobQueue.Backend.Class 18 | 19 | testJobQueueBackend :: String -> Spec 20 | testJobQueueBackend backend = do 21 | describe "backend queue" $ do 22 | it "peeks" $ do 23 | withBackend backend $ \(Backend { bOpenQueue = openQueue }) -> do 24 | q <- openQueue "/case/peek_1" 25 | k <- writeQueue q (BS.pack "hoge") 0 26 | Just (bs, name, idName, version) <- peekQueue q 27 | _ <- deleteQueue q name 28 | countQueue q `shouldReturn` 0 29 | 30 | it "writes and reads" $ do 31 | withBackend backend $ \(Backend { bOpenQueue = openQueue }) -> do 32 | q <- openQueue "/case/read_and_write_1" 33 | k <- writeQueue q (BS.pack "hoge") 0 34 | readQueue q `shouldReturn` Just (BS.pack "hoge", k) 35 | 36 | it "counts" $ do 37 | withBackend backend $ \(Backend { bOpenQueue = openQueue }) -> do 38 | q <- openQueue "/case/count_1" 39 | _ <- writeQueue q (BS.pack "hoge1") 0 40 | countQueue q `shouldReturn` 1 41 | _ <- writeQueue q (BS.pack "hoge2") 0 42 | countQueue q `shouldReturn` 2 43 | _ <- readQueue q 44 | _ <- readQueue q 45 | return () 46 | 47 | it "has items" $ do 48 | withBackend backend $ \(Backend { bOpenQueue = openQueue }) -> do 49 | q <- openQueue "/case/items_1" 50 | k1 <- writeQueue q (BS.pack "hoge1") 0 51 | itemsQueue q `shouldReturn` [k1] 52 | k2 <- writeQueue q (BS.pack "hoge2") 0 53 | itemsQueue q `shouldReturn` [k1, k2] 54 | _ <- readQueue q 55 | _ <- readQueue q 56 | return () 57 | 58 | ---------------------------------------------------------------- Utils 59 | 60 | withBackend :: String -> (Backend -> IO ()) -> IO () 61 | withBackend backend act = do 62 | bracket (openBackend backend) bClose act 63 | 64 | -------------------------------------------------------------------------------- /jobqueue/test/JobQueue.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module JobQueue (testJobQueue) where 7 | 8 | import Control.Exception 9 | import Test.Hspec 10 | import Control.Monad 11 | import System.Directory 12 | import System.IO.Error (isDoesNotExistError) 13 | import Control.Concurrent 14 | import Control.Concurrent.Async 15 | import System.IO 16 | 17 | import Network.JobQueue 18 | 19 | data JobEnv = JobEnv { 20 | jeHello :: String 21 | } deriving (Eq, Show) 22 | 23 | instance Env JobEnv where 24 | instance Aux JobEnv where 25 | 26 | data JobUnit = HelloStep | WorldStep deriving (Show, Read, Eq, Ord) 27 | 28 | instance Unit JobUnit where 29 | getPriority _ju = 1 30 | getRecovery _ju = HelloStep 31 | 32 | instance Desc JobUnit where 33 | 34 | data Looping = Looping Int deriving (Show, Read, Eq, Ord) 35 | 36 | instance Unit Looping where 37 | getPriority _ju = 1 38 | getRecovery _ju = (Looping 0) 39 | toBeLogged _ = False 40 | 41 | instance Desc Looping where 42 | 43 | testJobQueue :: String -> Spec 44 | testJobQueue backend = do 45 | describe "job queue" $ do 46 | it "says hello" $ do 47 | let withJobQueue = buildJobQueue backend "/says_hello_1" $ do 48 | process $ \WorldStep -> commitIO (putStrLn "world") >> fin 49 | process $ \HelloStep -> do 50 | env <- getEnv 51 | commitIO (putStr $ (jeHello env) ++ ", ") 52 | next WorldStep 53 | withJobQueue $ \jq -> do 54 | scheduleJob jq HelloStep 55 | countJobQueue jq `shouldReturn` 1 56 | withJobQueue $ \jq -> do 57 | let loop = \env jq' -> do 58 | executeJob jq' env 59 | count <- countJobQueue jq' 60 | when (count > 0) $ loop env jq' 61 | loop (JobEnv "hello") jq 62 | countJobQueue jq `shouldReturn` 0 63 | 64 | it "suspends" $ do 65 | let withJobQueue = buildJobQueue backend "/suspends_1" $ do 66 | process $ \WorldStep -> commitIO (putStrLn "world") >> fin 67 | process $ \HelloStep -> do 68 | env <- getEnv 69 | commitIO (putStr $ (jeHello env) ++ ", ") 70 | next WorldStep 71 | withJobQueue $ \jq -> do 72 | scheduleJob jq HelloStep 73 | suspendJobQueue jq `shouldReturn` True 74 | suspendJobQueue jq `shouldReturn` False 75 | step (JobEnv "hello") jq 5 76 | countJobQueue jq `shouldReturn` 2 77 | withJobQueue $ \jq -> do 78 | resumeJobQueue jq `shouldReturn` True 79 | step (JobEnv "hello") jq 5 80 | countJobQueue jq `shouldReturn` 0 81 | 82 | it "can be used concurrently" $ do 83 | let p = process $ \(Looping count) -> do 84 | if count > 0 85 | then liftIO (hPutStr stderr $ " " ++ show count) >> fork (Looping (count - 1)) 86 | else liftIO (hPutStrLn stderr ".") >> fin 87 | env0 = (JobEnv "hello") 88 | buildJobQueue backend "/concurrently_1" p $ \jq -> do 89 | scheduleJob jq (Looping 100) 90 | countJobQueue jq `shouldReturn` 1 91 | bracket (openSession backend) (closeSession) $ \session -> do 92 | let loop = \env jq' -> do 93 | executeJob jq' env 94 | count <- countJobQueue jq' 95 | when (count > 0) $ loop env jq' 96 | _ <- flip mapConcurrently [1..50] $ \_ -> do 97 | jq <- openJobQueue session "/concurrently_1" p 98 | loop env0 jq 99 | closeJobQueue jq 100 | return () 101 | buildJobQueue backend "/concurrently_1" p $ \jq -> do 102 | executeJob jq env0 103 | countJobQueue jq `shouldReturn` 0 104 | return () 105 | 106 | ---------------------------------------------------------------- Utils 107 | 108 | step :: (Aux e, Env e, Unit a) => e -> JobQueue e a -> Int -> IO () 109 | step env jq c 110 | | c > 0 = do 111 | executeJob jq env 112 | step env jq (pred c) 113 | | otherwise = return () 114 | 115 | -------------------------------------------------------------------------------- /jobqueue/test/Main.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) Gree, Inc. 2013 2 | -- License: MIT-style 3 | 4 | module Main where 5 | 6 | import Test.Hspec 7 | import System.Environment (lookupEnv) 8 | import Data.Maybe 9 | import System.IO 10 | 11 | import Action 12 | import BackendQueue 13 | import JobQueue 14 | 15 | main :: IO () 16 | main = do 17 | hSetBuffering stderr LineBuffering 18 | backend <- fmap (fromMaybe "sqlite3://test.sqlite3") $ lookupEnv "JOBQUEUE_TEST_BACKEND" 19 | hspec $ do 20 | testAction backend 21 | testJobQueueBackend backend 22 | testJobQueue backend 23 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - jobqueue/ 4 | - jobqueue-examples/ 5 | extra-deps: 6 | - hzk-2.1.0 7 | - HDBC-2.4.0.1 8 | - HDBC-sqlite3-2.3.3.1 9 | resolver: lts-3.4 10 | --------------------------------------------------------------------------------