+>
+>
+
+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:
+
+>
Status
+>
+>
+>
+
+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 [""]
+ 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
+
+
diff --git a/src/Snap/Extras/SpliceUtils/Common.hs b/src/Snap/Extras/SpliceUtils/Common.hs
--- a/src/Snap/Extras/SpliceUtils/Common.hs
+++ b/src/Snap/Extras/SpliceUtils/Common.hs
@@ -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)
diff --git a/src/Snap/Extras/SpliceUtils/Compiled.hs b/src/Snap/Extras/SpliceUtils/Compiled.hs
--- a/src/Snap/Extras/SpliceUtils/Compiled.hs
+++ b/src/Snap/Extras/SpliceUtils/Compiled.hs
@@ -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
diff --git a/src/Snap/Extras/SpliceUtils/Interpreted.hs b/src/Snap/Extras/SpliceUtils/Interpreted.hs
--- a/src/Snap/Extras/SpliceUtils/Interpreted.hs
+++ b/src/Snap/Extras/SpliceUtils/Interpreted.hs
@@ -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 []
diff --git a/src/Snap/Extras/Tabs.hs b/src/Snap/Extras/Tabs.hs
--- a/src/Snap/Extras/Tabs.hs
+++ b/src/Snap/Extras/Tabs.hs
@@ -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
diff --git a/test/src/Main.hs b/test/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/src/Main.hs
@@ -0,0 +1,14 @@
+module Main
+ ( main
+ ) where
+
+-------------------------------------------------------------------------------
+import Test.Tasty
+-------------------------------------------------------------------------------
+import Snap.Extras.Tests.MethodOverride (methodOverrideTests)
+-------------------------------------------------------------------------------
+
+main = do
+ defaultMain $ testGroup "tests"
+ [ methodOverrideTests
+ ]
diff --git a/test/src/Snap/Extras/Tests/Arbitrary.hs b/test/src/Snap/Extras/Tests/Arbitrary.hs
new file mode 100644
--- /dev/null
+++ b/test/src/Snap/Extras/Tests/Arbitrary.hs
@@ -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
+
+
diff --git a/test/src/Snap/Extras/Tests/MethodOverride.hs b/test/src/Snap/Extras/Tests/MethodOverride.hs
new file mode 100644
--- /dev/null
+++ b/test/src/Snap/Extras/Tests/MethodOverride.hs
@@ -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)
+