{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import qualified Network.JsonRpc.Server as S
import Network.JsonRpc.Server ((:+:) (..))
import Internal ( request, defaultRq, defaultRsp
                , defaultIdErrRsp, nullIdErrRsp
                , version, result, rpcErr, method
                , params, id', array, rspToIdString)
import qualified TestParallelism
import Data.List (sortBy)
import qualified Data.Vector as V
import Data.Function (on)
import qualified Data.Aeson as A
import Data.Aeson ((.=))
import qualified Data.Aeson.Types as A
import qualified Data.HashMap.Strict as H
import qualified Data.ByteString.Lazy.Char8 as LB
import Control.Monad.Trans (liftIO)
import Control.Monad.State (State, runState, lift, modify)
import Control.Monad.Identity (Identity, runIdentity)
import Test.HUnit hiding (State, Test)
import Test.Framework (defaultMain, Test)
import Test.Framework.Providers.HUnit (testCase)
import Prelude hiding (subtract)

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif

main :: IO ()
main = defaultMain $ errorHandlingTests ++ otherTests

errorHandlingTests :: [Test]
errorHandlingTests = [ testCase "invalid JSON" $
                           let rsp = runIdentity $ S.call [] $ LB.pack "{"
                           in removeErrMsg <$> (A.decode =<< rsp) @?= Just (nullIdErrRsp (-32700))

                     , testCase "invalid JSON-RPC" $
                           assertSubtractResponse (A.object ["id" .= A.Number 10]) $ nullIdErrRsp (-32600)

                     , testCase "empty batch call" $
                           assertSubtractResponse A.emptyArray $ nullIdErrRsp (-32600)

                     , testCase "invalid batch element" $
                           removeErrMsg <$> callSubtractMethods (array [A.Bool True]) @?= Just (array [nullIdErrRsp (-32600)])

                     , testCase "wrong request version" $
                           assertSubtractResponse (defaultRq `version` Just "1.0") $ nullIdErrRsp (-32600)

                     , testCase "wrong id type" $
                           assertSubtractResponse (defaultRq `id'` (Just $ A.Bool True)) $ nullIdErrRsp (-32600)

                     , testCase "method not found" $
                           assertSubtractResponse (defaultRq `method` "add") (defaultIdErrRsp (-32601))

                     , testCase "wrong method name capitalization" $
                           assertSubtractResponse (defaultRq `method` "Subtract") (defaultIdErrRsp (-32601))

                     , testCase "missing required named argument" $
                           assertInvalidParams $ defaultRq `params` Just (A.object ["a" .= A.Number 1, "y" .= A.Number 20])

                     , testCase "missing required unnamed argument" $
                           assertInvalidParams $ defaultRq `method` "flipped subtract" `params` Just (array [A.Number 0])

                     , testCase "wrong argument type" $
                           assertInvalidParams $ defaultRq `params` Just (A.object ["x" .= A.Number 1, "y" .= A.String "2"])

                     , testCase "extra unnamed arguments" $
                           assertInvalidParams $ defaultRq `params` Just (array $ map A.Number [1, 2, 3])

                     , let req = defaultRq `id'` Nothing `method` "12345"
                       in testCase "invalid notification" $ callSubtractMethods req @?= Nothing ]

otherTests :: [Test]
otherTests = [ testCase "encode RPC error" $
                   A.toJSON (S.rpcError (-1) "error") @?= rpcErr Nothing (-1) "error"

             , let err = S.rpcErrorWithData 1 "my message" errData
                   testError = rpcErr (Just $ A.toJSON errData) 1 "my message"
                   errData = ('\x03BB', [True], ())
               in testCase "encode RPC error with data" $ A.toJSON err @?= testError

             , testCase "batch request" testBatch

             , testCase "batch notifications" testBatchNotifications

             , testCase "allow missing version" testAllowMissingVersion

             , testCase "no arguments" $ assertGetTimeResponse Nothing

             , testCase "empty argument array" $ assertGetTimeResponse $ Just A.emptyArray

             , testCase "empty argument A.object" $ assertGetTimeResponse $ Just A.emptyObject

             , let req = defaultRq `params` Just args
                   args = A.object ["x" .= A.Number 10, "y" .= A.Number 20, "z" .= A.String "extra"]
                   rsp = defaultRsp `result` A.Number (-10)
               in testCase "allow extra named argument" $ assertSubtractResponse req rsp

             , let req = defaultRq `params` (Just $ A.object [("x1", A.Number 500), ("x", A.Number 1000)])
                   rsp = defaultRsp `result` A.Number 1000
               in testCase "use default named argument" $ assertSubtractResponse req rsp

             , let req = defaultRq `params` (Just $ array [A.Number 4])
                   rsp = defaultRsp `result` A.Number 4
               in testCase "use default unnamed argument" $ assertSubtractResponse req rsp

             , testCase "string request ID" $ assertEqualId $ A.String "ID 5"

             , testCase "null request ID" $ assertEqualId A.Null

             , testCase "parallelize tasks" TestParallelism.testParallelizingTasks ]

assertSubtractResponse :: A.Value -> A.Value -> Assertion
assertSubtractResponse rq expectedRsp = removeErrMsg <$> rsp @?= Just expectedRsp
    where rsp = callSubtractMethods rq

assertEqualId :: A.Value -> Assertion
assertEqualId i = assertSubtractResponse (defaultRq `id'` Just i) (defaultRsp `id'` Just i)

assertInvalidParams :: A.Value -> Assertion
assertInvalidParams req = assertSubtractResponse req (defaultIdErrRsp (-32602))

testBatch :: Assertion
testBatch = sortBy (compare `on` rspToIdString) <$> response @?= Just expected
       where expected = [nullIdErrRsp (-32600), rsp i1 2, rsp i2 4] 
                 where rsp i x = defaultRsp `id'` Just i `result` A.Number x
             response = fromArray =<< (removeErrMsg <$> callSubtractMethods (array requests))
             requests = [rq (Just i1) 10 8, rq (Just i2) 24 20, rq Nothing 15 1, defaultRq `version` Just (A.String "abc")]
                 where rq i x y = defaultRq `id'` i `params` toArgs x y
             toArgs :: Int -> Int -> Maybe A.Value
             toArgs x y = Just $ A.object ["x" .= x, "y" .= y]
             i1 = A.Number 1
             i2 = A.Number 2
             fromArray (A.Array v) = Just $ V.toList v
             fromArray _ = Nothing

testBatchNotifications :: Assertion
testBatchNotifications = runState response 0 @?= (Nothing, 10)
    where response = S.call [incrementStateMethod] $ A.encode rq
          rq = replicate 10 $ request Nothing "increment" Nothing

testAllowMissingVersion :: Assertion
testAllowMissingVersion = callSubtractMethods requestNoVersion @?= (Just $ defaultRsp `result` A.Number 1)
    where requestNoVersion = defaultRq `version` Nothing `params` Just (A.object ["x" .= A.Number 1])

incrementStateMethod :: S.Method (State Int)
incrementStateMethod = S.toMethod "increment" f ()
    where f :: S.RpcResult (State Int) ()
          f = lift $ modify (+1)

assertGetTimeResponse :: Maybe A.Value -> Assertion
assertGetTimeResponse args = passed @? "unexpected RPC response"
    where passed = (expected ==) <$> rsp
          expected = Just $ defaultRsp `result` A.Number 100
          req = defaultRq `method` "get_time_seconds" `params` args
          rsp = callGetTimeMethod req

callSubtractMethods :: A.Value -> Maybe A.Value
callSubtractMethods req = let methods :: [S.Method Identity]
                              methods = [subtractMethod, flippedSubtractMethod]
                              rsp = S.call methods $ A.encode req
                          in A.decode =<< runIdentity rsp

callGetTimeMethod :: A.Value -> IO (Maybe A.Value)
callGetTimeMethod req = let rsp = S.call [getTimeMethod] $ A.encode req
                        in (A.decode =<<) <$> rsp

subtractMethod :: S.Method Identity
subtractMethod = S.toMethod "subtract" subtract (S.Required "x" :+: S.Optional "y" 0 :+: ())

flippedSubtractMethod :: S.Method Identity
flippedSubtractMethod = S.toMethod "flipped subtract" (flip subtract) ps
    where ps = S.Optional "y" (-1000) :+: S.Required "x" :+: ()

subtract :: Int -> Int -> S.RpcResult Identity Int
subtract x y = return (x - y)

getTimeMethod :: S.Method IO
getTimeMethod = S.toMethod "get_time_seconds" getTestTime ()
    where getTestTime :: S.RpcResult IO Integer
          getTestTime = liftIO $ return 100

removeErrMsg :: A.Value -> A.Value
removeErrMsg (A.Object rsp) = A.Object $ H.adjust removeMsg "error" rsp
    where removeMsg (A.Object err) = A.Object $ H.insert "message" "" $ H.delete "data" err
          removeMsg v = v
removeErrMsg (A.Array rsps) = A.Array $ removeErrMsg `V.map` rsps
removeErrMsg v = v