diff --git a/snap-extras.cabal b/snap-extras.cabal index 00eeeae..1bd82c0 100644 --- a/snap-extras.cabal +++ b/snap-extras.cabal @@ -1,5 +1,5 @@ Name: snap-extras -Version: 0.12.2.0 +Version: 0.12.2.1 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 @@ -48,34 +48,34 @@ Library hs-source-dirs: src Build-depends: - aeson >= 0.6 && < 1.3 - , base >= 4 && < 5 - , blaze-builder >= 0.3 && < 0.5 - , blaze-html >= 0.6 && < 0.10 - , bytestring >= 0.9.1 && < 0.11 - , case-insensitive >= 1.0 && < 1.3 - , configurator >= 0.2 && < 0.4 - , containers >= 0.3 && < 0.6 - , data-default >= 0.5 && < 0.8 - , digestive-functors >= 0.3 && < 0.9 - , digestive-functors-heist >= 0.8 && < 0.9 - , digestive-functors-snap >= 0.3 && < 0.8 - , directory-tree >= 0.10 && < 0.13 - , filepath >= 1.1 && < 1.5 - , heist >= 0.14 && < 1.1 - , jmacro >= 0.6 && < 0.7 + aeson >= 0.6 + , base >= 4 + , 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 < 5 - , mtl >= 2.0 && < 2.3 - , pcre-light >= 0.4 && < 0.5 - , readable >= 0.1 && < 0.4 - , safe >= 0.3 && < 0.4 - , snap >= 0.9 && < 1.1 - , snap-core >= 0.9 && < 1.1 - , text >= 0.11 && < 1.3 - , time >= 1.4 && < 1.9 - , transformers >= 0.2 && < 0.6 - , wl-pprint-text >= 1.1 && < 1.2 - , xmlhtml >= 0.1.6 && < 0.3 + , 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 diff --git a/src/Snap/Extras/Ajax.hs b/src/Snap/Extras/Ajax.hs index f2be440..eb1df55 100644 --- a/src/Snap/Extras/Ajax.hs +++ b/src/Snap/Extras/Ajax.hs @@ -17,30 +17,41 @@ module Snap.Extras.Ajax ( replaceWith , replaceWithTemplate + , replaceWithTemplateWithSplices + , jmacroToByteString , ResponseType (..) , respond , responds , htmlOrAjax + , respondAjax ) where ------------------------------------------------------------------------------- import Blaze.ByteString.Builder -import Control.Applicative as A -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Text (Text) -import qualified Data.Text as T +import Control.Monad +import Control.Applicative as A +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Heist.Compiled +import qualified Heist.Interpreted as I +import Heist.Splices +import Heist import Language.Javascript.JMacro import Safe import Snap.Core import Snap.Extras.CoreUtils import Snap.Snaplet import Snap.Snaplet.Heist +import qualified Text.PrettyPrint.Leijen.Text as PP +import qualified Text.XmlHtml as H ------------------------------------------------------------------------------- --- | Replace innerHTML of given selector with given conntent. +-- | Replace innerHTML of given selector with given content. replaceWith :: MonadSnap m => Text @@ -48,22 +59,23 @@ replaceWith -> ByteString -- ^ content blob -> m () -replaceWith selector bs = do - let bs' = B.unpack bs - sel = T.unpack selector +replaceWith sel bs = do jsResponse - writeBS $ B.pack $ show . renderJs $ replaceWithJs bs' sel + writeBS $ jmacroToByteString $ replaceWithJs bs sel -- | Produce JS statement to replace a target's inner with given -- contents. -replaceWithJs :: String -> String -> JStat +replaceWithJs :: ByteString -> Text -> JStat replaceWithJs bs sel = [jmacro| - var contents = `(bs)`; + var contents = `(T.decodeUtf8 bs)`; var replaceJs = function() { $(`(sel)`).html(contents); }; replaceJs(); |] +-- | Converts JMacro-generated Javascript code to a @ByteString@. +jmacroToByteString :: JStat -> ByteString +jmacroToByteString = T.encodeUtf8 . PP.displayTStrict . PP.renderCompact . renderJs ------------------------------------------------------------------------------- -- | Replace the inner HTML element of a given selector with the @@ -84,7 +96,24 @@ replaceWithTemplate nm sel = do bld' <- withTop' id bld replaceWith sel (toByteString bld') - +-- | Same as @replaceWithTemplate@, but takes additional splices to render the template. +replaceWithTemplateWithSplices + :: HasHeist b + => Splices (I.Splice (Handler b b)) + -- ^ bound splices + -> ByteString + -- ^ Heist template name + -> Text + -- ^ jQuery selector for target element on page + -> Handler b v () +replaceWithTemplateWithSplices splices nm sel = do + doc <- withHeistState $ \ hs -> do + mb <- I.renderTemplateToDoc (I.bindSplices splices hs) nm + case mb of + Nothing -> badReq "Could not render a response." + Just doc -> return doc + bs' <- liftM (BL.toStrict . toLazyByteString . H.renderHtmlFragment H.UTF8 . H.docContent) $ withTop' id doc + replaceWith sel bs' ------------------------------------------------------------------------------- -- | Possible reponse types we support at the moment. Can be expanded @@ -124,4 +153,6 @@ htmlOrAjax f g = respond $ \ ty -> case ty of Html -> f Ajax -> g - +-- | Responding only to AJAX requests. +respondAjax :: MonadSnap m => m () -> m () +respondAjax = htmlOrAjax pass diff --git a/src/Snap/Extras/JSON.hs b/src/Snap/Extras/JSON.hs index 1d712dd..069aea1 100644 --- a/src/Snap/Extras/JSON.hs +++ b/src/Snap/Extras/JSON.hs @@ -4,8 +4,8 @@ module Snap.Extras.JSON ( -- * Parsing JSON from Request Body - getBoundedJSON - , getJSON + getBoundedJSON,getBoundedJSON' + , getJSON,getJSON' , reqBoundedJSON , reqJSON , getJSONField @@ -55,6 +55,11 @@ reqBoundedJSON n = do getJSON :: (MonadSnap m, A.FromJSON a) => m (Either String a) getJSON = getBoundedJSON 50000 +------------------------------------------------------------------------------- +-- | Try to parse request body as a generic JSON @Object@ with a default max size of +-- 50000. +getJSON' :: (MonadSnap m) => m (Either String Object) +getJSON' = getBoundedJSON' 50000 ------------------------------------------------------------------------------- -- | Parse request body into JSON or return an error string. @@ -71,6 +76,19 @@ getBoundedJSON n = do A.Error e -> Left e A.Success a -> Right a +------------------------------------------------------------------------------- +-- | Parse request body into a generic JSON @Object@ or return an error string. +getBoundedJSON' + :: (MonadSnap m) + => Int64 + -- ^ Maximum size in bytes + -> m (Either String Object) +getBoundedJSON' n = do + bodyVal <- A.decode `fmap` readRequestBody (fromIntegral n) + return $ case bodyVal of + Nothing -> Left $ "Can't find JSON data in POST body" + Just v -> Right v + ------------------------------------------------------------------------------- -- | Get JSON data from the given Param field diff --git a/src/Snap/Extras/SpliceUtils/Interpreted.hs b/src/Snap/Extras/SpliceUtils/Interpreted.hs index 8902624..0a7c626 100644 --- a/src/Snap/Extras/SpliceUtils/Interpreted.hs +++ b/src/Snap/Extras/SpliceUtils/Interpreted.hs @@ -14,6 +14,7 @@ module Snap.Extras.SpliceUtils.Interpreted ------------------------------------------------------------------------------- import Control.Monad import Control.Monad.Trans +import Control.Monad.Fail import qualified Data.Configurator as C import qualified Data.Map.Syntax as MS import Data.Text (Text) @@ -63,7 +64,7 @@ paramSplice = do -- by putting the name of a splice as the value of a textarea tag. -- -- > heistLocal runTextAreas $ render "joo/index" -runTextAreas :: Monad m => HeistState m -> HeistState m +runTextAreas :: (MonadFail m) => HeistState m -> HeistState m runTextAreas = bindSplices ("textarea" MS.## ta) where ta = do