----------------------------------------------------------------------------- -- | -- Module : Beanstalk Tests -- Copyright : (c) Greg Heartsfield 2010 -- License : BSD3 -- -- Test hbeanstalkh library against a real beanstalkd server. -- This script assumes the server is running on localhost:11300, and can -- be executed with `runhaskell Tests.hs` -- For best results, this should probably be run against a newly started -- server with zero jobs (restart server, and run without persistence) ----------------------------------------------------------------------------- module Main(main) where import Network.Beanstalk import Control.Exception(finally) import IO(bracket) import Control.Concurrent.MVar import Network.Socket import Test.HUnit import System.Random (randomIO) import Data.Maybe(fromJust) import qualified Data.Map as M import qualified Control.Exception as E import Control.Monad import Control.Concurrent(threadDelay) bs_host = "localhost" bs_port = "11300" -- | Run the tests main = runTestTT tests tests = TestList [ TestLabel "Connect" connectTest, TestLabel "Use" useTest, TestLabel "Watch" watchTest, TestLabel "Put" putTest, TestLabel "Put2" putTest2, TestLabel "Put/Reserve" putReserveTest, TestLabel "Put/Reserve-With-Timeout" putReserveWithTimeoutTest, TestLabel "Peek" peekTest, TestLabel "KickDelay" kickDelayTest, TestLabel "Release" releaseTest, TestLabel "Ignore" ignoreTest, TestLabel "Delete" deleteTest, TestLabel "Bury" buryTest, TestLabel "PeekReady" peekReadyTest, TestLabel "PeekJob" peekJobTest, TestLabel "PeekDelayed" peekDelayedTest, TestLabel "PeekBuried" peekBuriedTest, TestLabel "StatsJob" statsJobTest, TestLabel "ServerStats" statsTest, TestLabel "ListTubes" listTubesTest, TestLabel "ListTubesWatched" listTubesWatchedTest, TestLabel "ListTubeUsed" listTubeUsedTest, TestLabel "Touch" touchJobTest, TestLabel "Pause" pauseTubeTest, TestLabel "isNotfoundException" isNotFoundExceptionTest, TestLabel "isBadFormatException" isBadFormatxceptionTest, TestLabel "isTimedOutException" isTimedOutExceptionTest, TestLabel "AllExceptions" allExceptionTest, TestLabel "Disconnect" disconnectTest ] -- | Ensure that connection to a server works, or at least that no -- exceptions are thrown. connectTest = TestCase ( do bs <- connectBeanstalk bs_host bs_port mbSock <- tryTakeMVar bs case mbSock of Nothing -> do assertFailure "Beanstalk socket was not in the MVar as expected." Just s -> do sIsConnected s @? "Beanstalk socket was not connected" (sIsBound s >>= return.not) @? "Beanstalk socket was bound" (sIsListening s >>= return.not) @? "Beanstalk socket was not listening" sIsReadable s @? "Beanstalk socket was not readable" sIsWritable s @? "Beanstalk socket was not writable" ) -- Test that using a tube doesn't cause exceptions. useTest = TestCase ( do bs <- connectBeanstalk bs_host bs_port randomName >>= useTube bs return () ) -- Test that watching a tube works. watchTest = TestCase ( do bs <- connectBeanstalk bs_host bs_port tubeName <- randomName watchCount <- watchTube bs tubeName assertEqual "Watch list should consist of 'default' and newly watched tube" 2 watchCount ) -- Test that ignoring a tube works ignoreTest = TestCase ( do bs <- connectBeanstalk bs_host bs_port tubeName <- randomName watchCount <- watchTube bs tubeName assertEqual "Watch list should consist of 'default' and newly watched tube" 2 watchCount newWatchCount <- ignoreTube bs "default" assertEqual "Watch list should consist of newly watched tube only" 1 newWatchCount ) -- Simply test that connecting and putting a job in the default tube works without exceptions. putTest = TestCase ( do bs <- connectBeanstalk bs_host bs_port (state, jobid) <- putJob bs 1 0 60 "body" return () ) -- More exhaustive test of Put in a new tube putTest2 = TestCase ( do (bs, tt) <- connectAndSelectRandomTube assertJobsCount bs tt [READY] 0 "Initially, no jobs" (state, jobid) <- putJob bs 1 0 60 "body" -- Technically could be BURIED, but only if memory exhausted. assertEqual "New job is in state READY" READY state assertJobsCount bs tt [READY] 1 "Put creates a ready job in the tube" return () ) -- Test putting and then reserving a job putReserveTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube randString <- randomName let body = "My test job body, " ++ randString (_,put_job_id) <- putJob bs 1 0 60 body rsv_job <- reserveJob bs assertEqual "Reserved job ID should match what was put" put_job_id (job_id rsv_job) assertEqual "Reserved job body should match what was put" body (job_body rsv_job) assertEqual "Reserved job should match job that was just put" put_job_id (job_id rsv_job) ) -- Test putting and then reserving a job with timeout putReserveWithTimeoutTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube randString <- randomName let body = "My test job body, " ++ randString (_,put_job_id) <- putJob bs 1 0 60 body rsv_job <- reserveJobWithTimeout bs 2 assertEqual "Reserved job should match job that was just put" put_job_id (job_id rsv_job) ) -- Test peeking for a couple specific jobs peekTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube randString <- randomName let body = "My test job body, " ++ randString (_,put_job_id) <- putJob bs 1 0 60 body let next_body = "My test job body, " ++ randString (_,put_next_job_id) <- putJob bs 1 0 60 next_body peeked_job <- peekJob bs put_job_id assertEqual "Peeked job id should match job id that was just put" put_job_id (job_id peeked_job) assertEqual "Peeked job should match job that was just put" body (job_body peeked_job) next_peeked_job <- peekJob bs put_next_job_id assertEqual "Peeked job id should match job id that was just put" put_next_job_id (job_id next_peeked_job) assertEqual "Peeked job should match job that was just put" next_body (job_body next_peeked_job) ) -- Test kicking a delayed job. kickDelayTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube randString <- randomName let body = "My test job body, " ++ randString (_,put_job_id) <- putJob bs 1 5 60 body kicked <- kickJobs bs 1 assertEqual "Kick should indicate one job kicked" 1 kicked ) -- Test putting a job, reserving it, and then releasing it back to the tube. releaseTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube assertJobsCount bs tt [READY] 0 "New tube has no jobs" -- Put a job on the tube randString <- randomName let body = "My test job body, " ++ randString (_,put_job_id) <- putJob bs 1 0 60 body assertJobsCount bs tt [READY] 1 "Put adds job to tube" -- Reserve the job rj <- reserveJob bs assertJobsCount bs tt [READY] 0 "Reserve removes ready job" assertJobsCount bs tt [RESERVED] 1 "Single reserved job" -- Release it releaseJob bs (job_id rj) 1 0 assertJobsCount bs tt [READY] 1 "Release puts job back to ready" ) -- Test deleting a reserved job. deleteTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube assertJobsCount bs tt [READY] 0 "New tube has no jobs" (_,put_job_id) <- putJob bs 1 0 60 "new job" assertJobsCount bs tt [READY] 1 "Put creates new ready job" job <- reserveJob bs assertJobsCount bs tt [RESERVED] 1 "Only job on tube is reserved" deleteJob bs (job_id job) assertJobsCount bs tt [READY,RESERVED,DELAYED,BURIED] 0 "Tube is empty" ) -- Test burying a reserved job. buryTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube assertJobsCount bs tt [READY] 0 "New tube has no jobs" (_,put_job_id) <- putJob bs 1 0 60 "new job" assertJobsCount bs tt [READY] 1 "Put creates new ready job" job <- reserveJob bs assertJobsCount bs tt [RESERVED] 1 "Only job on tube is reserved" buryJob bs (job_id job) 1 assertJobsCount bs tt [BURIED] 1 "Job is buried" ) -- Test peeking to find the next ready job. peekReadyTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube assertJobsCount bs tt [READY] 0 "New tube has no jobs" (_,put_job_id) <- putJob bs 1 0 60 "new job" assertJobsCount bs tt [READY] 1 "Put creates new ready job" job <- peekReadyJob bs assertJobsCount bs tt [READY] 1 "Job is still ready" assertEqual "Peeked job id is same as put job" put_job_id (job_id job) ) -- Test peeking to find definition of a specific queued job. peekJobTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube assertJobsCount bs tt [READY] 0 "New tube has no jobs" randString <- randomName let jobcontent = "new job "++randString (_,put_job_id) <- putJob bs 1 0 60 jobcontent assertJobsCount bs tt [READY] 1 "Put creates new ready job" job <- peekJob bs put_job_id assertJobsCount bs tt [READY] 1 "Job is still ready" assertEqual "Peeked job id is same as put job" put_job_id (job_id job) assertEqual "Peeked job content is same as put job" jobcontent (job_body job) ) -- Test peeking to find the next delayed job. peekDelayedTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube assertJobsCount bs tt [READY] 0 "New tube has no jobs" (_,put_job_id) <- putJob bs 1 120 60 "new job" assertJobsCount bs tt [DELAYED] 1 "Put with delay" job <- peekDelayedJob bs assertJobsCount bs tt [DELAYED] 1 "Job is still delayed" assertEqual "Peeked job id is same as put job" put_job_id (job_id job) ) -- Test peeking to find the next buried job. peekBuriedTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube assertJobsCount bs tt [READY] 0 "New tube has no jobs" (_,put_job_id) <- putJob bs 1 0 60 "new job" assertJobsCount bs tt [READY] 1 "Put creates new ready job" rsv_job <- reserveJob bs assertJobsCount bs tt [RESERVED] 1 "Reserved job" buryJob bs put_job_id 1 assertJobsCount bs tt [BURIED] 1 "Burid job" job <- peekBuriedJob bs assertJobsCount bs tt [BURIED] 1 "Job is still buried" assertEqual "Peeked job id is same as put job" put_job_id (job_id job) ) -- Test finding information on a specific job. statsJobTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube let priority = 99 (job_state ,put_job_id) <- putJob bs priority 0 60 "new job" job_stats <- statsJob bs put_job_id assertEqual "Job ID matches" put_job_id (read (fromJust (M.lookup "id" job_stats))) assertEqual "Job priority matches" priority (read (fromJust (M.lookup "pri" job_stats))) ) -- Test finding server statistics. statsTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube stats <- statsServer bs assertBool "More than 1 job has been created" (1 < (read (fromJust (M.lookup "total-jobs" stats)))) ) -- Test listing all tubes for the server. listTubesTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube tubes <- listTubes bs assertBool "Newly created tube is in list" (elem tt tubes) ) -- Test listing all watched tubes. listTubesWatchedTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube -- Watch another tube so that we avaid NotIgnoredExceptions otherTube <- randomName watchTube bs otherTube tubes <- listTubesWatched bs assertBool "Newly created/watched tube is in watch list" (elem tt tubes) ignoreTube bs tt assertBool "Ignored tube is not in watch list" (elem tt tubes) ) -- Test listing the currently used tube. listTubeUsedTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube tu <- listTubeUsed bs assertEqual "Used tube" tt tu ) -- Test touching a job to extend its TTR. touchJobTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube (_,jobid) <- putJob bs 1 0 600 "test" rsv_job <- reserveJob bs threadDelay (2*1000*1000) -- sleep 2 seconds jobstat_before <- statsJob bs jobid touchJob bs jobid jobstat_after <- statsJob bs jobid let ttr_before = ((read (fromJust (M.lookup "time-left" jobstat_before)))::Int) let ttr_after = ((read (fromJust (M.lookup "time-left" jobstat_after)))::Int) assertBool "TTR extended by touch" (ttr_after >= ttr_before) ) -- Test pausing a tube. pauseTubeTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube tubestat_before <- statsTube bs tt pauseTube bs tt 1000 tubestat_after <- statsTube bs tt let paused_rem = ((read (fromJust (M.lookup "pause-time-left" tubestat_after)))::Int) -- Check that at least 990 seconds still remains of the -- original 1000 seconds we paused the tube for. assertBool "Tube has at least 990 seconds before un-pausing" (paused_rem > 990) ) -- Test that NotFoundException is thrown isNotFoundExceptionTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube e <- E.tryJust (guard . isNotFoundException) (deleteJob bs 999999) case e of Right _ -> assertFailure "Deleting non-existent job should fail" Left _ -> return () ) -- Test that BadFormatException is thrown isBadFormatxceptionTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube rname <- randomName e <- E.tryJust (guard . isBadFormatException) (statsTube bs ("-"++rname)) case e of Right _ -> assertFailure "Using tube name starting with hyphen should fail" Left _ -> return () ) -- Test that TimedOutException is thrown isTimedOutExceptionTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube e <- E.tryJust (guard . isTimedOutException) (reserveJobWithTimeout bs 1) case e of Right _ -> assertFailure "Reserve with no jobs causes timeout" Left _ -> return () ) -- Test all exception predicates to make sure they return false when -- there are no errors. allExceptionTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube e <- E.tryJust (guard . isNotFoundException) (putJob bs 1 0 600 "test") case e of Right _ -> return () Left _ -> assertFailure "Erroneous not found exception" e <- E.tryJust (guard . isBadFormatException) (putJob bs 1 0 600 "test") case e of Right _ -> return () Left _ -> assertFailure "Erroneous bad format exception" e <- E.tryJust (guard . isTimedOutException) (putJob bs 1 0 600 "test") case e of Right _ -> return () Left _ -> assertFailure "Erroneous timed out exception" e <- E.tryJust (guard . isOutOfMemoryException) (putJob bs 1 0 600 "test") case e of Right _ -> return () Left _ -> assertFailure "(possible) Erroneous out of memory exception" e <- E.tryJust (guard . isInternalErrorException) (putJob bs 1 0 600 "test") case e of Right _ -> return () Left _ -> assertFailure "(possible) Erroneous internal error exception" e <- E.tryJust (guard . isJobTooBigException) (putJob bs 1 0 600 "test") case e of Right _ -> return () Left _ -> assertFailure "Erroneous job too big exception" e <- E.tryJust (guard . isDeadlineSoonException) (putJob bs 1 0 600 "test") case e of Right _ -> return () Left _ -> assertFailure "Erroneous deadline soon exception" e <- E.tryJust (guard . isNotIgnoredException) (putJob bs 1 0 600 "test") case e of Right _ -> return () Left _ -> assertFailure "Erroneous not ignored exception" ) disconnectTest = TestCase ( do (bs, tt) <- connectAndSelectRandomTube disconnectBeanstalk bs mbSock <- tryTakeMVar bs case mbSock of Nothing -> do assertFailure "Beanstalk socket was not in the MVar as expected." Just s -> do (sIsConnected s >>= return .not) @? "Beanstalk socket was connected" ) -- Assert a number of jobs on a given tube with one of the states -- listed. assertJobsCount :: BeanstalkServer -> String -> [JobState] -> Int -> String -> IO () assertJobsCount bs tube states jobs msg = do ts <- statsTube bs tube jobsReady <- jobCountWithState bs tube states assertEqual msg jobs jobsReady -- Configure a new beanstalkd connection to use&watch a single tube -- with a random name. connectAndSelectRandomTube :: IO (BeanstalkServer, String) connectAndSelectRandomTube = do bs <- connectBeanstalk bs_host bs_port tt <- randomName useTube bs tt watchTube bs tt ignoreTube bs "default" return (bs, tt) -- Generate random tube names for test separation. randomName :: IO String randomName = do rdata <- randomIO :: IO Integer return (show (abs rdata))