snap-extras 0.9 → 0.12.3.2
raw patch · 23 files changed
Files
- README.md +16/−0
- changelog.md +23/−0
- 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 +101/−33
- src/Snap/Extras.hs +10/−7
- src/Snap/Extras/Ajax.hs +8/−8
- src/Snap/Extras/CSRF.hs +32/−14
- src/Snap/Extras/FlashNotice.hs +21/−21
- src/Snap/Extras/FormUtils.hs +10/−8
- src/Snap/Extras/JSON.hs +10/−10
- src/Snap/Extras/MethodOverride.hs +62/−0
- src/Snap/Extras/NavTrails.hs +19/−19
- src/Snap/Extras/PollStatus.hs +278/−0
- src/Snap/Extras/SpliceUtils/Common.hs +6/−4
- src/Snap/Extras/SpliceUtils/Compiled.hs +12/−11
- src/Snap/Extras/SpliceUtils/Interpreted.hs +26/−21
- src/Snap/Extras/Tabs.hs +38/−21
- test/src/Main.hs +14/−0
- test/src/Snap/Extras/Tests/Arbitrary.hs +29/−0
- test/src/Snap/Extras/Tests/MethodOverride.hs +75/−0
+ README.md view
@@ -0,0 +1,16 @@++# Snap-Extras [](https://travis-ci.org/ozataman/snap-extras)++A collection of useful helpers and utilities for Snap web+applications.++This package contains a collection of helper functions that come in+handy in most practical, real-world applications. Check individual+modules to understand what's here. You can simply import Snap.Extras+and use the initializer in there to get them all at once.+++# Contributors++- Ozgun Ataman+- Doug Beardsley
+ changelog.md view
@@ -0,0 +1,23 @@+0.12.3.2+* GHC 9.12 compatibility [#30](https://github.com/ozataman/snap-extras/pull/30)++0.12.3.1+* GHC 9.6 and Lens 5 compatibility [#29](https://github.com/ozataman/snap-extras/pull/29)++0.12.3.0+* Remove upper bounds on dependencies.++0.12.2.1+* Refactor in a few views to keep compatibility with MonadFail changes.++0.12.2.0+* Loosen dependencies.++0.12.1.1+* Add missing test suite files to package.++0.12.1.0+* Backwards compatibility fixes for versions of base < 4.8.++0.12.0.0+* Support snap 1.0. This drops support for some older versions of snap.
+ 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 qualified Data.Map.Syntax as MS+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' "" hc+ addRoutes routes+ ref <- liftIO $ newIORef emptyJobRepo+ return $ App h ref+ where+ hc = emptyHeistConfig+ & hcLoadTimeSplices .~ defaultLoadTimeSplices+ & hcCompiledSplices .~ splices++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" MS.## 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.12.3.2 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@@ -13,56 +13,124 @@ Category: Web, Snap Build-type: Simple Cabal-version: >= 1.10-+Extra-source-files:+ README.md+ changelog.md 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 , base >= 4 && < 5- , blaze-builder >= 0.3 && < 0.4- , blaze-html >= 0.6 && < 0.8- , bytestring >= 0.9.1 && < 0.11- , configurator >= 0.2 && < 0.3- , 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- , 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- , safe >= 0.3 && < 0.4- , snap >= 0.13 && < 0.14- , snap-core >= 0.7 && < 0.10- , text >= 0.11 && < 1.2- , transformers >= 0.2 && < 0.4- , xmlhtml >= 0.1.6 && < 0.3- , jmacro >= 0.6 && < 0.7- + , blaze-builder >= 0.3+ , blaze-html >= 0.6+ , bytestring >= 0.9.1+ , case-insensitive >= 1.0+ , configurator >= 0.2+ , containers >= 0.3+ , data-default >= 0.5+ , digestive-functors >= 0.3+ , digestive-functors-heist >= 0.8+ , digestive-functors-snap >= 0.3+ , directory-tree >= 0.10+ , filepath >= 1.1+ , heist >= 0.14+ , jmacro >= 0.6+ , lens < 6+ , mtl >= 2.0+ , pcre-light >= 0.4+ , readable >= 0.1+ , safe >= 0.3+ , snap >= 0.9+ , snap-core >= 0.9+ , text >= 0.11+ , time >= 1.4+ , transformers >= 0.2+ , wl-pprint-text >= 1.1+ , xmlhtml >= 0.1.6+ , map-syntax+ 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+ , map-syntax++ Default-Language: Haskell2010+++Test-Suite test+ Type: exitcode-stdio-1.0+ Main-Is: Main.hs+ Ghc-Options: -threaded -rtsopts -O0+ Default-Language: Haskell2010+ Other-Modules:+ Snap.Extras.Tests.Arbitrary+ Snap.Extras.Tests.MethodOverride+ Hs-Source-Dirs:+ test/src+ Build-Depends:+ base+ , bytestring+ , containers+ , snap-core+ , snap-extras+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , QuickCheck++source-repository head+ type: git+ location: https://github.com/ozataman/snap-extras.git+
src/Snap/Extras.hs view
@@ -2,17 +2,20 @@ 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 Data.Monoid+import Control.Lens+import Data.Monoid (mempty) import Heist import Snap.Snaplet import Snap.Snaplet.Heist@@ -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
@@ -25,10 +25,10 @@ ------------------------------------------------------------------------------- import Blaze.ByteString.Builder-import Control.Applicative+import Control.Applicative as A 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') @@ -100,7 +100,7 @@ respond :: MonadSnap m => (ResponseType -> m b) -> m b respond f = do hs <- maybeBadReq "Accept header required for this handler" $- getHeader "accept" <$> getRequest+ getHeader "accept" A.<$> getRequest if B.isInfixOf "application/javascript" hs then f Ajax else f Html
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,20 @@ ) where -------------------------------------------------------------------------------+import Control.Lens import Control.Monad import Control.Monad.Trans+import qualified Data.Map.Syntax as MS import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T+import Data.Monoid (mempty)+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 +34,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 }+ let splices = ("flash" MS.## flashSplice session)+ csplices = ("flash" MS.## flashCSplice session)+ addConfig h $ mempty & scCompiledSplices .~ csplices+ & scInterpretedSplices .~ splices ------------------------------------------------------------------------------- -- | Display an info message on next load of a page@@ -76,13 +78,13 @@ 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 callTemplateWithText "_flash" $ do- "type" ## typ'- "message" ## msg'+ "type" MS.## typ'+ "message" MS.## msg' -------------------------------------------------------------------------------@@ -97,11 +99,11 @@ k = T.concat ["_", typ] getVal = lift $ withTop session $ getFromSession k ss = do- "type" ## return $ C.yieldPureText typ- "message" ## return $ C.yieldRuntimeText+ "type" MS.## return $ C.yieldPureText typ+ "message" MS.## 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 +114,3 @@ deleteFromSession k commitSession return res--
src/Snap/Extras/FormUtils.hs view
@@ -23,16 +23,18 @@ ) where --------------------------------------------------------------------------------import Control.Error-import qualified Data.ByteString.Char8 as B+import Control.Monad.Trans.Maybe+import qualified Data.ByteString.Char8 as B+import Data.Maybe import Data.String-import Data.Text (Text)+import Data.Text (Text)+import qualified Data.Text as T import Data.Text.Encoding-import qualified Data.Text as T import Heist+import Safe import Snap.Core-import Text.Digestive-import qualified Text.XmlHtml as X+import Text.Digestive as DF+import qualified Text.XmlHtml as X ------------------------------------------------------------------------------- @@ -48,7 +50,7 @@ => a -> Result v (Maybe a) maybeTrans x = f x where f "" = Success Nothing- f a = Success $ Just a+ f a = Success $ Just a -------------------------------------------------------------------------------@@ -64,7 +66,7 @@ readTrans :: (Read a, IsString v) => Text -> Result v a-readTrans a = maybe (Error "Unrecognized input") Success $ readMay . T.unpack $ a+readTrans a = maybe (DF.Error "Unrecognized input") Success $ readMay . T.unpack $ a
src/Snap/Extras/JSON.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Snap.Extras.JSON- ( + ( -- * Parsing JSON from Request Body getBoundedJSON , getJSON@@ -13,8 +13,8 @@ -- * Sending JSON Data , writeJSON ) where- + ------------------------------------------------------------------------------- import Data.Aeson as A import qualified Data.ByteString.Char8 as B@@ -37,7 +37,7 @@ -- | Demand the presence of JSON in the body with a size up to N -- bytes. If parsing fails for any reson, request is terminated early -- and a server error is returned.-reqBoundedJSON +reqBoundedJSON :: (MonadSnap m, FromJSON a) => Int64 -- ^ Maximum size in bytes@@ -58,13 +58,13 @@ ------------------------------------------------------------------------------- -- | Parse request body into JSON or return an error string.-getBoundedJSON - :: (MonadSnap m, FromJSON a) - => Int64 +getBoundedJSON+ :: (MonadSnap m, FromJSON a)+ => Int64 -- ^ Maximum size in bytes -> m (Either String a) getBoundedJSON n = do- bodyVal <- A.decode `fmap` readRequestBody n+ bodyVal <- A.decode `fmap` readRequestBody (fromIntegral n) return $ case bodyVal of Nothing -> Left "Can't find JSON data in POST body" Just v -> case A.fromJSON v of@@ -74,7 +74,7 @@ ------------------------------------------------------------------------------- -- | Get JSON data from the given Param field-getJSONField +getJSONField :: (MonadSnap m, FromJSON a) => B.ByteString -> m (Either String a)@@ -85,7 +85,7 @@ Just val' -> case A.decode (LB.fromChunks . return $ val') of Nothing -> Left $ "Can't decode JSON data in field " ++ B.unpack fld- Just v -> + Just v -> case A.fromJSON v of A.Error e -> Left e A.Success a -> Right a@@ -93,7 +93,7 @@ ------------------------------------------------------------------------------- -- | Force the JSON value from field. Similar to 'getJSONField'-reqJSONField +reqJSONField :: (MonadSnap m, FromJSON a) => B.ByteString -> m a
+ src/Snap/Extras/MethodOverride.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Extras.MethodOverride+ ( handleMethodOverride+ , handleMethodOverride'+ ) where++-------------------------------------------------------------------------------+import Control.Applicative as A+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 A.<$> (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,21 +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 qualified Data.Map.Syntax as MS import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text.Encoding as T+import Data.Monoid (mempty)+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--+import Control.Monad ------------------------------------------------------------------------------- data NavTrail b = NavTrail {@@ -127,13 +128,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" MS.## focusCSplice lens+ "linkToBack" MS.## backCSplice+ interpretedSplices lens = do+ "linkToFocus" MS.## focusSplice lens+ "linkToBack" MS.## 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" MS.## 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 qualified Blaze.ByteString.Builder.Char8 as BB+import Control.Applicative as A+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Data.ByteString (ByteString)+import qualified Data.Map.Syntax as MS+import Data.Maybe+import Data.Monoid (mempty)+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.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" MS.## pureSplice internalUpdate+ MS.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 $ Prelude.show $ renderOneLine $ renderJs $+ [jmacro|+ setTimeout(function() {+ $.get(`(T.unpack url)`);+ }, `(Prelude.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 . Prelude.show+++------------------------------------------------------------------------------+-- | The status splices+statusSplices+ :: Monad n+ => Splices (RuntimeSplice n Status -> Splice n)+statusSplices = do+ "ifPending" MS.## ifCSplice ((==Pending) . statusJobState)+ "ifRunning" MS.## ifCSplice ((==Running) . statusJobState)+ "ifNotFinished" MS.## ifCSplice (not . statusFinished)+ "ifFinished" MS.## ifCSplice (statusFinished)+ "ifFinishedSuccess" MS.## ifCSplice ((==FinishedSuccess) . statusJobState)+ "ifFinishedFailure" MS.## ifCSplice ((==FinishedFailure) . statusJobState)+ "messages" MS.## manyWithSplices runChildren+ ("msgText" MS.## pureSplice (textSplice id)) .+ (liftM $ statusMessages)+ MS.mapV pureSplice $ do+ "startTime" MS.## textSplice (tshow . statusStartTime)+ "endTime" MS.## textSplice (tshow . statusTimestamp)+ "jobState" MS.## textSplice (tshow . statusJobState )+ "percentCompleted" MS.## textSplice (tshow . statusPercentCompleted)+ "amountCompleted" MS.## textSplice (tshow . statusAmountCompleted)+ "amountTotal" MS.## textSplice (tshow . statusAmountTotal)+++------------------------------------------------------------------------------+statusElapsed :: Status -> Maybe Int+statusElapsed Status{..} =+ round . diffUTCTime statusTimestamp A.<$> statusStartTime++
src/Snap/Extras/SpliceUtils/Common.hs view
@@ -1,17 +1,19 @@ 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
@@ -12,14 +12,15 @@ import Blaze.ByteString.Builder.ByteString import Control.Monad import Control.Monad.Trans+import qualified Data.Map.Syntax as MS import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Snap.Core-import qualified Snap.Extras.SpliceUtils.Interpreted as I+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Heist import Heist.Compiled import Heist.Compiled.LowLevel+import Snap.Core+import qualified Snap.Extras.SpliceUtils.Interpreted as I import Text.XmlHtml import Text.XmlHtml.Cursor -------------------------------------------------------------------------------@@ -27,8 +28,8 @@ utilSplices :: MonadSnap m => Splices (Splice m) utilSplices = do- "rqparam" ## paramSplice- "refererLink" ## refererCSplice+ "rqparam" MS.## paramSplice+ "refererLink" MS.## refererCSplice refererCSplice :: MonadSnap m => Splice m@@ -98,16 +99,16 @@ p <- newEmptyPromise let splices' = do- mapS ($ getPromise p) splices- "prelude" ## return mempty- "interlude" ## return mempty- "postlude" ## return mempty+ MS.mapV ($ getPromise p) splices+ "prelude" MS.## return mempty+ "interlude" MS.## return mempty+ "postlude" MS.## return mempty preChunks <- findNamedChild n "prelude" 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.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 Control.Monad.Trans+import qualified Data.Configurator as C+import qualified Data.Map.Syntax as MS+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 ------------------------------------------------------------------------------- @@ -32,8 +33,8 @@ -- | A list of splices offered in this module utilSplices :: Splices (SnapletISplice b) utilSplices = do- "rqparam" ## paramSplice- "refererLink" ## refererSplice+ "rqparam" MS.## paramSplice+ "refererLink" MS.## refererSplice refererSplice :: MonadSnap m => Splice m@@ -50,7 +51,7 @@ at <- liftM (getAttribute "name") getParamNode val <- case at of Just at' -> lift . getParam $ T.encodeUtf8 at'- Nothing -> return Nothing+ Nothing -> return Nothing return $ maybe [] ((:[]) . TextNode . T.decodeUtf8) val @@ -63,11 +64,13 @@ -- -- > heistLocal runTextAreas $ render "joo/index" runTextAreas :: Monad m => HeistState m -> HeistState m-runTextAreas = bindSplices ("textarea" ## ta)+runTextAreas = bindSplices ("textarea" MS.## ta) where ta = do hs <- getHS- n@(Element t ats _) <- getParamNode+ n <- getParamNode+ -- TODO Incomplete pattern matching.+ let (Element t ats _) = n let nm = nodeText n case lookupSplice nm hs of Just spl -> do@@ -91,16 +94,16 @@ -> Splice m selectSplice nm fid xs defv = callTemplate "_select" $ do- "options" ## opts- "name" ## textSplice nm- "id" ## textSplice fid+ "options" MS.## opts+ "name" MS.## textSplice nm+ "id" MS.## textSplice fid where opts = mapSplices gen xs gen (val,txt) = runChildrenWith $ do- "val" ## textSplice val- "text" ## textSplice txt- "ifSelected" ## ifISplice $ maybe False (== val) defv- "ifNotSelected" ## ifISplice $ maybe True (/= val) defv+ "val" MS.## textSplice val+ "text" MS.## textSplice txt+ "ifSelected" MS.## ifISplice $ maybe False (== val) defv+ "ifNotSelected" MS.## ifISplice $ maybe True (/= val) defv ------------------------------------------------------------------------------@@ -145,7 +148,9 @@ -- > beta-functions-enabled = true ifFlagSplice :: SnapletISplice b ifFlagSplice = do- Element _ ats es <- getParamNode+ e <- getParamNode+ -- TODO Incomplete pattern matching!+ let (Element _ ats es) = e conf <- lift getSnapletUserConfig case lookup "ref" ats of Nothing -> return []
src/Snap/Extras/Tabs.hs view
@@ -22,11 +22,12 @@ ------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as B-import Control.Error+import Control.Lens import Control.Monad import Control.Monad.Trans--import Data.Monoid+import qualified Data.Map.Syntax as MS+import Data.Maybe+import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -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 -------------------------------------------------------------------------------@@ -45,10 +47,10 @@ ------------------------------------------------------------------------------- initTabs :: HasHeist b => Snaplet (Heist b) -> Initializer b v () initTabs h = do- let splices = ("tabs" ## tabsSplice)- csplices = ("tabs" ## tabsCSplice)- addConfig h $ mempty { hcCompiledSplices = csplices- , hcInterpretedSplices = splices }+ let splices = ("tabs" MS.## tabsSplice)+ csplices = ("tabs" MS.## tabsCSplice)+ addConfig h $ mempty & scCompiledSplices .~ csplices+ & scInterpretedSplices .~ splices -------------------@@ -62,9 +64,9 @@ tabsCSplice = do n <- getParamNode let getCtx = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest- splices = ("tab" ## tabCSplice getCtx)+ splices = ("tab" MS.## 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" @@ -74,7 +76,9 @@ -- attributes in order to get ${} splice substitution. tabCSplice :: Monad m => RuntimeSplice m Text -> C.Splice m tabCSplice getCtx = do- (Element _ attrs ch) <- getParamNode+ e <- getParamNode+ -- TODO Incomplete pattern matching!+ let (Element _ attrs ch) = e attrsAction <- C.runAttributesRaw attrs nodes <- C.codeGen `fmap` C.runNodeList ch let ps as context = do@@ -84,6 +88,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 +101,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')@@ -129,7 +141,7 @@ tabsSplice :: MonadSnap m => Splice m tabsSplice = do context <- lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest- let bind = bindSplices ("tab" ## tabSplice context)+ let bind = bindSplices ("tab" MS.## tabSplice context) n <- getParamNode case n of Element _ attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch]@@ -209,18 +221,23 @@ tab url text attr md context = X.Element "li" attr' [tlink url text] where cur = case md of- TAMExactMatch -> url == context+ TAMExactMatch -> url == context TAMPrefixMatch -> url `T.isPrefixOf` context- TAMInfixMatch -> url `T.isInfixOf` context- TAMDontMatch -> False+ TAMInfixMatch -> url `T.isInfixOf` context+ TAMDontMatch -> False attr' = if cur then ("class", klass) : attr else attr klass = case lookup "class" attr of- Just k -> T.concat [k, " ", "active"]+ Just k -> T.concat [k, " ", "active"] Nothing -> "active" ------------------------------------------------------------------------------- tlink :: Text -> Text -> Node tlink target text = X.Element "a" [("href", target)] [X.TextNode text]++-------------------------------------------------------------------------------++note :: a -> Maybe b -> Either a b+note a = maybe (Left a) Right
+ 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+ ]
+ test/src/Snap/Extras/Tests/Arbitrary.hs view
@@ -0,0 +1,29 @@+module Snap.Extras.Tests.Arbitrary where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Char+import Data.ByteString.Char8 (ByteString, pack)+import Snap.Core+-------------------------------------------------------------------------------+import Test.QuickCheck+-------------------------------------------------------------------------------+++instance Arbitrary Method where+ arbitrary = oneof [ pure HEAD+ , pure POST+ , pure PUT+ , pure DELETE+ , pure TRACE+ , pure OPTIONS+ , pure CONNECT+ , pure PATCH+ , Method <$> (pack <$> cleanString)+ ]+ where+ cleanString = do+ NonEmpty s <- arbitrary+ return s++
+ test/src/Snap/Extras/Tests/MethodOverride.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+module Snap.Extras.Tests.MethodOverride+ ( methodOverrideTests+ ) where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Char+import qualified Data.Map as M+import Test.QuickCheck+import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.QuickCheck+-------------------------------------------------------------------------------+import Snap.Core+import Snap.Extras.MethodOverride+import Snap.Extras.Tests.Arbitrary ()+import Snap.Extras.TextUtils+import Snap.Test+-------------------------------------------------------------------------------++methodOverrideTests = testGroup "Snap.Extras.MethodOverride"+ [ testProperty "leaves method alone with no override" $ \meth ->+ monadicIO $ assertOverride meth meth Nothing+ , testProperty "leaves non-POST alone even with override" $ \(NonPost meth) override ->+ monadicIO $ assertOverride meth meth (Just $ showMethod override)+ , testProperty "leaves non-POST alone even with override and lowercased param" $ \(NonPost meth) override ->+ monadicIO $ assertOverride meth meth (Just $ showDCMethod override)+ , testProperty "overrides POST" $ \meth ->+ monadicIO $ assertOverride meth POST (Just $ showMethod meth)+ , testProperty "overrides POST with lowercased method" $ \meth ->+ monadicIO $ assertOverride (lowerMeth meth) POST (Just $ showDCMethod meth)+ ]+++-------------------------------------------------------------------------------+newtype NonPost = NonPost Method deriving (Show)++instance Arbitrary NonPost where+ arbitrary = NonPost <$> (arbitrary `suchThat` notPost)+ where+ notPost (POST) = False+ notPost _ = True++-------------------------------------------------------------------------------+showDCMethod = B.map toLower . showMethod++-------------------------------------------------------------------------------+showMethod :: Method -> ByteString+showMethod (Method m) = m+showMethod m = showBS m+++-------------------------------------------------------------------------------+lowerMeth (Method m) = Method (B.map toLower m)+lowerMeth m = m+++-------------------------------------------------------------------------------+assertOverride expectedMeth givenMeth override = do+ actualMeth <- run $ evalHandler builder app+ assert $ expectedMeth == actualMeth+ where+ builder = do+ setRequestType $ RequestWithRawBody givenMeth ""+ case override of+ Just m -> setQueryString $ M.singleton "_method" [m]+ _ -> return ()+++-------------------------------------------------------------------------------+app = handleMethodOverride (getsRequest rqMethod)+