Permalink
Browse files

Initial commit

  • Loading branch information...
1 parent 6c257c6 commit d7333ff5ce825398503281c9fa8f2fa2ef9d9da9 @davidsd committed Aug 17, 2012
View
27 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.
View
@@ -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
@@ -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//]]>"]
+ ]
@@ -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
+ ]
@@ -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();|];
Oops, something went wrong.

0 comments on commit d7333ff

Please sign in to comment.