snap-extras 0.9 → 0.11
raw patch · 18 files changed
+752/−103 lines, 18 filesdep +QuickCheckdep +case-insensitivedep +lensdep ~aesondep ~basedep ~blaze-buildernew-component:exe:PollExample
Dependencies added: QuickCheck, case-insensitive, lens, pcre-light, snap-extras, snap-server, tasty, tasty-hunit, tasty-quickcheck, time, wl-pprint-text
Dependency ranges changed: aeson, base, blaze-builder, blaze-html, bytestring, configurator, containers, digestive-functors, directory-tree, filepath, heist, mtl, readable, snap, snap-core, text, transformers
Files
- poll-example/PollExample.hs +154/−0
- poll-example/snaplets/heist/_status.tpl +21/−0
- poll-example/snaplets/heist/index.tpl +8/−0
- poll-example/snaplets/heist/jobstatus.tpl +22/−0
- snap-extras.cabal +79/−22
- src/Snap/Extras.hs +9/−6
- src/Snap/Extras/Ajax.hs +6/−6
- src/Snap/Extras/CSRF.hs +32/−14
- src/Snap/Extras/FlashNotice.hs +13/−14
- src/Snap/Extras/FormUtils.hs +3/−3
- src/Snap/Extras/MethodOverride.hs +62/−0
- src/Snap/Extras/NavTrails.hs +16/−17
- src/Snap/Extras/PollStatus.hs +278/−0
- src/Snap/Extras/SpliceUtils/Common.hs +6/−3
- src/Snap/Extras/SpliceUtils/Compiled.hs +2/−2
- src/Snap/Extras/SpliceUtils/Interpreted.hs +8/−7
- src/Snap/Extras/Tabs.hs +19/−9
- test/src/Main.hs +14/−0
+ poll-example/PollExample.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where++------------------------------------------------------------------------------+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.MVar+import Control.Lens+import Control.Monad+import Control.Monad.State+import Control.Monad.Trans+import Data.Aeson+import Data.IORef+import qualified Data.Map as M+import Data.Monoid+import Data.Readable+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time+import Heist+import Heist.Compiled+import Snap.Core+import Snap.Http.Server+import Snap.Snaplet+import Snap.Snaplet.Heist.Compiled+import Snap.Util.FileServe+------------------------------------------------------------------------------+import Snap.Extras.CoreUtils+import Snap.Extras.PollStatus+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- Job infrastructure that would have been necessary anyway+------------------------------------------------------------------------------+++data JobRepo = JobRepo+ { repoNextInd :: Int+ , repoJobs :: M.Map Int Status+ }++emptyJobRepo = JobRepo 0 M.empty++newJob :: UTCTime -> UTCTime -> JobRepo -> (JobRepo, Int)+newJob ts curTs repo = (JobRepo (i+1) jobs, i)+ where+ i = repoNextInd repo+ jobs = M.insert i (Status (Just ts) curTs Running [] 0 10) $+ repoJobs repo++updateJob :: Int -> (Status -> Status) -> JobRepo -> (JobRepo, ())+updateJob jobId f repo = (JobRepo (repoNextInd repo) newJobs, ())+ where+ curJobs = repoJobs repo+ newJobs = M.update (g . f) jobId curJobs+ g s = if statusAmountCompleted s == statusAmountTotal s+ then Just $ s { statusJobState = FinishedSuccess }+ else Just s++jobAction+ :: IORef JobRepo+ -> Int+ -> Double+ -> IO ()+jobAction ref jobId seconds = do+ let inc = seconds / 100.0+ numIters = ceiling $ seconds / inc+ forM_ [1..numIters] $ \n -> do+ threadDelay $ round $ inc * 1000000+ ts <- liftIO getCurrentTime+ let setStatus s = s { statusTimestamp = ts+ , statusAmountCompleted = (fromIntegral n * inc) }+ atomicModifyIORef' ref (updateJob jobId setStatus)+++------------------------------------------------------------------------------+-- Web app boilerplate for this test+------------------------------------------------------------------------------+++data App = App+ { _heist :: Snaplet (Heist App)+ , _repo :: IORef JobRepo+ }+makeLenses ''App++instance HasHeist App where+ heistLens = subSnaplet heist++routes = [ ("startJob", startlongjob)+ , ("myJobStatus", jobStatusHandler "_status" ".statusdiv")+ , ("", heistServe)+ , ("", serveDirectory "static")+ ]++appInit = makeSnaplet "app" "blah" Nothing $ do+ h <- nestSnaplet "" heist $ heistInit' "" $ mempty+ { hcLoadTimeSplices = defaultLoadTimeSplices+ , hcCompiledSplices = splices+ }+ addRoutes routes+ ref <- liftIO $ newIORef emptyJobRepo+ return $ App h ref++main :: IO ()+main = do+ serveSnaplet defaultConfig appInit+++------------------------------------------------------------------------------+-- Core code needed to create a polling job+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | You have to define at least these three splices in your application. The+-- first two are static. You'll need an instance of the third one for each+-- type of job you need status for.+splices = do+ -- You need one of these status splices per status job type+ "jobStatus" ## statusSplice statusSplices getUrl getMyJobStatus+ statusFinished+ where+ getUrl = do+ jobId <- getParam "jobId"+ return $ fmap (T.decodeUtf8 . ("myJobStatus?jobId=" <>)) jobId+++------------------------------------------------------------------------------+-- | Starts a job and returns its job ID.+startlongjob :: Handler App App ()+startlongjob = do+ ref <- gets _repo+ ts <- liftIO getCurrentTime+ jobId <- liftIO $ atomicModifyIORef' ref (newJob ts ts)+ liftIO $ forkIO $ jobAction ref jobId 10+ redirect $ T.encodeUtf8 $ "jobstatus?jobId=" <> (T.pack $ show jobId)+++------------------------------------------------------------------------------+-- | A function that gets the status of a job.+getMyJobStatus :: Handler App App (Maybe Status)+getMyJobStatus = do+ ref <- gets _repo+ repo <- liftIO $ readIORef ref+ mjidbs <- getParam "jobId"+ return $ do+ jobId <- fromBS =<< mjidbs+ M.lookup jobId (repoJobs repo)++
+ poll-example/snaplets/heist/_status.tpl view
@@ -0,0 +1,21 @@+<jobStatus interval="300">+ <ifRunning>+ <elapsedSeconds/> seconds elapsed++ <div class="progress">+ <div class="progress-bar progress-bar-striped active" role="progressbar"+ aria-valuenow="${amountCompleted}" aria-valuemin="0" aria-valuemax="${amountTotal}" style="width: ${percentCompleted}%">+ <percentCompleted/>%+ </div>+ </div>++ </ifRunning>+ <ifFinished>+ <div class="progress">+ <div class="progress-bar progress-bar-striped" role="progressbar"+ aria-valuenow="${amountCompleted}" aria-valuemin="0" aria-valuemax="${amountTotal}" style="width: ${percentCompleted}%">+ <percentCompleted/>%+ </div>+ </div>+ </ifFinished>+</jobStatus>
+ poll-example/snaplets/heist/index.tpl view
@@ -0,0 +1,8 @@+<html>+ <head>+ </head>+ <body>+ <h1>Hello</h1>+ <a href="startJob">Create new job</a>+ </body>+</html>
+ poll-example/snaplets/heist/jobstatus.tpl view
@@ -0,0 +1,22 @@+<html>+ <head>+ <script src="http://telescope-assets.s3.amazonaws.com/js/jquery.js"></script>+ <script src="http://telescope-assets.s3.amazonaws.com/js/jquery-ui.js"></script>++ <link rel="stylesheet" href="//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css">+ <link rel="stylesheet" href="//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap-theme.min.css">+ <script src="//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/js/bootstrap.min.js"></script>++ </head>+ <body>+ <div class="container">+ <h1>Status</h1>+ <div class="row">+ <div class="statusdiv col-md-4">+ <apply template="_status"/>+ </div>+ </div>+ </div>+ </body>+</html>+
snap-extras.cabal view
@@ -1,5 +1,5 @@ Name: snap-extras-Version: 0.9+Version: 0.11 Synopsis: A collection of useful helpers and utilities for Snap web applications. Description: This package contains a collection of helper functions that come in handy in most practical, real-world@@ -17,52 +17,109 @@ data-files: resources/templates/*.tpl+ poll-example/PollExample.hs+ poll-example/snaplets/heist/*.tpl +Flag Examples+ Description: Build the examples.+ Default: False+ Library- Exposed-modules: + Exposed-modules: Snap.Extras Snap.Extras.Ajax- Snap.Extras.CoreUtils Snap.Extras.CSRF- Snap.Extras.TextUtils- Snap.Extras.JSON+ Snap.Extras.CoreUtils Snap.Extras.FlashNotice+ Snap.Extras.FormUtils+ Snap.Extras.JSON+ Snap.Extras.MethodOverride+ Snap.Extras.NavTrails+ Snap.Extras.PollStatus Snap.Extras.SpliceUtils.Compiled Snap.Extras.SpliceUtils.Interpreted- Snap.Extras.FormUtils Snap.Extras.Tabs- Snap.Extras.NavTrails+ Snap.Extras.TextUtils other-modules: Snap.Extras.SpliceUtils.Common Paths_snap_extras hs-source-dirs: src Build-depends:- aeson >= 0.6 && < 0.8+ aeson >= 0.6 && < 0.9 , base >= 4 && < 5- , blaze-builder >= 0.3 && < 0.4- , blaze-html >= 0.6 && < 0.8+ , blaze-builder >= 0.3 && < 0.5+ , blaze-html >= 0.6 && < 0.9 , bytestring >= 0.9.1 && < 0.11- , configurator >= 0.2 && < 0.3+ , case-insensitive >= 1.0 && < 1.3+ , configurator >= 0.2 && < 0.4 , containers >= 0.3 && < 0.6 , data-default >= 0.5 && < 0.6 , digestive-functors >= 0.3 && < 0.8 , digestive-functors-heist >= 0.8 && < 0.9 , digestive-functors-snap >= 0.3 && < 0.7- , directory-tree >= 0.10 && < 0.12+ , directory-tree >= 0.10 && < 0.13 , errors >= 1.4 && < 1.5- , filepath >= 1.1 && < 1.4- , heist >= 0.13 && < 0.14- , mtl >= 2.0 && < 2.2- , readable >= 0.1 && < 0.3+ , filepath >= 1.1 && < 1.5+ , heist >= 0.14 && < 0.15+ , jmacro >= 0.6 && < 0.7+ , lens < 5+ , mtl >= 2.0 && < 2.3+ , pcre-light >= 0.4 && < 0.5+ , readable >= 0.1 && < 0.4 , safe >= 0.3 && < 0.4- , snap >= 0.13 && < 0.14+ , snap >= 0.13 && < 0.15 , snap-core >= 0.7 && < 0.10- , text >= 0.11 && < 1.2- , transformers >= 0.2 && < 0.4+ , text >= 0.11 && < 1.3+ , time >= 1.4 && < 1.6+ , transformers >= 0.2 && < 0.5+ , wl-pprint-text >= 1.1 && < 1.2 , xmlhtml >= 0.1.6 && < 0.3- , jmacro >= 0.6 && < 0.7- + ghc-options: -Wall -fwarn-tabs default-language: Haskell2010- ++Executable PollExample+ Main-is: PollExample.hs+ Hs-source-dirs: poll-example++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ aeson+ , base == 4.*+ , containers+ , heist+ , lens+ , mtl+ , readable+ , snap+ , snap-core+ , snap-extras+ , snap-server+ , text+ , time+ , transformers++ Default-Language: Haskell2010+++Test-Suite test+ Type: exitcode-stdio-1.0+ Main-Is: Main.hs+ Ghc-Options: -threaded -rtsopts -O0+ Default-Language: Haskell2010+ Hs-Source-Dirs:+ test/src+ Build-Depends:+ base+ , bytestring+ , containers+ , snap-core+ , snap-extras+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , QuickCheck
src/Snap/Extras.hs view
@@ -2,16 +2,19 @@ module Snap.Extras ( module Snap.Extras.Ajax+ , module Snap.Extras.CSRF , module Snap.Extras.CoreUtils- , module Snap.Extras.TextUtils- , module Snap.Extras.JSON , module Snap.Extras.FlashNotice , module Snap.Extras.FormUtils+ , module Snap.Extras.JSON+ , module Snap.Extras.MethodOverride , module Snap.Extras.Tabs+ , module Snap.Extras.TextUtils , initExtras ) where -------------------------------------------------------------------------------+import Control.Lens import Data.Monoid import Heist import Snap.Snaplet@@ -21,9 +24,11 @@ ------------------------------------------------------------------------------- import Snap.Extras.Ajax import Snap.Extras.CoreUtils+import Snap.Extras.CSRF import Snap.Extras.FlashNotice import Snap.Extras.FormUtils import Snap.Extras.JSON+import Snap.Extras.MethodOverride import qualified Snap.Extras.SpliceUtils.Compiled as C import qualified Snap.Extras.SpliceUtils.Interpreted as I import Snap.Extras.Tabs@@ -48,8 +53,6 @@ addTemplatesAt heistSnaplet "" . (</> "resources/templates") =<< getSnapletFilePath initFlashNotice heistSnaplet session- addConfig heistSnaplet $ mempty- { hcInterpretedSplices = I.utilSplices- , hcCompiledSplices = C.utilSplices- }+ addConfig heistSnaplet $ mempty & scInterpretedSplices .~ I.utilSplices+ & scCompiledSplices .~ C.utilSplices initTabs heistSnaplet
src/Snap/Extras/Ajax.hs view
@@ -28,7 +28,7 @@ import Control.Applicative import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B-import Data.Text+import Data.Text (Text) import qualified Data.Text as T import Heist.Compiled import Language.Javascript.JMacro@@ -60,8 +60,8 @@ replaceWithJs :: String -> String -> JStat replaceWithJs bs sel = [jmacro| var contents = `(bs)`;- var replace = function() { $(`(sel)`).html(contents); };- replace();+ var replaceJs = function() { $(`(sel)`).html(contents); };+ replaceJs(); |] @@ -72,16 +72,16 @@ -- Currently expect you to have jQuery loaded. -- TODO: Make this jQuery independent replaceWithTemplate- :: HasHeist v+ :: HasHeist b => ByteString -- ^ Heist template name -> Text -- ^ jQuery selector for target element on page- -> Handler v v ()+ -> Handler b v () replaceWithTemplate nm sel = do (bld, _) <- maybeBadReq "Could not render a response." $ withHeistState $ \ hs -> renderTemplate hs nm- bld' <- bld+ bld' <- withTop' id bld replaceWith sel (toByteString bld')
src/Snap/Extras/CSRF.hs view
@@ -3,13 +3,14 @@ module Snap.Extras.CSRF where ------------------------------------------------------------------------------+import Control.Monad.Trans import qualified Data.ByteString.Char8 as B import Data.Text (Text) import qualified Data.Text.Encoding as T-import Snap-import Snap.Snaplet.Session import Heist import Heist.Interpreted+import Snap+import Snap.Snaplet.Session import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ @@ -75,11 +76,13 @@ -> Handler b v () -- ^ Handler to run if the CSRF check fails -> Handler b v ()-blanketCSRF session onFailure = do- h <- getHeader "Content-type" `fmap` getRequest+ -- ^ Handler to let through when successful.+ -> Handler b v ()+blanketCSRF session onFailure onSucc = do+ h <- getHeader "content-type" `fmap` getRequest case maybe False (B.isInfixOf "multipart/form-data") h of- True -> return ()- False -> handleCSRF session onFailure+ True -> onSucc+ False -> handleCSRF session onFailure onSucc ------------------------------------------------------------------------------@@ -91,13 +94,28 @@ -> Handler b v () -- ^ Handler to run on failure -> Handler b v ()-handleCSRF session onFailure = do+ -- ^ Handler to let through when successful.+ -> Handler b v ()+handleCSRF session onFailure onSucc = do m <- getsRequest rqMethod- if m /= POST- then return ()- else do tok <- getParam "_csrf"- realTok <- with session csrfToken- if tok == Just (T.encodeUtf8 realTok)- then return ()- else onFailure >> getResponse >>= finishWith+ case m /= POST of+ True -> onSucc+ False -> do+ tok <- getParam "_csrf"+ realTok <- with session csrfToken+ if tok == Just (T.encodeUtf8 realTok)+ then onSucc+ else onFailure >> getResponse >>= finishWith+++-------------------------------------------------------------------------------+-- | A version of 'handleCSRF' that works as an imperative filter.+-- It's a NOOP when successful, redirs to oblivion under failure.+handleCSRF'+ :: SnapletLens v SessionManager+ -> Handler b v ()+ -- ^ On failure+ -> Handler b v ()+handleCSRF' ses onFail = handleCSRF ses onFail (return ())+
src/Snap/Extras/FlashNotice.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-} module Snap.Extras.FlashNotice ( initFlashNotice@@ -12,18 +12,19 @@ ) where -------------------------------------------------------------------------------+import Control.Lens import Control.Monad import Control.Monad.Trans import Data.Maybe import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text as T+import Heist+import qualified Heist.Compiled as C+import Heist.Interpreted import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Snaplet.Session-import Heist-import Heist.Interpreted-import qualified Heist.Compiled as C import Text.XmlHtml ------------------------------------------------------------------------------- @@ -32,14 +33,14 @@ -- | Initialize the flash notice system. All you have to do now is to -- add some flash tags in your application template. See 'flashSplice' -- for examples.-initFlashNotice - :: HasHeist b +initFlashNotice+ :: HasHeist b => Snaplet (Heist b) -> SnapletLens b SessionManager -> Initializer b v () initFlashNotice h session = do let splices = ("flash" ## flashSplice session) csplices = ("flash" ## flashCSplice session)- addConfig h $ mempty { hcCompiledSplices = csplices- , hcInterpretedSplices = splices }+ addConfig h $ mempty & scCompiledSplices .~ csplices+ & scInterpretedSplices .~ splices ------------------------------------------------------------------------------- -- | Display an info message on next load of a page@@ -76,7 +77,7 @@ let typ' = maybe "warning" id typ let k = T.concat ["_", typ'] msg <- lift $ withTop session $ getFromSession k- case msg of + case msg of Nothing -> return [] Just msg' -> do lift $ withTop session $ deleteFromSession k >> commitSession@@ -101,7 +102,7 @@ "message" ## return $ C.yieldRuntimeText $ liftM (fromMaybe "Flash notice cookie error") getVal- flashTemplate <- C.withLocalSplices ss noSplices (C.callTemplate "_flash")+ flashTemplate <- C.withLocalSplices ss mempty (C.callTemplate "_flash") return $ C.yieldRuntime $ do msg <- getVal case msg of@@ -112,5 +113,3 @@ deleteFromSession k commitSession return res--
src/Snap/Extras/FormUtils.hs view
@@ -27,12 +27,12 @@ import qualified Data.ByteString.Char8 as B import Data.String import Data.Text (Text)-import Data.Text.Encoding import qualified Data.Text as T-import Heist+import Data.Text.Encoding+import Heist hiding (Error) import Snap.Core import Text.Digestive-import qualified Text.XmlHtml as X+import qualified Text.XmlHtml as X -------------------------------------------------------------------------------
+ src/Snap/Extras/MethodOverride.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Extras.MethodOverride+ ( handleMethodOverride+ , handleMethodOverride'+ ) where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.ByteString (ByteString)+import Data.CaseInsensitive (mk, original)+import Data.Maybe (fromMaybe)+import Safe (headMay)+import Snap.Core+-------------------------------------------------------------------------------++++-------------------------------------------------------------------------------+-- | Wrap a handler with method override support. This means that if+-- (and only if) the request is a POST, _method param is passed, and+-- it is a parsable method name, it will change the request method to+-- the supplied one. This works around some browser limitations with+-- forms. If you use a different parameter name than _method, use+-- handleMethodOverride'+handleMethodOverride :: MonadSnap m+ => m a+ -- ^ Internal handler to call+ -> m a+handleMethodOverride = handleMethodOverride' "_method"+++-------------------------------------------------------------------------------+handleMethodOverride' :: MonadSnap m+ => ByteString+ -- ^ parameter name for method+ -> m a+ -- ^ Internal handler to call+ -> m a+handleMethodOverride' pn = (modifyRequest (methodOverride pn) >>)+++-------------------------------------------------------------------------------+methodOverride :: ByteString -> Request -> Request+methodOverride param r+ | rqMethod r == POST = r { rqMethod = overridden }+ | otherwise = r+ where+ overridden = fromMaybe POST $ do+ meth <- mk <$> (headMay =<< rqParam param r)+ case meth of+ "HEAD" -> Just HEAD+ "POST" -> Just POST+ "PUT" -> Just PUT+ "DELETE" -> Just DELETE+ "TRACE" -> Just TRACE+ "OPTIONS" -> Just OPTIONS+ "CONNECT" -> Just CONNECT+ "PATCH" -> Just PATCH+ "" -> Nothing+ s -> Just $ Method $ original s+
@@ -5,22 +5,22 @@ module Snap.Extras.NavTrails where import Blaze.ByteString.Builder.ByteString+import Control.Lens hiding (lens) import Control.Monad.State.Strict-import Data.ByteString (ByteString)+import Data.ByteString (ByteString) import Data.Maybe import Data.Monoid-import Data.Text (Text)-import qualified Data.Text.Encoding as T+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Heist+import qualified Heist.Compiled as C+import Heist.Interpreted import Snap.Core import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Snaplet.Session-import Heist-import qualified Heist.Compiled as C-import Heist.Interpreted - ------------------------------------------------------------------------------- data NavTrail b = NavTrail { ntSes :: SnapletLens b SessionManager@@ -127,13 +127,12 @@ addNavTrailSplices :: Snaplet (Heist b) -> Initializer b (NavTrail b) () addNavTrailSplices heist = do lens <- getLens- addConfig heist $- mempty { hcCompiledSplices = do- "linkToFocus" ## focusCSplice lens- "linkToBack" ## backCSplice- , hcInterpretedSplices = do- "linkToFocus" ## focusSplice lens- "linkToBack" ## backSplice- }--+ addConfig heist $ mempty & scCompiledSplices .~ compiledSplices lens+ & scInterpretedSplices .~ interpretedSplices lens+ where+ compiledSplices lens = do+ "linkToFocus" ## focusCSplice lens+ "linkToBack" ## backCSplice+ interpretedSplices lens = do+ "linkToFocus" ## focusSplice lens+ "linkToBack" ## backSplice
+ src/Snap/Extras/PollStatus.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++{-|++This module provides infrastructure for polling the status of processes that+run longer than a single request-response lifecycle. To do this, we issue+AJAX calls at regular intervals to a route that updates the status on the+page. There are two main components necessary to use this library: splices+and a handler.++The handler is a simple 'jobStatusHandler' function. Typically you'll add it+to your site's list of routes like this:++> route [ ...+> , ("myJobStatus", jobStatusHandler "statusTemplate" ".statusDiv")+> , ...+> ]++The first argument to jobsHandler is the template that will be rendered for+status update requests. It will typically be not much more than a+@\<myJobStatus\>@ tag enclosing the custom markup for displaying your job status.+Here's an example using a bootstrap progress bar:++> <myJobStatus interval="300">+> <ifRunning>+> <elapsedSeconds/> seconds elapsed+>+> <div class="progress">+> <div class="progress-bar progress-bar-striped active" role="progressbar"+> aria-valuenow="${amountCompleted}" aria-valuemin="0"+> aria-valuemax="${amountTotal}" style="width: ${percentCompleted}%">+> <percentCompleted/>%+> </div>+> </div>+>+> </ifRunning>+> <ifFinished>+> <div class="progress">+> <div class="progress-bar progress-bar-striped" role="progressbar"+> aria-valuenow="${amountCompleted}" aria-valuemin="0"+> aria-valuemax="${amountTotal}" style="width: ${percentCompleted}%">+> <percentCompleted/>%+> </div>+> </div>+> </ifFinished>+> </myJobStatus>++This will poll for updates every 300 milliseconds. See the documentation for+'statusSplice' for more details.++To get the above code working, you would have the myJobStatusPage handler+return markup that contains something like this:++> <h1>Status</h1>+> <div class="statusdiv col-md-4">+> <apply template="statusTemplate"/>+> </div>++You will also need to bind the main splice provided by this module.++> splices = do+> ...+> "myJobStatus" ## statusSplice splices getUrl getMyJobStatus isFinished++You need to bind this splice once for each type of action that you are+polling, each with its own splice name and function for getting the job+status.++-}++module Snap.Extras.PollStatus+ ( jobStatusHandler+ , statusSplice++ -- * Generic Status Type++ , JobState(..)+ , jobFinished+ , statusFinished+ , Status(..)+ , statusPercentCompleted+ , statusElapsed+ , statusSplices+ ) where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import qualified Blaze.ByteString.Builder.Char8 as BB+import Control.Applicative+import Control.Error+import Control.Monad+import Control.Monad.Trans+import Data.ByteString (ByteString)+import Data.Monoid+import Data.Readable+import Data.Text+import qualified Data.Text as T+import Data.Time+import Heist+import Heist.Compiled+import Heist.Splices+import Language.Javascript.JMacro+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.Heist.Compiled (HasHeist)+import Text.PrettyPrint.Leijen.Text (renderOneLine)+import qualified Text.XmlHtml as X+------------------------------------------------------------------------------+import Snap.Extras.Ajax+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Top-level handler that handles the job polling infrastructure.+jobStatusHandler+ :: HasHeist b+ => ByteString+ -- ^ Name of the template to use for the updateStatus endpoint.+ -> T.Text+ -- ^ A CSS selector string used to substitute the contents of the AJAX+ -- template into the status page.+ -> Handler b v ()+jobStatusHandler updateTemplate selector =+ replaceWithTemplate updateTemplate selector+++------------------------------------------------------------------------------+-- | Function to generate a status splice. This splice makes the following+-- splices available to its children:+--+-- Conditional splices:+-- ifPending, ifRunning, ifNotFinished, ifFinished, ifFinishedSuccess,+-- ifFinishedFailure+--+-- Data splices:+-- elapsedSeconds, startTime, endTime, jobState, messages, percentCompleted,+-- amountCompleted, amountTotal+statusSplice+ :: Monad n+ => Splices (RuntimeSplice n status -> Splice n)+ -- ^ Splices defined for your job status type status.+ -> n (Maybe Text)+ -- ^ Handler to get the URL that should be used for requesting AJAX status+ -- updates. This must be a handler because it will usually contain some+ -- form of job ID that is only obtainable at runtime.+ -> n (Maybe status)+ -- ^ Handler that knows how to get the status of the job in question.+ -- This typically will require it to know how to get some sort of job ID+ -- from the request.+ -> (status -> Bool)+ -- ^ A function to tell whether the status is finished+ -> Splice n+statusSplice splices getUrl getStatus isFinished = do+ n <- getParamNode+ runAttrs <- runAttributesRaw $ X.elementAttrs n+ let nodes = X.elementChildren n ++ [X.Element "updateJs" [] []]+ run = runNodeList nodes+ mayDeferMap return (withSplices run allSplices) $ do+ attrs <- runAttrs+ let delay = fromMaybe 1000 $ fromText =<< lookup "interval" attrs+ runMaybeT $ do+ url <- MaybeT $ lift getUrl+ let js = T.concat ["<script>", updateJS url delay, "</script>"]+ s <- MaybeT $ lift getStatus+ return (js, s)+ where+ allSplices = do+ "updateJs" ## pureSplice internalUpdate+ mapV (. liftM snd) splices+ internalUpdate (js,s) =+ if not $ isFinished s+ then BB.fromText js+ else mempty+++------------------------------------------------------------------------------+-- | JS code to do an AJAX request to updateStatus after a delay.+updateJS+ :: Text+ -- ^ The url for incremental status updates+ -> Int+ -- ^ The amount of time to wait before requesting the page in milliseconds+ -> Text+updateJS url delay = T.pack $ show $ renderOneLine $ renderJs $+ [jmacro|+ setTimeout(function() {+ $.get(`(T.unpack url)`);+ }, `(show delay)`);+ |]+++------------------------------------------------------------------------------+-- Example Implementation+------------------------------------------------------------------------------+++-- The above functions are everything you need to use the polling+-- infrastructure using yo++------------------------------------------------------------------------------+-- | Enumeration of the states a job can be in.+data JobState = Pending | Running | FinishedSuccess | FinishedFailure+ deriving (Eq,Show,Read,Enum)+++------------------------------------------------------------------------------+-- | Returns a bool indicating whether the job is finished.+jobFinished :: JobState -> Bool+jobFinished FinishedSuccess = True+jobFinished FinishedFailure = True+jobFinished _ = False+++------------------------------------------------------------------------------+-- | Returns a bool indicating whether the job is finished.+statusFinished :: Status -> Bool+statusFinished = jobFinished . statusJobState+++------------------------------------------------------------------------------+-- | The complete status of a job.+data Status = Status+ { statusStartTime :: Maybe UTCTime+ , statusTimestamp :: UTCTime+ , statusJobState :: JobState+ , statusMessages :: [Text]+ , statusAmountCompleted :: Double+ , statusAmountTotal :: Double+ } deriving (Eq,Show)+++------------------------------------------------------------------------------+-- | Calculates the percent completed as an Int.+statusPercentCompleted :: Status -> Int+statusPercentCompleted Status{..} =+ round $ 100.0 * statusAmountCompleted / statusAmountTotal+++------------------------------------------------------------------------------+tshow :: Show a => a -> Text+tshow = T.pack . show+++------------------------------------------------------------------------------+-- | The status splices+statusSplices+ :: Monad n+ => Splices (RuntimeSplice n Status -> Splice n)+statusSplices = do+ "ifPending" ## ifCSplice ((==Pending) . statusJobState)+ "ifRunning" ## ifCSplice ((==Running) . statusJobState)+ "ifNotFinished" ## ifCSplice (not . statusFinished)+ "ifFinished" ## ifCSplice (statusFinished)+ "ifFinishedSuccess" ## ifCSplice ((==FinishedSuccess) . statusJobState)+ "ifFinishedFailure" ## ifCSplice ((==FinishedFailure) . statusJobState)+ "messages" ## manyWithSplices runChildren+ ("msgText" ## pureSplice (textSplice id)) .+ (liftM $ statusMessages)+ mapV pureSplice $ do+ "startTime" ## textSplice (tshow . statusStartTime)+ "endTime" ## textSplice (tshow . statusTimestamp)+ "jobState" ## textSplice (tshow . statusJobState )+ "percentCompleted" ## textSplice (tshow . statusPercentCompleted)+ "amountCompleted" ## textSplice (tshow . statusAmountCompleted)+ "amountTotal" ## textSplice (tshow . statusAmountTotal)+++------------------------------------------------------------------------------+statusElapsed :: Status -> Maybe Int+statusElapsed Status{..} =+ round . diffUTCTime statusTimestamp <$> statusStartTime++
src/Snap/Extras/SpliceUtils/Common.hs view
@@ -1,17 +1,20 @@ module Snap.Extras.SpliceUtils.Common where -import qualified Data.Foldable as F+-------------------------------------------------------------------------------+import Control.Monad.Trans+import qualified Data.Foldable as F import Data.List import Snap import System.Directory.Tree import System.FilePath+------------------------------------------------------------------------------- getScripts :: MonadIO m => FilePath -> m [String] getScripts d = do tree <- liftIO $ build d- let files = F.foldMap ((:[]) . fst) $ zipPaths $ "" :/ free tree+ let files = F.foldMap ((:[]) . fst) $ zipPaths $ "" :/ dirTree tree return $ sort $ filter visibleScripts files where visibleScripts fname =- isSuffixOf ".js" fname && not (isPrefixOf "_" (takeFileName fname))+ isSuffixOf ".js" fname && not ("_" `isPrefixOf` takeFileName fname)
src/Snap/Extras/SpliceUtils/Compiled.hs view
@@ -98,7 +98,7 @@ p <- newEmptyPromise let splices' = do- mapS ($ getPromise p) splices+ mapV ($ getPromise p) splices "prelude" ## return mempty "interlude" ## return mempty "postlude" ## return mempty@@ -107,7 +107,7 @@ interChunks <- findNamedChild n "interlude" postChunks <- findNamedChild n "postlude" - itemChunks <- withLocalSplices splices' noSplices runChildren+ itemChunks <- withLocalSplices splices' mempty runChildren return $ yieldRuntime $ do items <- action case items of
src/Snap/Extras/SpliceUtils/Interpreted.hs view
@@ -13,17 +13,18 @@ ------------------------------------------------------------------------------- import Control.Monad+import Control.Monad.Trans import Control.Monad.Trans.Class-import qualified Data.Configurator as C-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import qualified Data.Configurator as C+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Heist+import Heist.Interpreted+import Heist.Splices import Snap import Snap.Extras.SpliceUtils.Common import Snap.Snaplet.Heist.Interpreted-import Heist-import Heist.Splices-import Heist.Interpreted import Text.XmlHtml -------------------------------------------------------------------------------
src/Snap/Extras/Tabs.hs view
@@ -23,6 +23,7 @@ ------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as B import Control.Error+import Control.Lens import Control.Monad import Control.Monad.Trans @@ -36,6 +37,7 @@ import Snap.Core import Snap.Snaplet import Snap.Snaplet.Heist+import Text.Regex.PCRE.Light import Text.XmlHtml import qualified Text.XmlHtml as X -------------------------------------------------------------------------------@@ -47,8 +49,8 @@ initTabs h = do let splices = ("tabs" ## tabsSplice) csplices = ("tabs" ## tabsCSplice)- addConfig h $ mempty { hcCompiledSplices = csplices- , hcInterpretedSplices = splices }+ addConfig h $ mempty & scCompiledSplices .~ csplices+ & scInterpretedSplices .~ splices -------------------@@ -64,7 +66,7 @@ let getCtx = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest splices = ("tab" ## tabCSplice getCtx) case n of- Element _ attrs ch -> C.withLocalSplices splices noSplices $+ Element _ attrs ch -> C.withLocalSplices splices mempty $ C.runNode $ X.Element "ul" attrs ch _ -> error "tabs tag has to be an Element" @@ -84,6 +86,10 @@ "Exact" -> Right $ url == context "Prefix" -> Right $ url `T.isPrefixOf` context "Infix" -> Right $ url `T.isInfixOf` context+ "Regex" -> do+ pat <- note "regex tabs must specify a 'pat' attribute" $ lookup "pat" as+ let r = compile (T.encodeUtf8 pat) []+ Right $ isJust $ match r (T.encodeUtf8 context) [] "None" -> Right $ False _ -> Left "Unknown match type" return (url, m')@@ -93,32 +99,36 @@ ns <- nodes let innerFrag = X.parseHTML "inner" $ B.toByteString ns let res = either (error . ("Tab errror: " ++) ) id $ do- (url, match) <- ps as ctx+ (url, matches) <- ps as ctx inner <- innerFrag let actClass = maybe "active" (T.append "active " ) $ lookup "class" as- attr' = if match then ("class", actClass) : as else as+ attr' = if matches then ("class", actClass) : as else as a = X.Element "a" (("href", url) : as) (X.docContent inner) return $ X.renderHtmlFragment X.UTF8 [X.Element "li" attr' [a]] return res tabSpliceWorker :: Node -> Text -> [Node]-tabSpliceWorker n@(Element _ attrs ch) context =+tabSpliceWorker (Element _ attrs ch) context = case ps of Left e -> error $ "Tab error: " ++ e- Right (url, c, match) ->- let attr' = if match then ("class", "active") : attrs else attrs+ Right (url, c, matches) ->+ let attr' = if matches then ("class", "active") : attrs else attrs a = X.Element "a" (("href", url) : attrs) c in [X.Element "li" attr' [a]] where ps = do m <- note "tab must specify a 'match' attribute" $ lookup "match" attrs- url <- note "tabs must specify a 'url' attribute" $ getAttribute "url" n+ url <- note "tabs must specify a 'url' attribute" $ lookup "url" attrs m' <- case m of "Exact" -> Right $ url == context "Prefix" -> Right $ url `T.isPrefixOf` context "Infix" -> Right $ url `T.isInfixOf` context+ "Regex" -> do+ pat <- note "regex tabs must specify a 'pat' attribute" $ lookup "pat" attrs+ let r = compile (T.encodeUtf8 pat) []+ Right $ isJust $ match r (T.encodeUtf8 context) [] "None" -> Right $ False _ -> Left "Unknown match type" return (url, ch, m')
+ test/src/Main.hs view
@@ -0,0 +1,14 @@+module Main+ ( main+ ) where++-------------------------------------------------------------------------------+import Test.Tasty+-------------------------------------------------------------------------------+import Snap.Extras.Tests.MethodOverride (methodOverrideTests)+-------------------------------------------------------------------------------++main = do+ defaultMain $ testGroup "tests"+ [ methodOverrideTests+ ]