{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Snap.Extras.Ajax
( replaceWith
, replaceWithTemplate
, ResponseType (..)
, respond
, responds
, htmlOrAjax
) 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 Heist.Compiled
import Language.Javascript.JMacro
import Safe
import Snap.Core
import Snap.Extras.CoreUtils
import Snap.Snaplet
import Snap.Snaplet.Heist
replaceWith
:: MonadSnap m
=> Text
-> ByteString
-> m ()
replaceWith selector bs = do
let bs' = B.unpack bs
sel = T.unpack selector
jsResponse
writeBS $ B.pack $ show . renderJs $ replaceWithJs bs' sel
replaceWithJs :: String -> String -> JStat
replaceWithJs bs sel = [jmacro|
var contents = `(bs)`;
var replaceJs = function() { $(`(sel)`).html(contents); };
replaceJs();
|]
replaceWithTemplate
:: HasHeist b
=> ByteString
-> Text
-> Handler b v ()
replaceWithTemplate nm sel = do
(bld, _) <- maybeBadReq "Could not render a response." $
withHeistState $ \ hs -> renderTemplate hs nm
bld' <- withTop' id bld
replaceWith sel (toByteString bld')
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" A.<$> getRequest
if B.isInfixOf "application/javascript" hs
then f Ajax
else f Html
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)
htmlOrAjax
:: MonadSnap m
=> m b
-> m b
-> m b
htmlOrAjax f g = respond $ \ ty -> case ty of
Html -> f
Ajax -> g