Permalink
Browse files

New Ajax response functionality

  • Loading branch information...
1 parent 72ec2d1 commit 63a14fbee6353717e6507a917f71f26e9fef7e9c @ozataman committed Feb 8, 2014
Showing with 115 additions and 5 deletions.
  1. +4 −4 snap-extras.cabal
  2. +3 −1 src/Snap/Extras.hs
  3. +108 −0 src/Snap/Extras/Ajax.hs
View
8 snap-extras.cabal
@@ -1,5 +1,5 @@
Name: snap-extras
-Version: 0.8.1
+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
@@ -19,9 +19,9 @@ 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
@@ -61,8 +61,8 @@ Library
, text >= 0.11 && < 0.12
, 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
View
4 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,6 +19,7 @@ import Snap.Snaplet.Heist
import Snap.Snaplet.Session
import System.FilePath.Posix
-------------------------------------------------------------------------------
+import Snap.Extras.Ajax
import Snap.Extras.CoreUtils
import Snap.Extras.FlashNotice
import Snap.Extras.FormUtils
View
108 src/Snap/Extras/Ajax.hs
@@ -0,0 +1,108 @@
+{-# 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 :: Text -> ByteString -> JStat
+replaceWith selector bs =
+ let bs' = B.unpack bs
+ sel = T.unpack selector
+ in [$jmacro| $(`(sel)`).html(`(bs')`); |]
+
+
+
+-------------------------------------------------------------------------------
+-- | 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
+ let js = show . renderJs $ replaceWith sel (toByteString bld')
+ modifyResponse $ setHeader "Content-Type" "application/javascript"
+ writeBS $ B.pack js
+
+
+
+data ResponseType = Html | Ajax
+ deriving (Eq,Show,Read,Ord)
+
+
+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
+
+
+test = renderJs $ replaceWith "#listing" "<strong>This is great</strong>"
+

0 comments on commit 63a14fb

Please sign in to comment.