Permalink
Browse files

Proof of concept: background workers

  • Loading branch information...
jamesdabbs committed Jul 3, 2014
1 parent a3d6435 commit a701e186011e1ae6b9ca4b0fc38e4f4bce5b5620
Showing with 139 additions and 80 deletions.
  1. +5 −1 Application.hs
  2. +3 −0 Foundation.hs
  3. +24 −30 Handler/Home.hs
  4. +82 −0 Jobs.hs
  5. +3 −5 Model.hs
  6. +6 −0 README.md
  7. +2 −0 Settings.hs
  8. +5 −1 config/models
  9. +1 −1 config/routes
  10. +1 −0 config/settings.yml
  11. +6 −0 sarah.cabal
  12. +1 −38 templates/homepage.hamlet
  13. +0 −1 templates/homepage.julius
  14. +0 −3 templates/homepage.lucius
View
@@ -25,6 +25,8 @@ import Network.Wai.Logger (clockDateCacher)
import Data.Default (def)
import Yesod.Core.Types (loggerSet, Logger (Logger))
import Jobs
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Home
@@ -81,8 +83,10 @@ makeFoundation conf = do
updateLoop
_ <- forkIO updateLoop
q <- spawnWorkers p dbconf (extraWorkers . appExtra $ conf)
let logger = Yesod.Core.Types.Logger loggerSet' getter
foundation = App conf s p manager dbconf logger
foundation = App conf s p manager dbconf logger q
-- Perform database migration using our application's logging settings.
runLoggingT
View
@@ -20,6 +20,8 @@ import Text.Jasmine (minifym)
import Text.Hamlet (hamletFile)
import Yesod.Core.Types (Logger)
import Jobs
-- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
@@ -31,6 +33,7 @@ data App = App
, httpManager :: Manager
, persistConfig :: Settings.PersistConf
, appLogger :: Logger
, jobQueue :: JobQueue
}
instance HasHttpManager App where
View
@@ -3,37 +3,31 @@ module Handler.Home where
import Import
-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Jobs
-- Simple helper for throwing jobs on to the application's queue
queue :: Job -> Handler ()
queue job = do
app <- getYesod
liftIO $ queueJob (jobQueue app) job
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe (FileInfo, Text)
handlerName = "getHomeR" :: Text
defaultLayout $ do
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
-- Test out the workers on several dummy jobs, some of which
-- are deleted by the time the workers run
feeds <- mapM createFeed [1..10]
mapM_ (runDB . delete) $ take 5 feeds
mapM_ (queue . RunFeedJob) feeds
defaultLayout $ do
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
defaultLayout $ do
setTitle "Worker test"
$(widgetFile "homepage")
sampleForm :: Form (FileInfo, Text)
sampleForm = renderDivs $ (,)
<$> fileAFormReq "Choose a file"
<*> areq textField "What's on the file?" Nothing
where
createFeed :: Int -> Handler FeedId
createFeed n = do
now <- liftIO getCurrentTime
runDB . insert $ Feed url now now now
where url = T.pack $ "this is feed url #" ++ show n
View
82 Jobs.hs
@@ -0,0 +1,82 @@
module Jobs
( Job (..)
, JobQueue
, spawnWorkers
, queueJob
) where
import Prelude
import Model
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Monad (forever, replicateM_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runStdoutLoggingT)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Monoid ((<>))
import Database.Persist
import Settings (PersistConf)
import Data.Time (getCurrentTime)
import System.Random (randomRIO)
-- The intention is for Job to be a sum type, with different `perform` implementations
-- for each constructor. For now, we just have the one:
data Job = RunFeedJob FeedId
-- A job queue is simply a list of jobs that multiple threads can access safely (using STM)
type JobQueue = TVar [Job]
-- Helper methods for threadsafe pushes and pops
aPop :: TVar [a] -> STM (Maybe a)
aPop qvar = do
q <- readTVar qvar
case q of
(x:xs) -> do
writeTVar qvar xs
return $ Just x
_ -> return Nothing
aPush :: TVar [a] -> a -> STM ()
aPush qvar x = do
xs <- readTVar qvar
writeTVar qvar $ xs ++ [x] -- TODO: use a structure with efficient appends
-- The public API for queueing a job. Internally, this simply pushes it onto the list.
queueJob :: JobQueue -> Job -> IO ()
queueJob q = atomically . aPush q
-- Starts an empty job queue and some number of workers to consume from that queue
spawnWorkers :: PersistConfigPool PersistConf -> PersistConf -> Int -> IO JobQueue
spawnWorkers pool dbconf n = do
q <- atomically $ newTVar []
replicateM_ n . forkIO $ work q
return q
where
work q = forever $ do
qi <- atomically $ aPop q
case qi of
Just i -> perform pool dbconf i
Nothing -> threadDelay 1000000
-- This allows us to run db queries inside a worker, similar to runDB inside a Handler
runDBIO pool dbconf f = runStdoutLoggingT . runResourceT $ runPool dbconf f pool
-- `perform` defines the actual work to be done for each type of job
-- TODO: figure out monadic sugar so that we can use e.g. runW and not need to pass in
-- pool and dbconf
-- also, figure out a getBy404 equivalent
-- also also, hook in logging (w/ numbered workers?)
perform pool dbconf (RunFeedJob _id) = do
now <- liftIO getCurrentTime
liftIO . putStrLn $ (show now) <> " -- Trying " <> (show _id)
mfeed <- runDBIO pool dbconf . get $ _id
liftIO $ case mfeed of
Just feed -> do
putStrLn $ (show now) <> " -- Running feed '" <> (show $ feedUrl feed) <> "'"
-- Pretend these are variably complicated units of work
sleep <- randomRIO (1,10)
threadDelay $ sleep * 1000000
Nothing -> return ()
View
@@ -2,13 +2,11 @@ module Model where
import Prelude
import Yesod
import Data.Text (Text)
import Database.Persist.Quasi
import Data.Time (UTCTime)
import Data.Typeable (Typeable)
import Database.Persist.Quasi
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlOnlySettings, mkMigrate "migrateAll"]
$(persistFileWith lowerCaseSettings "config/models")
View
@@ -0,0 +1,6 @@
# Sarah
## A Smart Home Server
This is a personal project designed to run on my home server and automate several tasks, like running backups, downloading feeds, and tagging music.
At the moment, this is mostly a sandbox for playing around with Haskell and Yesod to try things like background workers or accessing remote APIs.
View
@@ -68,9 +68,11 @@ widgetFile = (if development then widgetFileReload
data Extra = Extra
{ extraCopyright :: Text
, extraAnalytics :: Maybe Text -- ^ Google Analytics
, extraWorkers :: Int
} deriving Show
parseExtra :: DefaultEnv -> Object -> Parser Extra
parseExtra _ o = Extra
<$> o .: "copyright"
<*> o .:? "analytics"
<*> o .: "workers"
View
@@ -9,4 +9,8 @@ Email
verkey Text Maybe
UniqueEmail email
-- By default this file is used in Model.hs (which is imported by Foundation.hs)
Feed
url Text
createdAt UTCTime
lastRunAt UTCTime
nextRunAt UTCTime
View
@@ -4,4 +4,4 @@
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET POST
/ HomeR GET
View
@@ -3,6 +3,7 @@ Default: &defaults
port: 3000
approot: "http://localhost:3000"
copyright: Insert copyright statement here
workers: 3
#analytics: UA-YOURCODE
Development:
View
@@ -14,6 +14,7 @@ Flag library-only
library
exposed-modules: Application
Foundation
Jobs
Import
Model
Settings
@@ -67,6 +68,11 @@ library
, monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.1.4 && < 2.2
, wai-logger >= 2.1 && < 2.2
, stm >= 2.4.2 && < 2.5
, time >= 1.4.0.1 && < 1.5
, resourcet >= 1.1.2.2 && < 1.2
, transformers >= 0.3 && < 0.4
, random >= 1.0.1.1 && < 1.1
executable sarah
if flag(library-only)
View
@@ -1,38 +1 @@
<h1>_{MsgHello}
<ol>
<li>Now that you have a working project you should use the #
\<a href="http://www.yesodweb.com/book/">Yesod book</a> to learn more. #
You can also use this scaffolded site to explore some basic concepts.
<li> This page was generated by the #{handlerName} handler in #
\<em>Handler/Home.hs</em>.
<li> The #{handlerName} handler is set to generate your site's home screen in Routes file #
<em>config/routes
<li> The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
most of them are brought together by the <em>defaultLayout</em> function which #
is defined in the <em>Foundation.hs</em> module, and used by <em>#{handlerName}</em>. #
All the files for templates and wigdets are in <em>templates</em>.
<li>
A Widget's Html, Css and Javascript are separated in three files with the #
\<em>.hamlet</em>, <em>.lucius</em> and <em>.julius</em> extensions.
<li ##{aDomId}>If you had javascript enabled then you wouldn't be seeing this.
<li #form>
This is an example trivial Form. Read the #
\<a href="http://www.yesodweb.com/book/forms">Forms chapter</a> #
on the yesod book to learn more about them.
$maybe (info,con) <- submission
<div .message>
Your file's type was <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
<form method=post action=@{HomeR}#form enctype=#{formEnctype}>
^{formWidget}
<input type="submit" value="Send it!">
<li> And last but not least, Testing. In <em>tests/main.hs</em> you will find a #
test suite that performs tests on this page. #
You can run your tests by doing: <pre>yesod test</pre>
<h1> Yo
@@ -1 +0,0 @@
document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";
@@ -1,6 +1,3 @@
h1 {
text-align: center
}
h2##{aDomId} {
color: #990
}

0 comments on commit a701e18

Please sign in to comment.