Initial commit

LICENSE

@@ -0,0 +1,27 @@
+Copyright (c) 2012, David Simmons-Duffin
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+Redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright notice, this
+list of conditions and the following disclaimer in the documentation and/or
+other materials provided with the distribution.
+
+Neither the name of the authors nor the names of its contributors may be used
+to endorse or promote products derived from this software without specific
+prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

snaplet-liftajax.cabal

@@ -0,0 +1,57 @@
+name:           snaplet-liftajax
+version:        0.0.1
+synopsis:       Ajax snaplet for the Snap Framework
+description:    An ajax snaplet for the Snap Framework, based on Scala's Lift.
+license:        BSD3
+license-file:   LICENSE
+author:         David Simmons-Duffin
+maintainer:     davidsd@gmail.com
+build-type:     Simple
+cabal-version:  >= 1.6
+homepage:       http://davidsd.org/
+category:       Web
+
+extra-source-files:  LICENSE
+
+source-repository head
+  type:     git
+  location: https://github.com/norm2782/snaplet-hdbc.git
+
+Library
+  hs-source-dirs: src
+
+  exposed-modules:
+    Snap.Snaplet.LiftAjax
+    Snap.Snaplet.LiftAjax.Splice
+    Snap.Snaplet.LiftAjax.Js
+
+  build-depends:
+    base                       >= 4       && < 5,
+    blaze-builder              >= 0.3,
+    bytestring                 >= 0.9.1   && < 0.10,
+    clientsession              >= 0.7.3.6 && < 0.8,
+    containers                 >= 0.3     && < 0.6,
+    convertible                >= 1.0     && < 1.1,
+    data-lens                  >= 2.0.1   && < 2.11,
+    data-lens-template         >= 2.1     && < 2.2,
+    digestive-functors         >= 0.5,
+    digestive-functors-snap    >= 0.5,
+    HDBC                       >= 2.2     && < 2.4,
+    heist                      >= 0.8     && < 0.9,
+    jmacro                     >= 0.5,
+    MonadCatchIO-transformers  >= 0.2.1   && < 0.4,
+    mtl                        >= 2.0     && < 2.2,
+    pretty                     >= 1.1.1,
+    prettyclass                >= 1.0,
+    resource-pool-catchio      >= 0.2     && < 0.3,
+    snap                       >= 0.9     && < 0.10,
+    snap-core                  == 0.9.*,
+    stm                        >= 2.3,
+    text                       >= 0.11    && < 0.12,
+    time                       >= 1.1     && < 1.5,
+    transformers               >= 0.2     && < 0.4,
+    unordered-containers       >= 0.1.4   && < 0.3,
+    xmlhtml                    >= 0.1
+
+  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
+               -fno-warn-orphans -fno-warn-unused-do-bind

