diff --git a/snap-extras.cabal b/snap-extras.cabal --- a/snap-extras.cabal +++ b/snap-extras.cabal @@ -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 diff --git a/src/Snap/Extras.hs b/src/Snap/Extras.hs --- a/src/Snap/Extras.hs +++ b/src/Snap/Extras.hs @@ -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 diff --git a/src/Snap/Extras/Ajax.hs b/src/Snap/Extras/Ajax.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/Ajax.hs @@ -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 + + 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 @@ -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 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 @@ -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