diff --git a/Yesod/JobQueue.hs b/Yesod/JobQueue.hs --- a/Yesod/JobQueue.hs +++ b/Yesod/JobQueue.hs @@ -1,18 +1,25 @@ {-# LANGUAGE ImpredicativeTypes, UndecidableInstances #-} +-- | +-- +-- Background jobs library for Yesod. +-- Use example is in README.md. +-- module Yesod.JobQueue ( YesodJobQueue (..) , JobQueue - , getJobQueue - , JobState , JobInfo (..) - , newJobState) where + , startDequeue + , enqueue + , JobState + , newJobState + , getJobQueue + ) where import qualified Prelude as P import Yesod.JobQueue.Routes -import Yesod.JobQueue.APIData +import Yesod.JobQueue.Types --- import Data.Maybe import qualified Data.List as L import ClassyPrelude.Yesod import Control.Concurrent @@ -30,9 +37,8 @@ import Data.FileEmbed (embedFile) --- persist config for job env --- type JobDBConf c = (PersistConfig c) => (c, PersistConfigPool c) +-- | description for JobType class JobInfo j where describe :: j -> String describe _ = "" @@ -67,72 +73,28 @@ } deriving (Show, Read) $(deriveToJSON defaultOptions ''JobQueueItem) +-- | Backend jobs for Yesod class (Yesod master, Read (JobType master), Show (JobType master) , Enum (JobType master), Bounded (JobType master) , JobInfo (JobType master)) => YesodJobQueue master where - -- persistent config for job - -- jobDBConfig :: master -> JobDBConf config - - -- Custom Job Type + -- | Custom Job Type type JobType master - -- Execute Job Handler + -- | Job Handler runJob :: (MonadBaseControl IO m, MonadIO m) => master -> JobType master -> ReaderT master m () - -- queue key name for redis + -- | queue key name for redis queueKey :: master -> ByteString queueKey _ = "yesod-job-queue" - - -- serialize JobType - readJobType :: master -> String -> Maybe (JobType master) - readJobType _ = readMay - - -- desserialize JobType - showJobType :: JobType master -> String - showJobType = show - - -- get all job type list - allJobTypes :: master -> [JobType master] - allJobTypes _ = [minBound..] - - -- runDB with config for job + + -- | runDB for job runDBJob :: (MonadBaseControl IO m, MonadIO m) => ReaderT (YesodPersistBackend master) (ReaderT master m) a -> ReaderT master m a - -- start thread of dequeue-ing job - startDequeue :: (MonadBaseControl IO m, MonadIO m) => master -> m () - startDequeue m = do - liftIO $ forkIO $ do - conn <- R.connect R.defaultConnectInfo - R.runRedis conn $ do - forever $ do - emr <- R.blpop [queueKey m] 600 - liftIO $ case emr of - Left e -> putStrLn "[dequeue] error in at connection redis" - Right Nothing -> putStrLn "[dequeue] timeout retry" - Right (Just (k, v)) -> do - let item = readMay $ BSC.unpack v :: Maybe JobQueueItem - case readJobType m =<< queueJobType <$> item of - Just jt -> do - jid <- U.nextRandom - time <- getCurrentTime - let job = RunningJob (show jt) 1 jid time - STM.atomically - $ STM.modifyTVar (getJobState m) - (job:) - putStrLn . pack $ "dequeued: " ++ (show jt) - runReaderT (runJob m jt) m - STM.atomically - $ STM.modifyTVar (getJobState m) - (L.delete job) - Nothing -> putStrLn "[dequeue] unknown JobType" - return () - return () - -- | get job state getJobState :: master -> JobState @@ -144,29 +106,69 @@ jobManagerJSUrl :: master -> String jobManagerJSUrl m = (jobAPIBaseUrl m) ++ "/manager/app.js" - enqueue :: master -> JobType master -> IO () - enqueue m jt = do - time <- getCurrentTime - let item = JobQueueItem (show jt) time - conn <- liftIO $ R.connect R.defaultConnectInfo - R.runRedis conn $ do - R.rpush (queueKey m) [BSC.pack $ show item] - return () - - listQueue :: master -> IO (Either String [JobQueueItem]) - listQueue m = do - conn <- R.connect R.defaultConnectInfo - exs <- R.runRedis conn $ do - R.lrange (queueKey m) 0 (-1) - case exs of - Right xs -> - return $ Right $ catMaybes - $ map (readMay . BSC.unpack) xs - Left r -> return $ Left $ show r - -- | get information of all type classes related job-queue getClassInformation :: master -> [JobQueueClassInfo] getClassInformation _ = [] + +-- | start dequeue-ing job in new thread +startDequeue :: (YesodJobQueue master, MonadBaseControl IO m, MonadIO m) => master -> m () +startDequeue m = do + liftIO $ forkIO $ do + conn <- R.connect R.defaultConnectInfo + R.runRedis conn $ do + forever $ do + emr <- R.blpop [queueKey m] 600 + liftIO $ case emr of + Left e -> putStrLn "[dequeue] error in at connection redis" + Right Nothing -> putStrLn "[dequeue] timeout retry" + Right (Just (k, v)) -> do + let item = readMay $ BSC.unpack v :: Maybe JobQueueItem + case readJobType m =<< queueJobType <$> item of + Just jt -> do + jid <- U.nextRandom + time <- getCurrentTime + let job = RunningJob (show jt) 1 jid time + STM.atomically + $ STM.modifyTVar (getJobState m) + (job:) + putStrLn . pack $ "dequeued: " ++ (show jt) + runReaderT (runJob m jt) m + STM.atomically + $ STM.modifyTVar (getJobState m) + (L.delete job) + Nothing -> putStrLn "[dequeue] unknown JobType" + return () + return () + +-- | Add job to end of the queue +enqueue :: YesodJobQueue master => master -> JobType master -> IO () +enqueue m jt = do + time <- getCurrentTime + let item = JobQueueItem (show jt) time + conn <- liftIO $ R.connect R.defaultConnectInfo + R.runRedis conn $ do + R.rpush (queueKey m) [BSC.pack $ show item] + return () + +-- | Get all job in the queue +listQueue :: YesodJobQueue master => master -> IO (Either String [JobQueueItem]) +listQueue m = do + conn <- R.connect R.defaultConnectInfo + exs <- R.runRedis conn $ do + R.lrange (queueKey m) 0 (-1) + case exs of + Right xs -> + return $ Right $ catMaybes + $ map (readMay . BSC.unpack) xs + Left r -> return $ Left $ show r + +-- | read JobType from String +readJobType :: YesodJobQueue master => master -> String -> Maybe (JobType master) +readJobType _ = readMay + +-- | get all job type list +allJobTypes :: (YesodJobQueue master) => master -> [JobType master] +allJobTypes _ = [minBound..] -- | Handler for job manager api routes type JobHandler master a = diff --git a/Yesod/JobQueue/APIData.hs b/Yesod/JobQueue/APIData.hs deleted file mode 100644 --- a/Yesod/JobQueue/APIData.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Yesod.JobQueue.APIData where - -import ClassyPrelude.Yesod -import Data.Aeson.APIFieldJsonTH -import Control.Lens - -data PostJobQueueRequest = PostJobQueueRequest { - _postJobQueueRequestJob :: String -} - -makeFields ''PostJobQueueRequest -deriveApiFieldJSON ''PostJobQueueRequest - - - -data JobQueueClassInfo = JobQueueClassInfo { - _jobQueueClassInfoClassName :: Text - , _jobQueueClassInfoValues :: [Text] - } - -makeFields ''JobQueueClassInfo -deriveApiFieldJSON ''JobQueueClassInfo diff --git a/Yesod/JobQueue/Scheduler.hs b/Yesod/JobQueue/Scheduler.hs --- a/Yesod/JobQueue/Scheduler.hs +++ b/Yesod/JobQueue/Scheduler.hs @@ -1,7 +1,8 @@ +-- | Cron Job for Yesod module Yesod.JobQueue.Scheduler where import Yesod.JobQueue -import Yesod.JobQueue.APIData +import Yesod.JobQueue.Types import System.Cron.Schedule import qualified Prelude as P @@ -9,6 +10,7 @@ import qualified Data.Text as T (pack) +-- | Cron Scheduler for YesodJobQueue class (YesodJobQueue master) => YesodJobQueueScheduler master where -- | job schedules getJobSchedules :: master -> [(String, JobType master)] @@ -20,6 +22,7 @@ tids <- liftIO $ execSchedule $ mapM_ add $ getJobSchedules master print tids +-- | Need by 'getClassInformation' schedulerInfo :: YesodJobQueueScheduler master => master -> JobQueueClassInfo schedulerInfo m = JobQueueClassInfo "Scheduler" $ map (T.pack . showSchedule) $ getJobSchedules m - where showSchedule (s, jt) = s ++ " " ++ (show jt) + where showSchedule (s, jt) = s ++ " | " ++ (show jt) diff --git a/Yesod/JobQueue/Types.hs b/Yesod/JobQueue/Types.hs new file mode 100644 --- /dev/null +++ b/Yesod/JobQueue/Types.hs @@ -0,0 +1,22 @@ +module Yesod.JobQueue.Types where + +import ClassyPrelude.Yesod +import Data.Aeson.APIFieldJsonTH +import Control.Lens + +data PostJobQueueRequest = PostJobQueueRequest { + _postJobQueueRequestJob :: String +} + +makeFields ''PostJobQueueRequest +deriveApiFieldJSON ''PostJobQueueRequest + + + +data JobQueueClassInfo = JobQueueClassInfo { + _jobQueueClassInfoClassName :: Text + , _jobQueueClassInfoValues :: [Text] + } + +makeFields ''JobQueueClassInfo +deriveApiFieldJSON ''JobQueueClassInfo diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,22 +1,14 @@ -import qualified Prelude as P +import qualified Prelude as P () import ClassyPrelude.Yesod -import Yesod +-- import Yesod import Yesod.JobQueue import Yesod.JobQueue.Scheduler import Control.Concurrent import Database.Persist.Sqlite -import Control.Monad.Trans.Resource (runResourceT) +--import Control.Monad.Trans.Resource (runResourceT) import Control.Monad.Logger (runStderrLoggingT) --- Handlers --- getHomeR :: Handler Html -getHomeR = defaultLayout $ do - setTitle "JobQueue sample" - [whamlet| -

Hello - |] - -- Yesod Persist settings (Nothing special here) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Person @@ -56,12 +48,12 @@ runDBJob action = do app <- ask runSqlPool action $ appConnPool app - runJob app AggregationUser = do + runJob _ AggregationUser = do us <- runDBJob $ selectList ([] :: [Filter Person]) [] liftIO $ threadDelay $ 10 * 1000 * 1000 print us putStrLn "complate job!" - runJob app PushNotification = do + runJob _ PushNotification = do putStrLn "send norification!" getClassInformation app = [schedulerInfo app] -- jobManagerJSUrl _ = "http://localhost:3001/dist/app.bundle.js" -- use for development with "npm run bs" @@ -69,6 +61,14 @@ instance YesodJobQueueScheduler App where getJobSchedules _ = [("* * * * *", AggregationUser) , ("* * * * *", PushNotification)] + +-- Handlers +getHomeR :: HandlerT App IO Html +getHomeR = defaultLayout $ do + setTitle "JobQueue sample" + [whamlet| +

Hello + |] -- Main main :: IO () diff --git a/yesod-job-queue.cabal b/yesod-job-queue.cabal --- a/yesod-job-queue.cabal +++ b/yesod-job-queue.cabal @@ -1,7 +1,15 @@ name: yesod-job-queue -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Background jobs library for Yesod. -description: Please see README.md +description: + Background jobs library for Yesod + . + * It contains management API and web interface. + * Queue backend is Redis. + * Support cron scheduler + . + Usage and screen shot are available in README.md + homepage: https://github.com/nakaji-dayo/yesod-job-queue#readme license: BSD3 license-file: LICENSE @@ -18,10 +26,9 @@ default: False library - -- hs-source-dirs: src exposed-modules: Yesod.JobQueue , Yesod.JobQueue.Scheduler - , Yesod.JobQueue.APIData + , Yesod.JobQueue.Types , Yesod.JobQueue.Routes default-extensions: TemplateHaskell , MultiParamTypeClasses @@ -79,7 +86,7 @@ , classy-prelude-yesod ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N - + default-language: Haskell2010 test-suite yesod-job-queue-test type: exitcode-stdio-1.0