diff --git a/Network/JMacroRPC/Happstack.hs b/Network/JMacroRPC/Happstack.hs --- a/Network/JMacroRPC/Happstack.hs +++ b/Network/JMacroRPC/Happstack.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE ScopedTypeVariables, QuasiQuotes, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables, QuasiQuotes, RankNTypes, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} + {- | Module : Network.JMacroRPC.Happstack Copyright : (c) Gershom Bazerman, 2012 @@ -19,17 +20,17 @@ > import Control.Concurrent > import Network.JMacroRPC.Base > import Text.XHtml hiding(dir) -> +> > jsScript f = script (primHtml f) ! [thetype "text/javascript"] > jsScript' = jsScript . show . renderJs -> +> > testPage :: IO (ServerPartT IO Response) > testPage = mkConversationPageNoCulling pageFun (newMVar (1::Int)) jRpcs -> where pageFun js = return $ toResponse $ +> where pageFun js = return $ toResponse $ > (header << [script ! [src "https://ajax.googleapis.com/ajax/libs/jquery/1.6.2/jquery.min.js"] << noHtml]) +++ > jsScript' js +++ -> jsScript' ([jmacro|$(\ -> { +> jsScript' ([jmacro|$(\ +> { > var b = $(""); > $("body").append(b); > b.click(\ { @@ -39,7 +40,7 @@ > }); > |]); > jRpcs = [getCounterRPC] -> getCounterRPC = +> getCounterRPC = > toJsonConvRPC "getCounter" $ \s -> retRight =<< modifyMVar s (\i -> return (i+1,i)) > > retRight :: a -> IO (Either String a) @@ -52,38 +53,49 @@ -} module Network.JMacroRPC.Happstack where - + import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) import Control.Applicative import Control.Monad.Trans import Data.Maybe import Data.Monoid import Network.JMacroRPC.Base +import Network.JMacroRPC.Panels import Happstack.Server import Language.Javascript.JMacro import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import Data.IntMap(IntMap) +import Data.Aeson +import qualified Text.Blaze.Html as H -serveRpcs :: (MonadIO m, Functor m, Monad m) => (Int -> m s) -> [JsonRPC m s] -> ServerPartT m Response +instance (ToJSON b, Monad m, Functor m) => ToJsonRPC (ServerPartT m (Either String b)) (ServerPartT m) where + toJsonRPC_ f = \ _ -> fmap (fmap toJSON) $ f + +serveRpcs :: (MonadIO m, Functor m, Monad m) => (Int -> (ServerPartT m) s) -> [JsonRPC (ServerPartT m) s] -> ServerPartT m Response serveRpcs stateFun rpcs = do rq <- fromMaybe (BL.empty) . fmap unBody <$> (takeRequestBody =<< askRq) - toResponseBS (B.pack "application/json") <$> lift (handleRpcs stateFun rpcs rq) + toResponseBS (B.pack "application/json") <$> (handleRpcs stateFun rpcs rq) -serveSimpleRpcs :: (MonadIO m, Functor m, Monad m) => [JsonRPC m ()] -> ServerPartT m Response + +serveSimpleRpcs :: (MonadIO m, Functor m, Monad m) => [JsonRPC (ServerPartT m) ()] -> ServerPartT m Response serveSimpleRpcs rpcs = serveRpcs (const $ return ()) rpcs -- | This general handler allows explicit culling of conversation state. -mkConversationPage :: forall m s timestamp. (Monad m, Functor m, MonadIO m) => - IO timestamp -- ^ Get an abstract timestamp +mkConversationPage :: forall m s timestamp. (Monad m, Functor m, MonadIO m) => + IO timestamp -- ^ Get an abstract timestamp -> (IntMap (timestamp,s) -> IO (IntMap (timestamp,s))) -- ^ Cull a map of conversations based on a timestamp - -> (JStat -> ServerPartT m Response) -- ^ Take some JMacro Javascript and splice it into some generated page. + -> (JStat -> ServerPartT m Response) -- ^ Take some JMacro Javascript and splice it into some generated page. -> IO s -- ^ Generate an empty "initial" state for a conversation. States are responsible for using their own MVars or the like to allow sharing. - -> [JsonRPC m s] -- ^ JSON RPCs to serve and make available to clientside javascript + -> [JsonRPC (ServerPartT m) s] -- ^ JSON RPCs to serve and make available to clientside javascript -> IO (ServerPartT m Response) mkConversationPage getStamp cullMap pageFun emptyState rpcs = (\(rpcPage, mainPage) -> dir "jrpcs" rpcPage `mappend` mainPage) <$> mkConversationPageGen getStamp cullMap serveRpcs pageFun emptyState rpcs -- | This simple handler allows conversation state to grow without bounds. -mkConversationPageNoCulling :: forall m s. (Monad m, Functor m, MonadIO m) => (JStat -> ServerPartT m Response) -> IO s -> [JsonRPC m s] -> IO (ServerPartT m Response) +mkConversationPageNoCulling :: forall m s. (Monad m, Functor m, MonadIO m) => (JStat -> ServerPartT m Response) -> IO s -> [JsonRPC (ServerPartT m) s] -> IO (ServerPartT m Response) mkConversationPageNoCulling pageFun emptyState rpcs = mkConversationPage (return ()) return pageFun emptyState rpcs +-- | Render a Panel as a @ServerPartT m Response@. +panelToPage :: (Monad m, Functor m, MonadIO m) => String -> Panel (ServerPartT m) -> ServerPartT m Response +panelToPage title p = dir "jrpcs" updateHandler `mappend` drawHandler + where (updateHandler, drawHandler) = panelToPageGen (serveRpcs $ const (return ())) (return . toResponse . H.preEscapedToHtml) title p diff --git a/jmacro-rpc-happstack.cabal b/jmacro-rpc-happstack.cabal --- a/jmacro-rpc-happstack.cabal +++ b/jmacro-rpc-happstack.cabal @@ -1,20 +1,20 @@ Name: jmacro-rpc-happstack -Version: 0.1 +Version: 0.2 Homepage: http://patch-tag.com/r/gershomb/jmacro-rpc License: BSD3 License-file: LICENSE Author: Gershom Bazerman Maintainer: gershomb@gmail.com -Category: Network +Category: Network, Web Build-type: Simple Cabal-version: >=1.6 Synopsis: Happstack backend for jmacro-rpc -Description: Provides functions for serving jmacro-rpc json rpcs from Happstack. +Description: Provides functions for serving jmacro-rpc json rpcs and panels from Happstack. Library Exposed-modules: Network.JMacroRPC.Happstack - Build-depends: base >= 4, base < 7, bytestring > 0.9, jmacro > 0.5, happstack-server > 6, jmacro-rpc >= 0.1, mtl >= 2, containers >= 0.4 + Build-depends: base >= 4, base < 7, bytestring > 0.9, jmacro > 0.6, happstack-server > 6, jmacro-rpc >= 0.2, mtl >= 2, containers >= 0.4, aeson >= 0.6, blaze-html >= 0.5 ghc-options: -Wall