src/Snap/Snaplet/LiftAjax.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+
+module Snap.Snaplet.LiftAjax
+    ( addCallback
+    , ajaxInit
+    , defaultAjaxState
+    , Ajax
+    , HasAjax
+    , ajaxLens
+    , ajaxForm
+    ) where
+
+------------------------------------------------------------------------------
+import           Control.Concurrent
+import           Control.Concurrent.STM
+import           Control.Monad.State
+import           Data.ByteString                (ByteString)
+import qualified Data.ByteString.Char8          as B
+import           Data.Lens.Lazy
+import qualified Data.Map                       as Map
+import           Data.Monoid
+import           Data.Text                      (Text)
+import           Language.Javascript.JMacro     ()
+import           Language.Javascript.JMacro
+import           Snap.Core
+import           Snap.Snaplet
+import           Snap.Snaplet.Heist
+import           Snap.Snaplet.LiftAjax.Callback
+import qualified Snap.Snaplet.LiftAjax.Js       as Js
+import qualified Snap.Snaplet.LiftAjax.Splice   as Splice
+import           Snap.Snaplet.LiftAjax.State
+import           Snap.Snaplet.Session.Common
+import           Text.Digestive
+import           Text.Templating.Heist
+import qualified Text.XmlHtml                   as X
+------------------------------------------------------------------------------
+
+class HasAjax b where
+    ajaxLens :: Lens b (Snaplet (Ajax b))
+
+ajaxForm :: HasAjax b =>
+            Text
+         -> Form v (Handler b b) a
+         -> (Either (View v) a -> Handler b b JStat)
+         -> Splice (Handler b b)
+ajaxForm = Splice.ajaxForm ajaxLens
+
+defaultAjaxState :: IO (Ajax b)
+defaultAjaxState = do
+  heartbeats <- newTVarIO Map.empty
+  callbacks  <- newTVarIO Map.empty
+  rng        <- mkRNG
+  return Ajax { ajaxHeartbeats   = heartbeats
+              , ajaxCallbacks    = callbacks
+              , ajaxPageId       = PageId ""
+              , ajaxRNG          = rng
+              , ajaxPageLifetime = 75*4           -- 5 minutes
+              , ajaxGCDelay      = 75*4*1000*1000 -- 5 minutes
+              }
+
+ajaxInit :: HasHeist b => IO (Ajax b) -> SnapletInit b (Ajax b)
+ajaxInit ajaxState = makeSnaplet "ajax" "" Nothing $ do
+                       addSplices splices
+                       addRoutes routes
+                       wrapSite (setNewPageId >>)
+                       ajax <- liftIO ajaxState
+                       gcThread <- liftIO $ forkIO $ collector ajax
+                       onUnload $ killThread gcThread
+                       return ajax
+
+routes :: HasHeist b => [(ByteString, AjaxHandler b ())]
+routes = [ ("/request/:pageId/", handleRequest)
+         , ("/gc",               failIfNotLocal handleGC)
+         , ("/state",            failIfNotLocal handleState)
+         ]
+    where
+      failIfNotLocal m = do
+        rip <- liftM rqRemoteAddr getRequest
+        if not $ elem rip [ "127.0.0.1" , "localhost" , "::1" ]
+          then pass
+          else m
+
+splices :: [(Text, SnapletSplice b (Ajax b))]
+splices = [ ("ajaxFooter", footerSplice) ]
+
+footerSplice :: SnapletSplice b (Ajax b)
+footerSplice = do
+  PageId pid  <- liftHandler $ gets ajaxPageId
+  ajaxUrl <- liftHandler getSnapletRootURL
+  let initGC = [jmacro| jQuery(document).ready(function() {liftAjax.lift_successRegisterGC();});
+                        var !lift_page = `(B.unpack pid)`;
+                        var !lift_ajaxUrl = `(B.unpack ajaxUrl)`; |]
+  return [ X.Element "script" [ ("type", "text/javascript") ]
+           [X.TextNode $ "// <![CDATA[\n" <> Js.showAsText initGC <> "\n//]]>"]
+         ]

