yesod-job-queue (empty) → 0.1.0.0
raw patch · 9 files changed
+485/−0 lines, 9 filesdep +aesondep +api-field-json-thdep +basesetup-changed
Dependencies added: aeson, api-field-json-th, base, bytestring, classy-prelude-yesod, cron, file-embed, hedis, lens, monad-logger, persistent-sqlite, resourcet, stm, text, time, uuid, yesod, yesod-core, yesod-job-queue
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Yesod/JobQueue.hs +253/−0
- Yesod/JobQueue/APIData.hs +13/−0
- Yesod/JobQueue/Routes.hs +17/−0
- app/dist/app.bundle.js too large to diff
- example/Main.hs +74/−0
- test/Spec.hs +2/−0
- yesod-job-queue.cabal +94/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Yesod/JobQueue.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE ImpredicativeTypes, UndecidableInstances #-}+module Yesod.JobQueue (+ YesodJobQueue (..)+ , JobQueue+ , getJobQueue+ , JobState+ , JobInfo (..)+ , newJobState) where++import qualified Prelude as P++import Yesod.JobQueue.Routes+import Yesod.JobQueue.APIData++-- import Data.Maybe+import qualified Data.List as L+import ClassyPrelude.Yesod+import Control.Concurrent+import Control.Lens ((^.))+import qualified Data.ByteString.Char8 as BSC (pack, unpack)+import Control.Monad.Logger+import System.Cron.Schedule+import qualified Database.Redis as R++import qualified Data.UUID as U+import qualified Data.UUID.V4 as U+import qualified Control.Concurrent.STM as STM+import Data.Time.Clock++import Data.Aeson.TH++import Data.FileEmbed (embedFile)++-- persist config for job env+type JobDBConf c = (PersistConfig c) => (c, PersistConfigPool c)++class JobInfo j where+ describe :: j -> String+ describe _ = ""++-- | Thread ID for convenience+type ThreadNum = Int++-- | JobType String+type JobTypeString = String++-- | Information of the running job+data RunningJob = RunningJob {+ jobType :: JobTypeString+ , threadId :: ThreadNum+ , jobId :: U.UUID+ , startTime :: UTCTime+ } deriving (Eq)+instance ToJSON U.UUID where+ toJSON = String . pack . U.toString+$(deriveToJSON defaultOptions ''RunningJob)++-- | Manage the running jobs+type JobState = TVar [RunningJob]++-- | create new JobState+newJobState :: IO (TVar [RunningJob])+newJobState = STM.newTVarIO []++data JobQueueItem = JobQueueItem {+ queueJobType :: JobTypeString+ , queueTime :: UTCTime+} deriving (Show, Read)+$(deriveToJSON defaultOptions ''JobQueueItem)++class (Yesod master, Read (JobType master), Show (JobType master)+ , Enum (JobType master), Bounded (JobType master)+ , JobInfo (JobType master)+ , PersistConfig config)+ => YesodJobQueue master config | master -> config where+ + -- persistent config for job+ jobDBConfig :: master -> JobDBConf config+ + -- Custom Job Type+ type JobType master+ + -- Execute Job Handler+ runJob :: (MonadBaseControl IO m, MonadIO m)+ => master -> JobType master -> ReaderT master m ()+ + -- 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+ runDBJob :: (MonadBaseControl IO m, MonadIO m) =>+ PersistConfigBackend config m a -> ReaderT master m a+ runDBJob action = do+ m <- ask+ let (config, pool) = jobDBConfig m+ lift $ runPool config action pool++ -- 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 ()++ getJobState :: master -> JobState++ -- | get API and Manager base url+ jobAPIBaseUrl :: master -> String+ jobAPIBaseUrl _ = "/job"++ -- | get manager application javascript url (change only development)+ 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++++-- | Handler for job manager api routes+type JobHandler master a =+ YesodJobQueue master c => HandlerT JobQueue (HandlerT master IO) a++-- | get job definitions+getJobR :: JobHandler master Value+getJobR = lift $ do+ y <- getYesod+ let f x = object ["type" .= show x, "description" .= describe x]+ let ts = map f $ allJobTypes y+ returnJson $ object ["jobTypes" .= ts]+ ++-- | get a list of jobs in queue+getJobQueueR :: JobHandler master Value+getJobQueueR = lift $ do+ y <- getYesod+ Right q <- liftIO $ listQueue y+ returnJson $ object ["queue" .= q]+ +-- | enqueue new job+postJobQueueR :: JobHandler master Value+postJobQueueR = lift $ do+ y <- getYesod+ body <- requireJsonBody :: HandlerT master IO PostJobQueueRequest+ case readJobType y (body ^. job) of+ Just jt -> do+ liftIO $ enqueue y jt+ returnJson $ object []+ Nothing -> invalidArgs ["job"]++-- | get a list of running jobs+getJobStateR :: JobHandler master Value+getJobStateR = lift $ do+ y <- getYesod+ s <- liftIO $ STM.readTVarIO (getJobState y)+ returnJson $ object ["running" .= s] ++getJobManagerR :: JobHandler master Html+getJobManagerR = lift $ do+ y <- getYesod+ withUrlRenderer [hamlet|+$doctype 5+<html>+ <head>+ <title>YesodJobQueue Manager+ <link rel="stylesheet" href="https://fonts.googleapis.com/icon?family=Material+Icons">+ <link rel="stylesheet" href="https://code.getmdl.io/1.1.3/material.blue_grey-red.min.css">+ <script defer src="https://code.getmdl.io/1.1.3/material.min.js">+ <meta name="viewport" content="width=device-width, initial-scale=1.0">+ <body>+ <div class="mdl-layout mdl-js-layout mdl-layout--fixed-header">+ <header class="mdl-layout__header">+ <div class="mdl-layout__header-row">+ <!-- Title -->+ <span class="mdl-layout-title">YesodJobQueue Manager+ <main class="mdl-layout__content">+ <div id="app" class="page-content">+ <div id="demo-toast-example" class="mdl-js-snackbar mdl-snackbar">+ <div class="mdl-snackbar__text">+ <button class="mdl-snackbar__action" type="button">+ <script>+ window.BASE_URL = "#{jobAPIBaseUrl y}"+ <script src="#{jobManagerJSUrl y}">+|]++-- | Job manager UI (get static page. ajax application)+getJobManagerStaticR :: Text -> JobHandler master Value+getJobManagerStaticR f+ | f == "app.js" = lift $ do+ let content = toContent $(embedFile "app/dist/app.bundle.js")+ sendResponse ("application/json" :: ByteString, content)+ | otherwise = notFound++-- | JobQueue manager subsite+instance YesodJobQueue master c => YesodSubDispatch JobQueue (HandlerT master IO) where+ yesodSubDispatch = $(mkYesodSubDispatch resourcesJobQueue)++getJobQueue :: a -> JobQueue+getJobQueue = const JobQueue++
+ Yesod/JobQueue/APIData.hs view
@@ -0,0 +1,13 @@+module Yesod.JobQueue.APIData where++import ClassyPrelude.Yesod+import Data.Aeson.APIFieldJsonTH+import Control.Lens++data PostJobQueueRequest = PostJobQueueRequest {+ _postJobQueueRequestJob :: String+}++makeFields ''PostJobQueueRequest+deriveApiFieldJSON ''PostJobQueueRequest+
+ Yesod/JobQueue/Routes.hs view
@@ -0,0 +1,17 @@+module Yesod.JobQueue.Routes where++import Yesod+import Data.Text++-- Subsites have foundations just like master sites.+data JobQueue = JobQueue++-- We have a familiar analogue from mkYesod, with just one extra parameter.+-- We'll discuss that later.+mkYesodSubData "JobQueue" [parseRoutes|+/ JobR GET+/queue JobQueueR GET POST+/state JobStateR GET+/manager JobManagerR GET+/manager/#Text JobManagerStaticR GET+|]
+ app/dist/app.bundle.js view
file too large to diff
+ example/Main.hs view
@@ -0,0 +1,74 @@+import qualified Prelude as P+import ClassyPrelude.Yesod+import Yesod+import Yesod.JobQueue+import Control.Concurrent+import Database.Persist.Sqlite+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+ name String+ age Int+ deriving Show+|]+instance YesodPersist App where+ type YesodPersistBackend App = SqlBackend+ runDB action = do+ app <- getYesod+ runSqlPool action $ appConnPool app+++-- Make Yesod App that have ConnectionPool, JobState+data App = App {+ appConnPool :: ConnectionPool+ , appDBConf :: SqliteConf+ , appJobState :: JobState+ }+instance Yesod App+mkYesod "App" [parseRoutes|+/ HomeR GET+/job JobQueueR JobQueue getJobQueue -- ^ JobQueue API and Manager+|]++-- JobQueue settings+data MyJobType = AggregationUser | PushNotification deriving (Show, Read, Enum, Bounded)+instance JobInfo MyJobType where+ describe AggregationUser = "aggregate user's activities"+ describe _ = "No information"++instance YesodJobQueue App SqliteConf where+ type JobType App = MyJobType+ getJobState = appJobState+ jobDBConfig app = (appDBConf app, appConnPool app)+ runJob app AggregationUser = do+ us <- runDBJob $ selectList ([] :: [Filter Person]) []+ liftIO $ threadDelay $ 10 * 1000 * 1000+ putStrLn "complate job!"+ runJob app PushNotification = do+ putStrLn "send norification!"+ -- jobManagerJSUrl _ = "http://localhost:3001/dist/app.bundle.js" -- use for development with "npm run bs"++-- Main+main :: IO ()+main = runStderrLoggingT $+ withSqlitePool (sqlDatabase dbConf) (sqlPoolSize dbConf) $ \pool -> liftIO $ do+ runResourceT $ flip runSqlPool pool $ do+ runMigration migrateAll+ insert $ Person "test" 28+ jobState <- newJobState -- ^ create JobState+ let app = App pool dbConf jobState+ startDequeue app+ warp 3000 app+ where dbConf = SqliteConf "test.db3" 4
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"
+ yesod-job-queue.cabal view
@@ -0,0 +1,94 @@+name: yesod-job-queue+version: 0.1.0.0+synopsis: Background jobs library for Yesod. contains management API and web interface. Queue backend is Redis.+description: Please see README.md+homepage: https://github.com/nakaji-dayo/yesod-job-queue#readme+license: BSD3+license-file: LICENSE+author: Daishi Nakajima+maintainer: nakaji.dayo@gmail.com+copyright: 2016 Daishi Nakajima+category: Web+build-type: Simple+extra-source-files: app/dist/app.bundle.js+cabal-version: >=1.10++flag example+ description: Build the example application+ default: False+ +library+ -- hs-source-dirs: src+ exposed-modules: Yesod.JobQueue+ , Yesod.JobQueue.APIData+ , Yesod.JobQueue.Routes+ default-extensions: TemplateHaskell+ , MultiParamTypeClasses+ , FunctionalDependencies+ , TypeSynonymInstances+ , FlexibleInstances+ , QuasiQuotes+ , TypeFamilies+ , OverloadedStrings+ , FlexibleContexts+ , ViewPatterns+ build-depends: base >= 4.7 && < 5+ , stm+ , hedis+ , uuid+ , aeson+ , cron+ , monad-logger+ , bytestring+ , lens+ , classy-prelude-yesod+ , api-field-json-th+ , yesod+ , file-embed+ , text+ , time+ + default-language: Haskell2010++executable yesod-job-queue-example+ if flag(example)+ buildable: True+ else+ buildable: False+ hs-source-dirs: example+ main-is: Main.hs+ default-extensions: TemplateHaskell+ , QuasiQuotes+ , OverloadedStrings+ , TypeFamilies+ , GADTs+ , MultiParamTypeClasses+ , EmptyDataDecls+ , GeneralizedNewtypeDeriving+-- other-modules: + ghc-options: -Wall -fwarn-tabs -O2++ build-depends: base+ , yesod+ , yesod-core+ , yesod-job-queue+ , persistent-sqlite+ , resourcet+ , monad-logger+ , classy-prelude-yesod++ ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N++ +test-suite yesod-job-queue-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , yesod-job-queue+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/nakaji-dayo/yesod-job-queue