Tests.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
module Network.JsonRpc.Tests (tests) where

import Control.Applicative
import Control.Concurrent.Async.Lifted
import Control.Concurrent.STM
import qualified Data.ByteString.Lazy as L
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Conduit.TMChan
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Trans
import Data.Aeson
import Data.Aeson.Types
import Data.Either
import Data.Maybe
import Network.JsonRpc
import Network.JsonRpc.Arbitrary()
import Test.QuickCheck
import Test.QuickCheck.Monadic
import Test.Framework
import Test.Framework.Providers.QuickCheck2

tests :: [Test]
tests =
    [ testGroup "JSON-RPC Requests"
        [ testProperty "Check fields"
            (reqFields :: Request -> Bool)
        , testProperty "Encode/decode"
            (testEncodeDecode :: Request -> Bool)
        ]
    , testGroup "JSON-RPC Notifications"
        [ testProperty "Check fields"
            (notifFields :: Notif -> Bool)
        , testProperty "Encode/decode"
            (testEncodeDecode :: Notif -> Bool)
        ]
    , testGroup "JSON-RPC Responses"
        [ testProperty "Check fields"
            (resFields :: Response -> Bool)
        , testProperty "Encode/decode"
            (testEncodeDecode :: Response -> Bool)
        ]
    , testGroup "JSON-RPC Errors"
        [ testProperty "Check fields"
            (errFields :: Err -> Bool)
        , testProperty "Encode/decode"
            (testEncodeDecode :: Err -> Bool)
        ]
    , testGroup "Network"
        [ testProperty "Test server" serverTest
        , testProperty "Test client" clientTest
        ]
    ]

checkVerId :: Ver -> Id -> Object -> Parser Bool
checkVerId ver i o = do
    j <- o .:? "jsonrpc"
    guard $ if ver == V2 then j == Just (String "2.0") else isNothing j
    o .:? "id" .!= IdNull >>= guard . (==i)
    return True

checkFieldsReqNotif :: Ver -> Method -> Value -> Id -> Object -> Parser Bool
checkFieldsReqNotif ver m v i o = do
    checkVerId ver i o >>= guard
    o .: "method" >>= guard . (==m)
    o .: "params" >>= guard . (==v)
    return True

checkFieldsReq :: Request -> Object -> Parser Bool
checkFieldsReq (Request ver m v i) = checkFieldsReqNotif ver m v i

checkFieldsNotif :: Notif -> Object -> Parser Bool
checkFieldsNotif (Notif ver m v) = checkFieldsReqNotif ver m v IdNull

checkFieldsRes :: Response -> Object -> Parser Bool
checkFieldsRes (Response ver v i) o = do
    checkVerId ver i o >>= guard
    o .: "result" >>= guard . (==v)
    return True

checkFieldsErr :: Err -> Object -> Parser Bool
checkFieldsErr (Err ver e i) o = do
    checkVerId ver i o >>= guard
    o .: "error" >>= guard . (==e)
    return True

testFields :: ToJSON r => (Object -> Parser Bool) -> r -> Bool
testFields ck r = fromMaybe False . parseMaybe f $ toJSON r where
    f = withObject "json" ck

testEncodeDecode :: (Eq r, ToJSON r, FromJSON r) => r -> Bool
testEncodeDecode r = maybe False (==r) $ parseMaybe parseJSON (toJSON r)

reqFields :: Request -> Bool
reqFields rq = testFields (checkFieldsReq rq) rq

notifFields :: Notif -> Bool
notifFields nt = testFields (checkFieldsNotif nt) nt

resFields :: Response -> Bool
resFields rs = testFields (checkFieldsRes rs) rs

errFields :: Err -> Bool
errFields er = testFields (checkFieldsErr er) er

serverTest :: ([Request], Ver) -> Property
serverTest (reqs, ver) = monadicIO $ do
    rt <- run $ runNoLoggingT $ do
        (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16
                                                <*> newTBMChan 16
        let snk = sinkTBMChan bso False
            src = sourceTBMChan bsi
        withAsync (srv snk src) $ const $
            withAsync (sender bsi) $ const $
                receiver bso []
    assert $ length rt == length reqs
    assert $ null rt || all isJust rt
    assert $ params == reverse (results rt)
  where
    r q = return $ Right (q :: Value)
    srv snk src = runJsonRpcT ver r
        (encodeConduit =$ snk) (src =$ decodeConduit ver) dummySrv
    sender bsi = forM_ reqs $ liftIO . atomically .
        writeTBMChan bsi . L.toStrict . encode . MsgRequest
    receiver bso xs = if length xs == length reqs
        then return xs
        else liftIO (atomically $ readTBMChan bso) >>= \b -> case b of
            Just x -> do
                let res = decodeStrict' x :: Maybe Response
                receiver bso (res:xs)
            Nothing -> undefined
    params = map getReqParams reqs
    results = map $ getResult . fromJust

clientTest :: ([Value], Ver) -> Property
clientTest (qs, ver) = monadicIO $ do
    rt <- run $ runNoLoggingT $ do
        (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16
                                                <*> newTBMChan 16
        let snk = sinkTBMChan bso False
            src = sourceTBMChan bsi
            csnk = sinkTBMChan bsi False
            csrc = sourceTBMChan bso
        withAsync (srv snk src) $ const $ cli
            (CL.map Right =$ csnk)
            (csrc $= CL.map Right)
    assert $ length rt == length qs
    assert $ null rt || all correct rt
    assert $ qs == results rt
  where
    r q = return $ Right (q :: Value)
    srv snk src = runJsonRpcT ver r snk src dummySrv
    cli snk src = runJsonRpcT ver r snk src . forM qs $ sendRequest
    results = map fromJust . rights
    correct (Right (Just _)) = True
    correct _ = False