yesod-job-queue 0.1.0.2 → 0.1.0.3

raw patch · 6 files changed

+131/−119 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Yesod/JobQueue.hs +79/−77
• Yesod/JobQueue/APIData.hs +0/−22
• Yesod/JobQueue/Scheduler.hs +5/−2
• Yesod/JobQueue/Types.hs +22/−0
• example/Main.hs +13/−13
• yesod-job-queue.cabal +12/−5

@@ -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 =

@@ -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

@@ -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)

@@ -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

@@ -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|-        <h1>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|+        <h1>Hello+    |]  -- Main main :: IO ()

@@ -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