{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}

-- |A collection of convenience functions for using and parsing JSON values
-- within 'WD'. All monadic parse errors are converted to asynchronous
-- 'BadJSON' exceptions.
--
-- These functions are used internally to implement webdriver commands, and may
-- be useful for implementing non-standard commands.
module Test.WebDriver.JSON
       ( -- * Access a JSON object key
         (!:), (.:??)
         -- * Conversion from JSON within WD
         -- |Apostrophes are used to disambiguate these functions
         -- from their "Data.Aeson" counterparts.
       , parseJSON', fromJSON'
         -- * Tuple functions
         -- |Convenience functions for working with tuples.

         -- ** JSON object constructors
       , single, pair, triple
         -- ** Extracting JSON objects into tuples
       , parsePair, parseTriple
         -- * Conversion from parser results to WD
         -- |These functions are used to implement the other functions
         -- in this module, and could be used to implement other JSON
         -- convenience functions
       , apResultToWD, aesonResultToWD
         -- * Parse exception
       , BadJSON(..)
         -- * parsing commands with no return value
       , NoReturn(..), noReturn, ignoreReturn

       , fromText
       ) where
import Test.WebDriver.Class (WebDriver)

import Data.Aeson as Aeson
import Data.Aeson.Types
import Data.Text (Text)
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Attoparsec.ByteString.Lazy (Result(..))
import qualified Data.Attoparsec.ByteString.Lazy as AP

import Control.Monad (join, void)
import Control.Applicative
import Control.Monad.Trans.Control
import Control.Exception.Lifted
import Data.String
import Data.Typeable

import Prelude -- hides some "unused import" warnings

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key             as A
import qualified Data.Aeson.KeyMap          as HM
fromText :: Text -> A.Key
fromText :: Text -> Key
fromText = Text -> Key
A.fromText
#else
import qualified Data.HashMap.Strict        as HM
fromText :: Text -> Text
fromText = id
#endif


instance Exception BadJSON
-- |An error occured when parsing a JSON value.
newtype BadJSON = BadJSON String
             deriving (BadJSON -> BadJSON -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BadJSON -> BadJSON -> Bool
$c/= :: BadJSON -> BadJSON -> Bool
== :: BadJSON -> BadJSON -> Bool
$c== :: BadJSON -> BadJSON -> Bool
Eq, Int -> BadJSON -> ShowS
[BadJSON] -> ShowS
BadJSON -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadJSON] -> ShowS
$cshowList :: [BadJSON] -> ShowS
show :: BadJSON -> String
$cshow :: BadJSON -> String
showsPrec :: Int -> BadJSON -> ShowS
$cshowsPrec :: Int -> BadJSON -> ShowS
Show, Typeable)


-- |A type indicating that we expect no return value from the webdriver request.
-- Its FromJSON instance parses successfully for any values that indicate lack of
-- a return value (a notion that varies from server to server).
data NoReturn = NoReturn

instance FromJSON NoReturn where
  parseJSON :: Value -> Parser NoReturn
parseJSON Value
Null                    = forall (m :: * -> *) a. Monad m => a -> m a
return NoReturn
NoReturn
  parseJSON (Object Object
o) | forall v. KeyMap v -> Bool
HM.null Object
o  = forall (m :: * -> *) a. Monad m => a -> m a
return NoReturn
NoReturn
  parseJSON (String Text
"")             = forall (m :: * -> *) a. Monad m => a -> m a
return NoReturn
NoReturn
  parseJSON Value
other                   = forall a. String -> Value -> Parser a
typeMismatch String
"no return value" Value
other

-- |Convenience function to handle webdriver commands with no return value.
noReturn :: WebDriver wd => wd NoReturn -> wd ()
noReturn :: forall (wd :: * -> *). WebDriver wd => wd NoReturn -> wd ()
noReturn = forall (f :: * -> *) a. Functor f => f a -> f ()
void

-- |Convenience function to ignore result of a webdriver command.
ignoreReturn :: WebDriver wd => wd Value -> wd ()
ignoreReturn :: forall (wd :: * -> *). WebDriver wd => wd Value -> wd ()
ignoreReturn = forall (f :: * -> *) a. Functor f => f a -> f ()
void


-- |Construct a singleton JSON 'object' from a key and value.
single :: ToJSON a => Text -> a -> Value
single :: forall a. ToJSON a => Text -> a -> Value
single Text
a a
x = [Pair] -> Value
object [(Text -> Key
fromText Text
a) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
x]

-- |Construct a 2-element JSON 'object' from a pair of keys and a pair of
-- values.
pair :: (ToJSON a, ToJSON b) => (Text,Text) -> (a,b) -> Value
pair :: forall a b. (ToJSON a, ToJSON b) => (Text, Text) -> (a, b) -> Value
pair (Text
a,Text
b) (a
x,b
y) = [Pair] -> Value
object [Text -> Key
fromText Text
a forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
x, Text -> Key
fromText Text
b forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= b
y]

-- |Construct a 3-element JSON 'object' from a triple of keys and a triple of
-- values.
triple :: (ToJSON a, ToJSON b, ToJSON c) =>
          (Text,Text,Text) -> (a,b,c) -> Value
