diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yesod/JobQueue.hs b/Yesod/JobQueue.hs new file mode 100644 --- /dev/null +++ b/Yesod/JobQueue.hs @@ -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 + + + 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 + + diff --git a/Yesod/JobQueue/APIData.hs b/Yesod/JobQueue/APIData.hs new file mode 100644 --- /dev/null +++ b/Yesod/JobQueue/APIData.hs @@ -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 + diff --git a/Yesod/JobQueue/Routes.hs b/Yesod/JobQueue/Routes.hs new file mode 100644 --- /dev/null +++ b/Yesod/JobQueue/Routes.hs @@ -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 +|] diff --git a/app/dist/app.bundle.js b/app/dist/app.bundle.js new file mode 100644 # file too large to diff: app/dist/app.bundle.js diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/yesod-job-queue.cabal b/yesod-job-queue.cabal new file mode 100644 --- /dev/null +++ b/yesod-job-queue.cabal @@ -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