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


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

Happstack backend for JMacro-RPC.

Example usage:

> {-# LANGUAGE QuasiQuotes #-}
> module Main where
> import Network.JMacroRPC.Happstack
> import Happstack.Server
> import Language.Javascript.JMacro
> import Control.Concurrent
> import Network.JMacroRPC.Base
> import Text.XHtml hiding(dir)
> import Control.Monad.Trans(lift)
>
> 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 $
>                        (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 -> (lift $ retRight =<< modifyMVar s (\i -> return (i+1,i)) :: ServerPartT IO (Either String Int))
>
> retRight :: a -> IO (Either String a)
> retRight = return . Right
>
> main = simpleHTTP nullConf =<< testPage

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

-}

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

-- | 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
                            -> (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.
                            -> 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 (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 (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