{-# LANGUAGE QuasiQuotes, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances #-}

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

The jmacro-rpc library provides an implementation of the JSON-RPC 2.0 protocol in Haskell (http://www.jsonrpc.org/), using typeclass based induction to automatically wrap arbitrary Haskell functions up as exposed RPCs, and to generate Haskell functions to call those RPCs on a remote server. Facilities are also included to expose RPCs in javascript on generated HTML pages, and to manage page-local (i.e. "conversation") state on these pages. This package provides all core functionality and APIs. Additional backend-specific packages are provided for wiring these functions up to existing HTTP server packages.

-}

module Network.JMacroRPC.Base where

import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)
import Control.Applicative
import Control.Concurrent
import Control.Monad.Trans
import Data.Aeson
import Data.Attoparsec.Lazy
import Data.Attoparsec.Number
import Data.Foldable(foldMap)
import qualified Data.IntMap as IM
import Data.Monoid
import Data.List(find)
import Data.Vector(toList)

import qualified Data.ByteString.Lazy.Char8 as BL

import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T

import Language.Javascript.JMacro

-- | A JSON request is a list of values
type JRequest  = [Value]

-- | A JSON result is either an error or a value.
type JResult = Either String Value

-- | A JsonRPC is a named function that takes a handle to some state, and yields a function from request to result in some monad. It is a representation of the server side of an RPC call.
data JsonRPC m s = JsonRPC String (s -> JRequest -> m JResult)

-- | retErr = return . Left
retErr :: Monad m => a -> m (Either a b)
retErr s = return $ Left s

-- To RPCs/Server Side

-- | This class should not be used directly.
class Monad m => ToJsonRPC a m | a -> m where
    toJsonRPC_ :: a -> ([Value] -> m JResult)

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

instance (FromJSON a, ToJsonRPC b m) => ToJsonRPC (a -> b) m where
    toJsonRPC_ f (x:xs) = case fromJSON x of
                            Error s -> retErr s
                            Success v -> toJsonRPC_ (f v) xs
    toJsonRPC_ _ [] = retErr "insufficient arguments"

-- | Takes a compatible function to a JsonRPC.
toJsonRPC :: ToJsonRPC a m => String -> a -> JsonRPC m ()
toJsonRPC nm f = JsonRPC nm $ \() -> toJsonRPC_ f

-- | Takes a compatible function to a JsonRPC making use of state (i.e. a conversation).
toJsonConvRPC :: ToJsonRPC a m => String -> (s -> a) -> JsonRPC m s
toJsonConvRPC nm f = JsonRPC nm (\s -> toJsonRPC_ (f s))

-- Client Side

-- | This class should not be used directly.
class ToJsonRPCCall a b | a -> b where
    toJsonRPCCall_ :: [Value] -> a -> b

instance FromJSON b => ToJsonRPCCall (IO (Either String b)) ((BL.ByteString -> IO (Either String BL.ByteString)) -> Value -> String -> IO (Either String b)) where
    toJsonRPCCall_ xs _ = \remoteCall ident method -> do
                            res <- remoteCall $ encode $ object
                                    [
                                     (T.pack "params" , toJSON $ reverse xs),
                                     (T.pack "jsonrpc", toJSON "2.0"),
                                     (T.pack "method" , toJSON method),
                                     (T.pack "id", ident)
                                    ]
                            return $ either (Left . id) toVal res
        where
          toVal bs =
            case eitherResult $ parse json bs of
              Left err -> Left err
              Right v ->
                  case v of
                    Object m ->
                        case mapM (\x -> HM.lookup (T.pack x) m) ["jsonrpc","result","id"] of
                          Just [String code, res, Number _] ->
                              if code /= T.pack "2.0"
                              then Left "bad protocol version"
                              else case fromJSON res of
                                     Error str -> Left str
                                     Success a -> Right a
                          _ -> Left $ "bad return val " ++ show v
                    _ -> Left $ "bad return val" ++ show v

instance (ToJSON a, ToJsonRPCCall b c) => ToJsonRPCCall (a -> b) (a -> c) where
    toJsonRPCCall_ xs f = \x -> toJsonRPCCall_ (toJSON x : xs) (f x)


-- | Send a function on Jsonable values to a function of the same signature whose logic is invokable on a remote server. This function operates on the type of its argument. The body can remain undefined.
toJsonRPCCall :: ToJsonRPCCall a b => a -> b
toJsonRPCCall x = toJsonRPCCall_ [] x

-- | Takes a name and a function and yields both the server-side JsonRPC and the client-side stub.
mkJsonRPCPair :: (ToJsonRPC a m, ToJsonRPCCall a t) =>
                 String -> (s -> a) -> (t, JsonRPC m s)
mkJsonRPCPair nm f = (toJsonRPCCall_ [] (f undefined), toJsonConvRPC nm f)


