{-# LANGUAGE CPP,
             OverloadedStrings,
             TypeOperators #-}

#if MIN_VERSION_mtl(2,2,1)
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif

module Tests (tests) where

import Network.JsonRpc.Client
import Network.JsonRpc.ServerAdapter
import Network.JsonRpc.Server (toMethods, rpcError, callWithBatchStrategy)
import qualified Data.Aeson as A
import Data.Aeson ((.=))
import qualified Data.ByteString.Lazy as B
import Data.Text (unpack)
import Data.List (isInfixOf)
import Control.Applicative (pure, empty, (<$>), (<$), (<*>), (<|>))
import Control.Monad.Error (runErrorT, throwError)
import Control.Monad.State (State, runState, evalState, modify, when)
import Test.HUnit hiding (State, Test)
import Test.Framework (Test)
import Test.Framework.Providers.HUnit (testCase)
import Prelude hiding (subtract)

tests :: [Test]
tests = [ testCase "single request" $ runServer (subtract 22 1) @?= (Right 21, 1)

        , testCase "batch with one request" $ myRunBatch (subtractB 1 2) @?= (Right (-1), 1)

        , let result = myRunBatch $ pure (,) <*> subtractB 7 3 <*> divideB 15 12
          in testCase "batch 1" $ result @?= (Right (4, 1.25), 2)

        , let result = myRunBatch $ (+) <$> subtractB 5 3 <*> ((*) <$> subtractB 11 2 <*> subtractB 15 10)
          in testCase "batch 2" $ result @?= (Right 47, 3)

        , let result = myRunBatch $ (*) <$> ((+) <$> subtractB 5 3 <*> subtractB 11 2) <*> subtractB 15 10
          in testCase "batch 3" $ result @?= (Right 55, 3)

        , testCase "single notification" $
                   runServer (subtract_ 1 2) @?= (Right (), 1)

        , testCase "batch with one notification" $
                   myRunBatch (subtractB_ 1 2) @?= (Right (), 1)

        , let result = myRunBatch $ (,) <$> subtractB_ 5 4 <*> subtractB 20 16
          in testCase "notification at start of batch" $ result @?= (Right ((), 4), 2)

        , let result = myRunBatch $ (,) <$> subtractB 5 4 <*> subtractB_ 20 16
          in testCase "notification at end of batch" $ result @?= (Right (1, ()), 2)

        , let result = myRunBatch $ (:) <$> divideB 4 2 <*> ((:[]) <$> divideB 1 0)
          in testCase "batch with error" $ result @?= (Left (-32050), 1)

        , testCase "single request with error" $ runServer (divide 10 0) @?= (Left (-32050), 0)

        , let result = runServer $ runBatch badServer $ (||) <$> pure True <*> pure False
              badServer = error "unnecessarily sent to server"
          in testCase "batch with no requests" $ result @?= (Right True, 0)

        , let result = myRunBatch $ divideB 1 0 <|> divideB 2 1
          in testCase "batch alternative with failure first" $ result @?= (Right 2, 1)

        , let result = myRunBatch $ divideB 2 1 <|> divideB 1 0
          in testCase "batch alternative with failure last" $ result @?= (Right 2, 1)

        , let result = myRunBatch $ divideB 2 0 <|> divideB 1 0
          in testCase "batch alternative with all failures" $ result @?= (Left (-32050), 0)

        , let result = myRunBatch $ divideB 2 1 <|> divideB 1 1
          in testCase "batch alternative with no failures" $ result @?= (Right 2, 2)

        , testCase "empty batch" $ myRunBatch (empty :: Batch String) @?= (Left (-31999), 0)

        , testCase "bad JSON response" $
                   assertErrorMsg (A.encode $ A.Number 3) ["Client cannot parse JSON response"]

        , let response = A.encode $ A.object [ "result" .= A.Number 3
                                             , "jsonrpc" .= A.String "2.0" ]
          in testCase "missing response id attribute" $ assertErrorMsg response
                 [ "Client cannot parse JSON response"
                 , "key \"id\" not present" ]

        , let response = A.encode [A.String "element"]
          in testCase "non-object response" $
             assertErrorMsg response ["expecting a JSON-RPC response"]

        , let response = A.encode $ A.object [ "id" .= A.Number 3
                                             , "result" .= True
                                             , "jsonrpc" .= A.String "2.0"]
          in testCase "wrong response result type" $
             assertErrorMsg response ["wrong result type"]
        ]

type Result r = RpcResult (State Int) r

subtractSig :: Signature (Int ::: Int ::: ()) Int
subtractSig = Signature "subtract" ("x" ::: "y" ::: ())

divideSig :: Signature (Double ::: Double ::: ()) Double
divideSig = Signature "divide" ("x" ::: "y" ::: ())

subtract = toFunction myServer subtractSig

subtract_ = toFunction_ myServer subtractSig

subtractB = toBatchFunction subtractSig

subtractB_ = toBatchFunction_ subtractSig

divide = toFunction myServer divideSig

divideB = toBatchFunction divideSig

runServer :: Result a -> (Either Int a, Int)
runServer server = runState (mapLeft errCode <$> runErrorT server) 0
    where mapLeft f (Left x) = Left $ f x
          mapLeft _ (Right x) = Right x

myRunBatch :: A.FromJSON a => Batch a -> (Either Int a, Int)
myRunBatch = runServer . runBatch myServer

myServer :: B.ByteString -> State Int (Maybe B.ByteString)
myServer = callWithBatchStrategy (sequence . reverse) methods

assertErrorMsg :: B.ByteString -> [String] -> Assertion
assertErrorMsg response expected = (runServer result @?= (Left (-31999), 0)) >>
                                   mapM_ (assertErrorMsgContains result) expected
                 where result = toFunction badServer subtractSig 10 1
                       badServer = constServer response

constServer :: B.ByteString -> B.ByteString -> State Int (Maybe B.ByteString)
constServer = const . return . Just

assertErrorMsgContains :: Result a -> String -> Assertion
assertErrorMsgContains server expected = case evalState (runErrorT server) 0 of
                                           Right _ -> assertFailure "Expected an error, but got a result."
                                           Left err -> assertBool msg $ expected `isInfixOf` errorMsg
                                               where errorMsg = unpack $ errMsg err
                                                     msg = "Wrong error message: " ++ errorMsg

methods = toMethods [subtractMethod, divideMethod]

subtractMethod = toServerMethod subtractSig f
    where f :: Int -> Int -> RpcResult (State Int) Int
          f x y = (x - y) <$ modify (+1)

divideMethod = toServerMethod divideSig f
    where f :: Double -> Double -> RpcResult (State Int) Double
          f x y = do
            when (y == 0) $ throwError $ rpcError (-32050) "divide by zero"
            x / y <$ modify (+1)