{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

-- |
-- Module: Servant.JsonRpc
--
-- Work with JSON-RPC protocol messages at both type and value level.
--
-- > type Mul = JsonRpc "mul" (Int, Int) String Int
-- >
-- > req :: Request (Int, Int)
-- > req = Request "mul" (3, 5) (Just 0)
-- >
-- > rsp :: JsonRpcResponse String Int
-- > rsp = Result 0 15
module Servant.JsonRpc
    (
    -- * API specification types
      JsonRpc
    , JsonRpcNotification

    -- * JSON-RPC messages
    , Request (..)
    , JsonRpcResponse (..)
    , JsonRpcErr (..)

    -- * Type rewriting
    , JsonRpcEndpoint
    ) where


import           Control.Applicative (liftA3)
import           Data.Aeson          (FromJSON (..), ToJSON (..), Value (Null),
                                      object, withObject, (.:), (.:?), (.=))
import           Data.Aeson.Types    (Parser)
import           Data.Maybe          (isNothing)
import           Data.Word           (Word64)
import           GHC.TypeLits        (Symbol)
import           Servant.API         ((:>), JSON, NoContent, Post, ReqBody)


-- | Client messages
data Request p
    = Request
    { method    :: String
    , params    :: p

    -- | should be omitted only if the message is a notification, with no response content
    , requestId :: Maybe Word64
    } deriving (Eq, Show)


instance ToJSON p => ToJSON (Request p) where
    toJSON (Request m p ix) =
        object
            . maybe id (onValue "id") ix
            $ [ "jsonrpc" .= ("2.0" :: String)
              , "method" .= m
              , "params" .= p
              ]

        where
        onValue n v = ((n .= v) :)


instance FromJSON p => FromJSON (Request p) where
    parseJSON = withObject "JsonRpc Request" $ \obj -> do
        ix <- obj .:? "id"
        m  <- obj .:  "method"
        p  <- obj .:  "params"
        v  <- obj .:  "jsonrpc"

        versionGuard v . pure $ Request m p ix


versionGuard :: Maybe String -> Parser a -> Parser a
versionGuard v x
    | v == Just "2.0" = x
    | isNothing v     = x
    | otherwise       = fail "unknown version"


-- | Server messages.  An 'Ack' is a message which refers to a 'Request' but
-- both its "errors" and "result" keys are null
data JsonRpcResponse e r
    = Result Word64 r
    | Ack Word64
    | Errors (Maybe Word64) (JsonRpcErr e)
    deriving (Eq, Show)


data JsonRpcErr e = JsonRpcErr
    { errorCode    :: Int
    , errorMessage :: String
    , errorData    :: Maybe e
    } deriving (Eq, Show)


instance (FromJSON e, FromJSON r) => FromJSON (JsonRpcResponse e r) where
    parseJSON = withObject "Response" $ \obj -> do
        ix      <- obj .:  "id"
        version <- obj .:? "jsonrpc"
        result  <- obj .:? "result"
        err     <- obj .:? "error"
        versionGuard version $ pack ix result err

        where

        pack (Just ix) (Just r) Nothing = pure $ Result ix r
        pack ix Nothing (Just e)        = Errors ix <$> parseErr e
        pack (Just ix) Nothing Nothing  = pure $ Ack ix
        pack _ _ _                      = fail "invalid response"

        parseErr = withObject "Error" $
            liftA3 JsonRpcErr <$> (.: "code") <*> (.: "message") <*> (.:? "data")


instance (ToJSON e, ToJSON r) => ToJSON (JsonRpcResponse e r) where
    toJSON (Result ix r) =
        object [ "jsonrpc" .= ("2.0" :: String)
               , "result"  .= r
               , "id"      .= ix
               ]

    toJSON (Ack ix) =
        object [ "jsonrpc" .= ("2.0" :: String)
               , "id"      .= ix
               , "result"  .= Null
               , "error"   .= Null
               ]

    toJSON (Errors ix (JsonRpcErr c msg err)) =
        object [ "jsonrpc" .= ("2.0" :: String)
               , "id"      .= ix
               , "error"   .= detail

               ]

         where
         detail = object [ "code"    .= c
                         , "message" .= msg
                         , "data"    .= err
                           ]


-- | JSON-RPC endpoints which respond with a result
data JsonRpc (method :: Symbol) p e r


-- | JSON-RPC endpoints which do not respond
data JsonRpcNotification (method :: Symbol) p


type family JsonRpcEndpoint a where
    JsonRpcEndpoint (JsonRpc m p e r)
        = ReqBody '[JSON] (Request p) :> Post '[JSON] (JsonRpcResponse e r)

    JsonRpcEndpoint (JsonRpcNotification m p)
        = ReqBody '[JSON] (Request p) :> Post '[JSON] NoContent