-- | JMacro Javascript stub to invoke json-rpc calls from web browsers.
invokeRPCLib :: JStat
invokeRPCLib =
    [jmacro|
         var !jmacro_rpc_id = 0;
         var !serverLoc = window.location.href.split(/[?#]/)[0];
         fun invokeJsonRPC serverLoc method args {
               var res;
               $.ajax({type    : "POST",
                       url     : serverLoc,
                       data    : JSON.stringify
                                       {
                                         params: args,
                                         jsonrpc: "2.0",
                                         method: method,
                                         id: jmacro_rpc_id
                                       },
                       success : \d {res = d},
                       dataType: "json",
                       async   : false
                      });
               if(res.result) {
                   return res.result;
               } else {
                   alert (method + ": " + res.error.message + "");
               }
         }
     |]

-- | id with a helpful type.
asIO :: IO a -> IO a
asIO = id

-- | Given a function for managing local state, and a list of JsonRPCs over that local state, produce a function from Bytestring to Bytestring mapping json-rpc requests to responses.
handleRpcs :: (Functor m, Monad m) => (Int -> m s) -> [JsonRPC m s] -> BL.ByteString -> m BL.ByteString
handleRpcs getS rpcs bs = encode <$>
    case eitherResult $ parse json bs of
      Left err -> return $ errToVal Nothing (-32700) err
      Right v ->
          case v of
            Object m -> case mapM (\x -> HM.lookup (T.pack x) m) ["jsonrpc","method","params","id"] of
                          Just [String code, String meth, Array params, Number ident] ->
                              if code /= T.pack "2.0"
                              then return $ errToVal (Just $ toInt ident) (-32600) "wrong protocol version -- server requires 2.0"
                              else case find (\(JsonRPC n _) -> n == T.unpack meth) rpcs of
                                     Just (JsonRPC _ f) -> jresToVal (toInt ident) <$> (flip f (toList params) =<< getS (toInt ident))
                                     Nothing -> return $ errToVal (Just $ toInt ident) (-32601) $ "no method defined " ++ (T.unpack meth)
                          _ -> do
                             return $ errToVal Nothing (-32602) $ "bad params passed, require jsonrpc, method, params, id"
            _ -> return $ errToVal Nothing (-32700) "not passed an object"

  where
    toInt (I i) = fromIntegral i
    toInt (D d) = round d

    jresToVal :: Int -> JResult -> Value
    jresToVal ident jres =
                    object $
                           [(T.pack "jsonrpc", toJSON "2.0"),
                            (T.pack "id", toJSON ident)] ++
                           case jres of
                             Right r -> [(T.pack "result", r)]
                             Left  e -> [(T.pack "error", eobj 0 e)]

    eobj :: Int -> String -> Value
    eobj ecode msg = object [(T.pack "code",toJSON ecode),(T.pack "message",toJSON msg)]

    errToVal :: Maybe Int -> Int -> String -> Value
    errToVal mident ecode msg = object $
                  [(T.pack "jsonrpc", toJSON "2.0"),
                   (T.pack "id", maybe Null toJSON mident),
                   (T.pack "error", eobj ecode msg)]

-- | Used for creating server backends. Yes, this type is confusing. But unless you are creating a server backend, you can ignore it. Takes a function to generate some time identifier, a function to cull page state, a rpc handler, a function for creating a single page, a function to initialize a page state, and a bunch of rpcs, and creates a pair of handler functions (one for POST and one for GET) such that individual clients first pull a page with an embedded ID, along with client-side rpc functions. Those functions in turn interact with state local to that invocation of a page when they make json-rpc requests to the server. The cull function is in IO so it has access to whatever notion of time it desires, including the opportunity to not run at all. Note that the POST page should be served from the same url as the get page, but with an additional "/jrpcs" directory guard.
mkConversationPageGen :: (MonadIO m1, MonadIO m) =>
                            IO timestamp
                            -> (IM.IntMap (timestamp,s) -> IO (IM.IntMap (timestamp,s)))
                            -> ((Int -> m s) -> [JsonRPC m s] -> m1 resp)
                            -> (JStat -> m1 resp)
                            -> IO s
                            -> [JsonRPC m s]
                            -> IO (m1 resp, m1 resp)
mkConversationPageGen  getStamp cullMap rpcFun pageFun emptyState rpcs = do
  mp <- newMVar (IM.empty :: IM.IntMap s)
  identSupply <- newMVar (1 :: Int)
  let
      stateFun ident = liftIO $ modifyMVar mp $ \m -> case IM.lookup ident m of
                           Just (_,res) -> do
                             t <- getStamp
                             newMap <- cullMap $ IM.insert ident (t,res) m
                             return (newMap, res)
                           Nothing -> do
                             s <- emptyState
                             t <- getStamp
                             m' <- cullMap m
                             return (IM.insert ident (t,s) m',s)
      genJs = do
        i <- liftIO $ modifyMVar identSupply $ \is -> return (is+1,is)
        return $ invokeRPCLib
             `mappend`
             [jmacro|
                      jmacro_rpc_id = `(i)`;
              |]
             `mappend`
             foldMap jsonRPCToDecl rpcs

  return $ (rpcFun stateFun rpcs, pageFun =<< genJs)

-- | Converts a json rpc to a javascript declaration of the appropriate function.
jsonRPCToDecl :: JsonRPC a m -> JStat
jsonRPCToDecl (JsonRPC n _) =
              BlockStat [
                    DeclStat (StrI n) Nothing,
                    AssignStat (ValExpr $ JVar $ StrI n)
                                   [jmacroE|\ {
                                      var a = Array.prototype.slice.call(arguments);
                                      return (invokeJsonRPC (serverLoc + "jrpcs") `(n)` a);
                                    }
                                    |]
          ]


type JState a = MVar (Either String a)
type JStateAsync a = MVar (Either (Int, String) (JState a))