snap-extras 0.7 → 0.9
raw patch · 5 files changed
+235/−32 lines, 5 filesdep +jmacrodep ~aesondep ~blaze-htmldep ~digestive-functors
Dependencies added: jmacro
Dependency ranges changed: aeson, blaze-html, digestive-functors, readable, text
Files
- snap-extras.cabal +10/−10
- src/Snap/Extras.hs +9/−7
- src/Snap/Extras/Ajax.hs +127/−0
- src/Snap/Extras/SpliceUtils/Compiled.hs +68/−1
- src/Snap/Extras/Tabs.hs +21/−14
snap-extras.cabal view
@@ -1,5 +1,5 @@ Name: snap-extras-Version: 0.7+Version: 0.9 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@@ -12,16 +12,16 @@ Maintainer: oz@soostone.com Category: Web, Snap Build-type: Simple-Cabal-version: >= 1.6+Cabal-version: >= 1.10 data-files: resources/templates/*.tpl Library- -- Modules exported by the library. Exposed-modules: Snap.Extras+ Snap.Extras.Ajax Snap.Extras.CoreUtils Snap.Extras.CSRF Snap.Extras.TextUtils@@ -38,15 +38,15 @@ hs-source-dirs: src Build-depends:- aeson >= 0.6 && < 0.7+ aeson >= 0.6 && < 0.8 , base >= 4 && < 5 , blaze-builder >= 0.3 && < 0.4- , blaze-html >= 0.6 && < 0.7+ , 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.7+ , 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@@ -54,15 +54,15 @@ , filepath >= 1.1 && < 1.4 , heist >= 0.13 && < 0.14 , mtl >= 2.0 && < 2.2- , readable >= 0.1 && < 0.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 && < 0.12+ , text >= 0.11 && < 1.2 , transformers >= 0.2 && < 0.4 , xmlhtml >= 0.1.6 && < 0.3+ , jmacro >= 0.6 && < 0.7 - -- Other-modules: - ghc-options: -Wall -fwarn-tabs+ default-language: Haskell2010
src/Snap/Extras.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Snap.Extras- ( module Snap.Extras.CoreUtils+ ( module Snap.Extras.Ajax+ , module Snap.Extras.CoreUtils , module Snap.Extras.TextUtils , module Snap.Extras.JSON , module Snap.Extras.FlashNotice@@ -18,16 +19,17 @@ import Snap.Snaplet.Session import System.FilePath.Posix -------------------------------------------------------------------------------+import Snap.Extras.Ajax import Snap.Extras.CoreUtils import Snap.Extras.FlashNotice import Snap.Extras.FormUtils import Snap.Extras.JSON-import qualified Snap.Extras.SpliceUtils.Compiled as C+import qualified Snap.Extras.SpliceUtils.Compiled as C import qualified Snap.Extras.SpliceUtils.Interpreted as I import Snap.Extras.Tabs import Snap.Extras.TextUtils --------------------------------------------------------------------------------import Paths_snap_extras+import Paths_snap_extras ------------------------------------------------------------------------------- @@ -38,10 +40,10 @@ => Snaplet (Heist b) -> SnapletLens b SessionManager -> SnapletInit b ()-initExtras heistSnaplet session = - makeSnaplet - "Snap Extras" - "Collection of utilities for web applications" +initExtras heistSnaplet session =+ makeSnaplet+ "snap-extras"+ "Collection of utilities for web applications" (Just getDataDir) $ do addTemplatesAt heistSnaplet "" . (</> "resources/templates") =<< getSnapletFilePath
+ src/Snap/Extras/Ajax.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Snap.Extras.Ajax+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Ozgun Ataman+-- Stability : experimental+--+-- Simple combinators to work with AJAX requests.+----------------------------------------------------------------------------++module Snap.Extras.Ajax+ ( replaceWith+ , replaceWithTemplate+ , ResponseType (..)+ , respond+ , responds+ , htmlOrAjax+ ) where++-------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import Control.Applicative+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Text+import qualified Data.Text as T+import Heist.Compiled+import Language.Javascript.JMacro+import Safe+import Snap.Core+import Snap.Extras.CoreUtils+import Snap.Snaplet+import Snap.Snaplet.Heist+-------------------------------------------------------------------------------+++-- | Replace innerHTML of given selector with given conntent.+replaceWith+ :: MonadSnap m+ => Text+ -- ^ jquery selector+ -> ByteString+ -- ^ content blob+ -> m ()+replaceWith selector bs = do+ let bs' = B.unpack bs+ sel = T.unpack selector+ jsResponse+ writeBS $ B.pack $ show . renderJs $ replaceWithJs bs' sel+++-- | Produce JS statement to replace a target's inner with given+-- contents.+replaceWithJs :: String -> String -> JStat+replaceWithJs bs sel = [jmacro|+ var contents = `(bs)`;+ var replace = function() { $(`(sel)`).html(contents); };+ replace();+|]+++-------------------------------------------------------------------------------+-- | Replace the inner HTML element of a given selector with the+-- contents of the rendered Heist template.+--+-- Currently expect you to have jQuery loaded.+-- TODO: Make this jQuery independent+replaceWithTemplate+ :: HasHeist v+ => ByteString+ -- ^ Heist template name+ -> Text+ -- ^ jQuery selector for target element on page+ -> Handler v v ()+replaceWithTemplate nm sel = do+ (bld, _) <- maybeBadReq "Could not render a response." $+ withHeistState $ \ hs -> renderTemplate hs nm+ bld' <- bld+ replaceWith sel (toByteString bld')++++-------------------------------------------------------------------------------+-- | Possible reponse types we support at the moment. Can be expanded+-- for more use cases like JSON, CSV and XML.+data ResponseType = Html | Ajax+ deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | The multi-mime dispatcher. It will inspect the 'Accept' header+-- and determine what type of a request this is. If AJAX, make sure to+-- set the Accept header to 'application/javascript'.+respond :: MonadSnap m => (ResponseType -> m b) -> m b+respond f = do+ hs <- maybeBadReq "Accept header required for this handler" $+ getHeader "accept" <$> getRequest+ if B.isInfixOf "application/javascript" hs+ then f Ajax+ else f Html+++-- | Dispatch on all response types+responds :: MonadSnap m => [(ResponseType, m b)] -> m b+responds fs = respond $ \ ty -> fromJustNote ("Handler does not know how to respond to: " ++ show ty) (lookup ty fs)+++-- | Classic pattern of responding to a static HTML or an alternative+-- AJAX request.+htmlOrAjax+ :: MonadSnap m+ => m b+ -- ^ If call is HTML+ -> m b+ -- ^ If call is AJAX+ -> m b+htmlOrAjax f g = respond $ \ ty -> case ty of+ Html -> f+ Ajax -> g++
src/Snap/Extras/SpliceUtils/Compiled.hs view
@@ -1,9 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -module Snap.Extras.SpliceUtils.Compiled where+module Snap.Extras.SpliceUtils.Compiled+ ( utilSplices+ , refererCSplice+ , paramSplice+ , scriptsSplice+ , fancyLoopSplice+ ) where ------------------------------------------------------------------------------- import Blaze.ByteString.Builder.ByteString+import Control.Monad import Control.Monad.Trans import Data.Monoid import qualified Data.Text as T@@ -12,7 +19,9 @@ import qualified Snap.Extras.SpliceUtils.Interpreted as I import Heist import Heist.Compiled+import Heist.Compiled.LowLevel import Text.XmlHtml+import Text.XmlHtml.Cursor ------------------------------------------------------------------------------- @@ -63,4 +72,62 @@ -> Splice m scriptsSplice d prefix = runNodeList =<< I.scriptsSplice d prefix ++------------------------------------------------------------------------------+-- | Sometimes in a loop you don't always want the same behavior for every+-- item. If you have a comma separated list, you usually don't want a comma+-- after the last item. If you have a list surrounded by parentheses, you+-- might not want the parentheses to show up if the list is empty. Dealing+-- with these situations can be a pain with the stock looping splices, so+-- we've provided this helper that solves all of these problems.+--+-- This function is similar to manyWithSplices, but it binds three additional+-- splices: \"prelude\", \"interlude\", and \"postlude\". The children of+-- the prelude and postlude splices only show up before the beginning of the+-- list and after the end of the list if the list is non-empty. The+-- children of the interlude splice are used as a separator between each list+-- element. If the list has only one element, then the separator does not+-- appear. These splices have this behavior regardless of where they appear+-- in the parent tag.+fancyLoopSplice :: Monad n+ => Splices (RuntimeSplice n a -> Splice n)+ -> RuntimeSplice n [a]+ -> Splice n+fancyLoopSplice splices action = do+ n <- getParamNode+ p <- newEmptyPromise++ let splices' = do+ mapS ($ getPromise p) splices+ "prelude" ## return mempty+ "interlude" ## return mempty+ "postlude" ## return mempty++ preChunks <- findNamedChild n "prelude"+ interChunks <- findNamedChild n "interlude"+ postChunks <- findNamedChild n "postlude"++ itemChunks <- withLocalSplices splices' noSplices runChildren+ return $ yieldRuntime $ do+ items <- action+ case items of+ [] -> return mempty+ (i:is) -> do+ pre <- codeGen preChunks+ post <- codeGen postChunks++ front <- putPromise p i >> codeGen itemChunks+ body <- forM is $ \item -> do+ putPromise p item+ inter <- codeGen interChunks+ res <- codeGen itemChunks+ return $ inter <> res++ return $ pre <> front <> mconcat body <> post+++findNamedChild :: Monad n => Node -> T.Text -> Splice n+findNamedChild node name =+ maybe (return mempty) (runNodeList . childNodes . current) $+ findChild (\c -> tagName (current c) == Just name) $ fromNode node
src/Snap/Extras/Tabs.hs view
@@ -21,21 +21,23 @@ ) where -------------------------------------------------------------------------------+import qualified Blaze.ByteString.Builder as B import Control.Error import Control.Monad import Control.Monad.Trans+ import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import Data.Text (Text)+import qualified Data.Text as T+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 Heist-import qualified Heist.Compiled as C-import Heist.Interpreted import Text.XmlHtml-import qualified Text.XmlHtml as X+import qualified Text.XmlHtml as X ------------------------------------------------------------------------------- @@ -74,6 +76,7 @@ tabCSplice getCtx = do (Element _ attrs ch) <- getParamNode attrsAction <- C.runAttributesRaw attrs+ nodes <- C.codeGen `fmap` C.runNodeList ch let ps as context = do m <- note "tab must specify a 'match' attribute" $ lookup "match" as url <- note "tabs must specify a 'url' attribute" $ lookup "url" as@@ -83,16 +86,20 @@ "Infix" -> Right $ url `T.isInfixOf` context "None" -> Right $ False _ -> Left "Unknown match type"- return (url, ch, m')+ return (url, m') return $ C.yieldRuntime $ do ctx <- getCtx as <- attrsAction- let res = case ps as ctx of- Left e -> error $ "Tab error: " ++ e- Right (url, c, match) ->- let attr' = if match then ("class", "active") : as else as- a = X.Element "a" (("href", url) : as) c- in X.renderHtmlFragment X.UTF8 [X.Element "li" attr' [a]]+ ns <- nodes+ let innerFrag = X.parseHTML "inner" $ B.toByteString ns+ let res = either (error . ("Tab errror: " ++) ) id $ do+ (url, match) <- ps as ctx+ inner <- innerFrag++ let actClass = maybe "active" (T.append "active " ) $ lookup "class" as+ attr' = if match 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