{-# LANGUAGE ScopedTypeVariables, QuasiQuotes, FlexibleInstances, MultiParamTypeClasses #-}

{- |
Module      :  Network.JMacroRPC.Snap
Copyright   :  (c) Gershom Bazerman, 2012
License     :  BSD 3 Clause
Maintainer  :  gershomb@gmail.com
Stability   :  experimental

Snap backend for JMacro-RPC.

Example usage:

> {-# LANGUAGE QuasiQuotes #-}
> module Main where
> import Network.JMacroRPC.Snap
> import Snap.Http.Server
> import Snap.Core
> import Language.Javascript.JMacro
> import Control.Concurrent
> import Control.Monad.Trans
> import Network.JMacroRPC.Base
> import Text.XHtml hiding(dir)
> import qualified Data.Text as T
>
> jsScript f = script (primHtml f) ! [thetype "text/javascript"]
> jsScript' = jsScript . show . renderJs
>
> testPage = mkConversationPageNoCulling pageFun (newMVar (1::Int)) jRpcs
>     where pageFun :: JStat ->  Snap ()
>           pageFun js = writeText $ T.pack $ show $
>                        (header << [script ! [src "https://ajax.googleapis.com/ajax/libs/jquery/1.6.2/jquery.min.js"] << noHtml]) +++
>                        jsScript' js +++
>                        jsScript' ([jmacro|$(\
>                                      {
>                                            var b = $("<button>click me!</button>");
>                                            $("body").append(b);
>                                            b.click(\ {
>                                                var c = getCounter();
>                                                alert ("counter is: " + c);
>                                            });
>                                      });
>                                   |]);
>           jRpcs = [getCounterRPC]
>           getCounterRPC =
>               toJsonConvRPC "getCounter" $ \s -> (liftIO $ retRight =<< modifyMVar s (\i -> return (i+1,i)) :: Snap (Either String Int))
>
> retRight :: a -> IO (Either String a)
> retRight = return . Right
>
> main = quickHttpServe =<< testPage

Every invocation of this page (including from the same browser) will have a distinct, stateful, counter, stored server-side.

-}


module Network.JMacroRPC.Snap where

import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)
import Control.Applicative
import Network.JMacroRPC.Base
import Network.JMacroRPC.Panels
import Data.Aeson
import Language.Javascript.JMacro
import qualified Data.ByteString.Char8 as B
import Data.IntMap(IntMap)
import Snap.Core

instance (ToJSON b) => ToJsonRPC (Snap (Either String b)) Snap where
    toJsonRPC_ f = \ _ -> fmap (fmap toJSON) $ f

-- | Provide a set of json rpcs.
serveRpcs :: MonadSnap m => (Int -> m s) -> [JsonRPC m s] -> m ()
serveRpcs stateFun rpcs = do
  rq <- readRequestBody maxBound
  modifyResponse $ setContentType (B.pack "application/json")
  writeLBS =<< handleRpcs stateFun rpcs rq

-- | This general handler allows explicit culling of conversation state.
mkConversationPage :: (MonadSnap m) =>
                            IO timestamp -- ^ Get an abstract timestamp
                            -> (IntMap (timestamp,s) -> IO (IntMap (timestamp,s))) -- ^ Cull a map of conversations based on a timestamp
                            -> (JStat -> m ()) -- ^ 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
                            -> IO (m ())
mkConversationPage getStamp cullMap pageFun emptyState rpcs = (\(rpcPage, mainPage) -> dir (B.pack "jrpcs") rpcPage <|> mainPage) <$> mkConversationPageGen getStamp cullMap serveRpcs pageFun emptyState rpcs

-- | This simple handler allows conversation state to grow without bounds.
mkConversationPageNoCulling :: (MonadSnap m) => (JStat -> m ()) -> IO s -> [JsonRPC m s] -> IO (m ())
mkConversationPageNoCulling pageFun emptyState rpcs = mkConversationPage (return ()) return pageFun emptyState rpcs

-- | Convert a Panel into a Snap resource.
panelToPage :: Maybe String -> String -> Panel Snap -> Snap ()
panelToPage jqloc title p = dir (B.pack "jrpcs") updateHandler <|> method GET drawHandler
    where (updateHandler, drawHandler) = panelToPageGen (serveRpcs $ const (return ())) writeLazyText jqloc title p