triple :: forall a b c.
(ToJSON a, ToJSON b, ToJSON c) =>
(Text, Text, Text) -> (a, b, c) -> Value
triple (Text
a,Text
b,Text
c) (a
x,b
y,c
z) = [Pair] -> Value
object [Text -> Key
fromText Text
a forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
x, Text -> Key
fromText Text
bforall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= b
y, Text -> Key
fromText Text
c forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= c
z]


-- |Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an
-- instance of 'FromJSON'..
parseJSON' :: MonadBaseControl IO wd => FromJSON a => ByteString -> wd a
parseJSON' :: forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
ByteString -> wd a
parseJSON' = forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Result Value -> wd a
apResultToWD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> ByteString -> Result a
AP.parse Parser Value
json

-- |Convert a JSON 'Value' to an instance of 'FromJSON'.
fromJSON' :: MonadBaseControl IO wd => FromJSON a => Value -> wd a
fromJSON' :: forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Value -> wd a
fromJSON' = forall (wd :: * -> *) a. MonadBaseControl IO wd => Result a -> wd a
aesonResultToWD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Result a
fromJSON

-- |This operator is a wrapper over Aeson's '.:' operator.
(!:) :: (MonadBaseControl IO wd, FromJSON a) => Object -> Text -> wd a
Object
o !: :: forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Object -> Text -> wd a
!: Text
k = forall (wd :: * -> *) a. MonadBaseControl IO wd => Result a -> wd a
aesonResultToWD forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Parser b) -> a -> Result b
parse (forall a. FromJSON a => Object -> Key -> Parser a
.: Text -> Key
fromText Text
k) Object
o

-- |Due to a breaking change in the '.:?' operator of aeson 0.10 (see <https://github.com/bos/aeson/issues/287>) that was subsequently reverted, this operator
-- was added to provide consistent behavior compatible with all aeson versions. If the field is either missing or `Null`, this operator should return a `Nothing` result.
(.:??) :: FromJSON a => Object -> Text -> Parser (Maybe a)
Object
o .:?? :: forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:?? Text
k = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Text -> Key
fromText Text
k)


-- |Parse a JSON 'Object' as a pair. The first two string arguments specify the
-- keys to extract from the object. The third string is the name of the
-- calling function, for better error reporting.
parsePair :: (MonadBaseControl IO wd, FromJSON a, FromJSON b) =>
             String -> String -> String -> Value -> wd (a, b)
parsePair :: forall (wd :: * -> *) a b.
(MonadBaseControl IO wd, FromJSON a, FromJSON b) =>
String -> String -> String -> Value -> wd (a, b)
parsePair String
a String
b String
funcName Value
v =
  case Value
v of
    Object Object
o -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Object -> Text -> wd a
!: forall a. IsString a => String -> a
fromString String
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Object -> Text -> wd a
!: forall a. IsString a => String -> a
fromString String
b
    Value
_        -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BadJSON
BadJSON forall a b. (a -> b) -> a -> b
$ String
funcName forall a. [a] -> [a] -> [a]
++
                String
": cannot parse non-object JSON response as a (" forall a. [a] -> [a] -> [a]
++ String
a
                forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
b forall a. [a] -> [a] -> [a]
++ String
") pair" forall a. [a] -> [a] -> [a]
++ String
")"


-- |Parse a JSON Object as a triple. The first three string arguments
-- specify the keys to extract from the object. The fourth string is the name
-- of the calling function, for better error reporting.
parseTriple :: (MonadBaseControl IO wd, FromJSON a, FromJSON b, FromJSON c) =>
               String -> String -> String ->  String -> Value -> wd (a, b, c)
parseTriple :: forall (wd :: * -> *) a b c.
(MonadBaseControl IO wd, FromJSON a, FromJSON b, FromJSON c) =>
String -> String -> String -> String -> Value -> wd (a, b, c)
parseTriple String
a String
b String
c String
funcName Value
v =
  case Value
v of
    Object Object
o -> (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Object -> Text -> wd a
!: forall a. IsString a => String -> a
fromString String
a
                     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Object -> Text -> wd a
!: forall a. IsString a => String -> a
fromString String
b
                     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Object -> Text -> wd a
!: forall a. IsString a => String -> a
fromString String
c
    Value
_        -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BadJSON
BadJSON forall a b. (a -> b) -> a -> b
$ String
funcName forall a. [a] -> [a] -> [a]
++
                String
": cannot parse non-object JSON response as a (" forall a. [a] -> [a] -> [a]
++ String
a
                forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
b forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String
c forall a. [a] -> [a] -> [a]
++ String
") pair"



-- |Convert an attoparsec parser result to 'WD'.
apResultToWD :: (MonadBaseControl IO wd, FromJSON a) => AP.Result Value -> wd a
apResultToWD :: forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Result Value -> wd a
apResultToWD Result Value
p = case Result Value
p of
  Done ByteString
_ Value
res -> forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Value -> wd a
fromJSON' Value
res
  Fail ByteString
_ [String]
_ String
err -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> BadJSON
BadJSON String
err

-- |Convert an Aeson parser result to 'WD'.
aesonResultToWD :: (MonadBaseControl IO wd) => Aeson.Result a -> wd a
aesonResultToWD :: forall (wd :: * -> *) a. MonadBaseControl IO wd => Result a -> wd a
aesonResultToWD Result a
r = case Result a
r of
  Success a
val -> forall (m :: * -> *) a. Monad m => a -> m a
return a
val
  Error String
err   -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> BadJSON
BadJSON String
err