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
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") <$> (handleRpcs stateFun rpcs rq)
serveSimpleRpcs :: (MonadIO m, Functor m, Monad m) => [JsonRPC (ServerPartT m) ()] -> ServerPartT m Response
serveSimpleRpcs rpcs = serveRpcs (const $ return ()) rpcs
mkConversationPage :: forall m s timestamp. (Monad m, Functor m, MonadIO m) =>
IO timestamp
-> (IntMap (timestamp,s) -> IO (IntMap (timestamp,s)))
-> (JStat -> ServerPartT m Response)
-> IO s
-> [JsonRPC (ServerPartT m) s]
-> IO (ServerPartT m Response)
mkConversationPage getStamp cullMap pageFun emptyState rpcs = (\(rpcPage, mainPage) -> dir "jrpcs" rpcPage `mappend` mainPage) <$> mkConversationPageGen getStamp cullMap serveRpcs pageFun emptyState rpcs
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
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