src/Snap/Snaplet/LiftAjax/Callback.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Snap.Snaplet.LiftAjax.Callback
+    ( addCallback
+    , handleRequest
+    , handleState
+    , handleGC
+    , collector
+    ) where
+
+------------------------------------------------------------------------------
+import           Control.Applicative
+import           Control.Category
+import           Control.Concurrent
+import           Control.Concurrent.STM
+import           Control.Monad.State
+import           Data.ByteString             (ByteString)
+import qualified Data.ByteString.Char8       as B
+import qualified Data.Map                    as Map
+import           Data.Maybe
+import           Data.Text                   (Text)
+import qualified Data.Text                   as T
+import           Data.Time.Clock.POSIX
+import           Data.Time.Clock             (NominalDiffTime)
+import           Prelude                     hiding (id, (.))
+import           Snap.Core
+import           Snap.Snaplet
+import           Snap.Snaplet.Heist
+import           Snap.Snaplet.LiftAjax.State
+import qualified Text.PrettyPrint            as PP
+import           Text.PrettyPrint.HughesPJClass
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- Callbacks
+------------------------------------------------------------------------------
+
+addCallback :: Handler b b () -> AjaxHandler b HandlerId
+addCallback h = do
+  touchPage
+  handlerId <- newHandlerId
+  pageId <- gets ajaxPageId
+  modifyCallbacks $ insertCallback pageId handlerId
+  return handlerId
+      where
+        insertCallback pid hid = Map.insertWith Map.union pid $ Map.singleton hid h
+
+runCallback :: AjaxHandler b ()
+runCallback = do
+  maybeCallbacks <- Map.lookup <$> gets ajaxPageId <*> getCallbacks
+  params <- getsRequest rqParams
+  withTop' id $ fromMaybe pass $ do
+    callbacks <- maybeCallbacks
+    listToMaybe $ catMaybes $ map (flip Map.lookup callbacks . HandlerId) (Map.keys params)
+
+handleRequest :: AjaxHandler b ()
+handleRequest = do
+  maybePageId <- getRqParam "pageId"
+  maybe pass (setPageId . PageId) maybePageId
+  touchPage
+  maybeGC <- getRqParam "__lift__GC"
+  when (isNothing maybeGC) runCallback
+
+touchPage :: AjaxHandler b ()
+touchPage = do
+  pageId <- gets ajaxPageId
+  currentTime <- liftIO getPOSIXTime
+  modifyHeartbeats $ Map.insert pageId currentTime
+
+------------------------------------------------------------------------------
+-- Garbage Collection
+------------------------------------------------------------------------------
+
+deletePage :: Ajax b -> PageId -> IO ()
+deletePage (Ajax {..}) pageId =
+  atomically $ do
+    modifyTVar ajaxHeartbeats (Map.delete pageId)
+    modifyTVar ajaxCallbacks  (Map.delete pageId)
+
+stalePages :: Ajax b -> IO [PageId]
+stalePages (Ajax {..}) = do
+  currentTime <- getPOSIXTime
+  heartbeats <- readTVarIO ajaxHeartbeats
+  return $ map fst
+             $ filter ((< currentTime - ajaxPageLifetime) . snd)
+             $ Map.toList heartbeats
+
+collect :: Ajax b -> IO ()
+collect ajax = stalePages ajax >>= notify >>= mapM_ (deletePage ajax)
+    where
+      notify x = putStr "Collecting pages: " >> print x >> return x
+
+collector :: Ajax b -> IO ()
+collector ajax = go
+    where go = collect ajax >> threadDelay (ajaxGCDelay ajax) >> go
+
+handleGC :: AjaxHandler b ()
+handleGC = get >>= liftIO . collect
+
+------------------------------------------------------------------------------
+-- Debugging
+------------------------------------------------------------------------------
+
+handleState :: HasHeist b => AjaxHandler b ()
+handleState = showAjax >>= writeText
+
+instance (Pretty key, Pretty val) => Pretty (Map.Map key val) where
+    pPrint = PP.braces . PP.vcat . map kvPair . Map.toList
+        where kvPair (k,v) = PP.hsep [pPrint k, PP.text "->", pPrint v]
+instance Pretty ByteString       where pPrint = pPrint . B.unpack
+instance Pretty NominalDiffTime  where pPrint = PP.text . show
+instance Pretty (Handler b b ()) where pPrint = const $ PP.text "<handler>"
+instance Pretty PageId           where pPrint = PP.text . show
+instance Pretty HandlerId        where pPrint = PP.text . show
+
+showAjax :: AjaxHandler b Text
+showAjax = do
+  Ajax {..} <- get
+  hs <- liftIO $ readTVarIO ajaxHeartbeats
+  cs <- liftIO $ readTVarIO ajaxCallbacks
+  return $ T.pack $ PP.render $
+           PP.vcat [ PP.text "Callbacks:"
+                   , PP.nest 4 $ pPrint cs
+                   , PP.text "Heartbeats:"
+                   , PP.nest 4 $ pPrint hs
+                   ]

src/Snap/Snaplet/LiftAjax/Js.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+
+module Snap.Snaplet.LiftAjax.Js where
+
+------------------------------------------------------------------------------
+import           Blaze.ByteString.Builder
+import           Data.ByteString            (ByteString)
+import qualified Data.ByteString.Char8      as B
+import           Data.Text                  (Text)
+import qualified Data.Text                  as T
+import           Language.Javascript.JMacro
+import           Snap.Core
+import qualified Text.PrettyPrint           as PP
+import qualified Text.XmlHtml               as X
+------------------------------------------------------------------------------
+
+instance ToJExpr Text where
+    toJExpr = toJExpr . T.unpack
+
+instance ToJExpr [X.Node] where
+    toJExpr = toJExpr . B.unpack . toByteString . X.renderHtmlFragment X.UTF8
+
+write :: (JsToDoc a, JMacro a, MonadSnap m) => a -> m ()
+write = writeBS . showAsBS
+
+showAsBS :: (JsToDoc a, JMacro a) => a -> ByteString
+showAsBS = B.pack . PP.renderStyle (PP.style { PP.mode = PP.OneLineMode }) . renderJs
+
+showAsText :: (JsToDoc a, JMacro a) => a -> Text
+showAsText = T.pack . PP.renderStyle (PP.style { PP.mode = PP.OneLineMode }) . renderJs
+
+noop :: JStat
+noop = [jmacro|$.noop();|];