diff --git a/README.md b/README.md index ecd1041..5a61aba 100644 --- a/README.md +++ b/README.md @@ -105,7 +105,7 @@ where they'll be served): ``` -Add the `` just before your site's body tag. +Add the `` just before your site's `` tag. Notes ----- diff --git a/snaplet-liftajax.cabal b/snaplet-liftajax.cabal index 240933f..ee2dd3c 100644 --- a/snaplet-liftajax.cabal +++ b/snaplet-liftajax.cabal @@ -28,6 +28,7 @@ Library Snap.Snaplet.LiftAjax.Js build-depends: + aeson >= 0.6 && < 0.7, base >= 4 && < 5, blaze-builder >= 0.3, bytestring >= 0.9.1 && < 0.10, @@ -46,6 +47,7 @@ Library pretty >= 1.1.1, prettyclass >= 1.0, resource-pool-catchio >= 0.2 && < 0.3, + safe >= 0.3 && < 0.4, snap >= 0.9 && < 0.10, snap-core == 0.9.*, stm >= 2.3, diff --git a/src/Snap/Snaplet/LiftAjax.hs b/src/Snap/Snaplet/LiftAjax.hs index 32fde4b..7843ce8 100644 --- a/src/Snap/Snaplet/LiftAjax.hs +++ b/src/Snap/Snaplet/LiftAjax.hs @@ -59,15 +59,15 @@ ajaxInit ajaxState = makeSnaplet "ajax" "" Nothing $ do routes :: HasHeist b => [(ByteString, AjaxHandler b ())] routes = [ ("/request/:pageId/", handleRequest) - , ("/gc", failIfNotLocal handleGC) - , ("/state", failIfNotLocal handleState) + , ("/gc", ifLocal handleGC) + , ("/state", ifLocal handleState) ] where - failIfNotLocal m = do + ifLocal m = do rip <- liftM rqRemoteAddr getRequest - if not $ elem rip [ "127.0.0.1" , "localhost" , "::1" ] - then pass - else m + if rip `elem` [ "127.0.0.1" , "localhost" , "::1" ] + then m + else pass splices :: [(Text, SnapletSplice b (Ajax b))] splices = [ ("ajaxFooter", footerSplice) ] diff --git a/src/Snap/Snaplet/LiftAjax/Js.hs b/src/Snap/Snaplet/LiftAjax/Js.hs index 0741b59..eeeb64f 100644 --- a/src/Snap/Snaplet/LiftAjax/Js.hs +++ b/src/Snap/Snaplet/LiftAjax/Js.hs @@ -32,7 +32,10 @@ showAsText :: (JsToDoc a, JMacro a) => a -> Text showAsText = T.pack . PP.renderStyle (PP.style { PP.mode = PP.OneLineMode }) . renderJs noop :: JStat -noop = [jmacro|$.noop();|]; +noop = [jmacro|$.noop();|] alert :: Text -> JStat -alert msg = [jmacro|alert(`(msg)`);|]; +alert msg = [jmacro|alert(`(msg)`);|] + +null :: JExpr +null = [jmacroE|null|] diff --git a/src/Snap/Snaplet/LiftAjax/Splice.hs b/src/Snap/Snaplet/LiftAjax/Splice.hs index c83aa29..f63d93c 100644 --- a/src/Snap/Snaplet/LiftAjax/Splice.hs +++ b/src/Snap/Snaplet/LiftAjax/Splice.hs @@ -2,17 +2,26 @@ {-# LANGUAGE QuasiQuotes #-} module Snap.Snaplet.LiftAjax.Splice - ( ajaxForm - , ajaxFormWithSplices ) where + ( ajaxFormWithHandler + , ajaxForm + , ajaxFormWithSplices + , ajaxButtonWithHandler + , ajaxButton + , ajaxButton_ + , ajaxJsonButton + ) where ------------------------------------------------------------------------------ import Control.Monad.Trans +import Data.Aeson import Data.Function (on) import Data.List (unionBy) import Data.Monoid +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB import Data.Text (Text) import Language.Javascript.JMacro -import Snap.Core +import Safe import Snap.Snaplet import Snap.Snaplet.LiftAjax.Callback import qualified Snap.Snaplet.LiftAjax.Js as Js @@ -23,65 +32,109 @@ import Text.Templating.Heist import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ +type FormHandler b v a = Either (View v) a -> Handler b b JStat + -- Does not override existing attributes addAttrs :: [(Text, Text)] -- ^ Original attributes -> [(Text, Text)] -- ^ Attributes to add -> [(Text, Text)] -- ^ Resulting attributes addAttrs = unionBy (on (==) fst) -handleForm :: MonadSnap m => - Text - -> Form v m a - -> (Either (View v) a -> m JStat) - -> m () -handleForm name form process = do - (view, result) <- runForm name form - process (maybe (Left view) Right result) >>= Js.write - -formWithHandler :: HasAjax b => - Handler b b () - -> Splice (Handler b b) -formWithHandler h = do - X.Element _ attrs cs <- getParamNode - formId <- lift $ withTop ajaxLens newRandomId - handlerId <- lift $ withTop ajaxLens $ addCallback h - children <- runNodeList cs - return $ formNodes formId handlerId attrs children +lazyFromStrict :: B.ByteString -> LB.ByteString +lazyFromStrict = LB.fromChunks . (:[]) + +ajaxCall :: JExpr -> JStat +ajaxCall e = [jmacro| liftAjax.lift_ajaxHandler(`(e)`, null, null, 'javascript'); + return false; |] -formNodes :: Text -> HandlerId -> [(Text, Text)] -> [X.Node] -> [X.Node] -formNodes formId hid attrs children = [form] +ajaxCallWithParams :: [(Text, JExpr)] -> JStat +ajaxCallWithParams ps = ajaxCall $ collect $ map pair ps where - hidden = X.Element "input" [ ("type", "hidden") - , ("name", hidAsText hid) - , ("id", hidAsText hid) + pair (a,b) = [jmacroE|`(a)`+"="+encodeURIComponent(`(b)`)|] + collect = foldl1Def Js.null (\x xs -> [jmacroE|`(x)`+"&"+`(xs)`|]) + +liftAjax :: HasAjax b => AjaxHandler b a -> HeistT (Handler b b) a +liftAjax = lift . withTop ajaxLens + +addAjaxCallback :: HasAjax b => Handler b b JStat -> HeistT (Handler b b) HandlerId +addAjaxCallback = liftAjax . addCallback . (>>= Js.write) + +ajaxFormWithHandler :: HasAjax b => + Handler b b JStat + -> Splice (Handler b b) +ajaxFormWithHandler h = do + X.Element _ attrs cs <- getParamNode + formId <- liftAjax newRandomId + handlerId <- addAjaxCallback h + children <- runNodeList cs + let hidden = X.Element "input" [ ("type", "hidden") + , ("name", hidAsText handlerId) + , ("id", hidAsText handlerId) ] [] form = X.Element "form" (addAttrs [ ("action", "javascript://") , ("onsubmit", Js.showAsText sendForm) , ("id", formId) ] attrs) (children ++ [hidden]) - sendForm = [jmacro| liftAjax.lift_ajaxHandler($(`("#"<>formId)`).serialize(), - null, - null, - 'javascript'); - return false; |] - -type FormHandler b v a = Either (View v) a -> Handler b b JStat + sendForm = ajaxCall [jmacroE|$(`("#"<>formId)`).serialize()|] + return [form] ajaxForm :: HasAjax b => Text -> Form v (Handler b b) a -> FormHandler b v a -> Splice (Handler b b) -ajaxForm n f p = formWithHandler $ handleForm n f p +ajaxForm name form process = + ajaxFormWithHandler $ do + (view, result) <- runForm name form + process (maybe (Left view) Right result) ajaxFormWithSplices :: HasAjax b => (View v -> [(Text, Splice (Handler b b))]) -> Form v (Handler b b) a - -> FormHandler b v a + -> FormHandler b v a -> Splice (Handler b b) ajaxFormWithSplices splices form process = do - name <- lift $ with ajaxLens newRandomId + name <- liftAjax newRandomId view <- lift $ getForm name form localTS (bindSplices $ splices view) $ ajaxForm name form process +ajaxButtonWithHandler :: HasAjax b => + [(Text, JExpr)] + -> Handler b b JStat + -> Splice (Handler b b) +ajaxButtonWithHandler jsParams h = do + X.Element _ attrs cs <- getParamNode + handlerId <- addAjaxCallback h + children <- runNodeList cs + let button = X.Element "button" (addAttrs [ ("onclick", Js.showAsText call) + ] attrs) children + call = ajaxCallWithParams $ [(hidAsText handlerId, Js.null)] ++ jsParams + return [button] + +ajaxButtonWithParser :: HasAjax b => + (B.ByteString -> Maybe a) + -> JExpr + -> (Maybe a -> Handler b b JStat) + -> Splice (Handler b b) +ajaxButtonWithParser parse jsExpr process = do + exprName <- liftAjax newRandomId + ajaxButtonWithHandler [(exprName, jsExpr)] $ do + expr <- getTextRqParam exprName + process $ expr >>= parse + +ajaxButton :: (HasAjax b, Read a) => + JExpr + -> (Maybe a -> Handler b b JStat) + -> Splice (Handler b b) +ajaxButton = ajaxButtonWithParser $ readMay . B.unpack + +ajaxJsonButton :: (HasAjax b, FromJSON a) => + JExpr + -> (Maybe a -> Handler b b JStat) + -> Splice (Handler b b) +ajaxJsonButton jsonExpr = ajaxButtonWithParser (decode . lazyFromStrict) + [jmacroE|JSON.stringify(`(jsonExpr)`)|] + +ajaxButton_ :: (HasAjax b) => Handler b b JStat -> Splice (Handler b b) +ajaxButton_ press = ajaxButtonWithHandler [] press diff --git a/src/Snap/Snaplet/LiftAjax/State.hs b/src/Snap/Snaplet/LiftAjax/State.hs index d3e6d2d..409fe6e 100644 --- a/src/Snap/Snaplet/LiftAjax/State.hs +++ b/src/Snap/Snaplet/LiftAjax/State.hs @@ -42,9 +42,12 @@ class HasAjax b where hidAsText :: HandlerId -> Text hidAsText (HandlerId h) = T.pack $ B.unpack h -getRqParam :: ByteString -> AjaxHandler b (Maybe ByteString) +getRqParam :: ByteString -> Handler b v (Maybe ByteString) getRqParam p = liftM (>>=listToMaybe) $ getsRequest $ rqParam p +getTextRqParam :: Text -> Handler b v (Maybe ByteString) +getTextRqParam = getRqParam . B.pack . T.unpack + setPageId :: PageId -> AjaxHandler b () setPageId pageId = modify $ \a -> a { ajaxPageId = pageId }