json-rpc-server-0.1.0.0: demo/Demo.hs

{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import Network.JsonRpc.Server
import Happstack.Server.SimpleHTTP hiding (Method, body, result)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
import Control.Monad.Error (throwError)
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Concurrent.MVar

main :: IO ()
main = newMVar 0 >>= \count ->
       simpleHTTP nullConf $ do
         request <- askRq
         body <- liftIO $ getBody request
         result <- runReaderT (call methods body) count
         let resultStr = fromMaybe "" result
         return $ toResponse resultStr
    where getBody r = unBody `fmap` readMVar (rqBody r)

type Server = ReaderT (MVar Integer) (ServerPartT IO)

methods :: Methods Server
methods = toMethods [printSequence, getCount, add]

printSequence, getCount, add :: Method Server

printSequence = toMethod "print" f params
    where params = Required "string" :+:
                   Optional "count" 1 :+:
                   Optional "separator" ',' :+: ()
          f :: String -> Int -> Char -> RpcResult Server ()
          f str count sep = do
              when (count < 0) $ throwError negativeCount
              liftIO $ print $ intercalate [sep] $ replicate count str
          negativeCount = rpcError (-32000) "negative count"

getCount = toMethod "get_count" f ()
    where f :: RpcResult Server Integer
          f = ask >>= \count -> liftIO $ modifyMVar count inc
              where inc x = return (x + 1, x + 1)

add = toMethod "add" f (Required "x" :+: Required "y" :+: ())
    where f :: Double -> Double -> RpcResult Server Double
          f x y = liftIO $ return (x + y)