{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Marionette.Protocol where

import Control.Monad (MonadPlus (mzero))
import Control.Monad.Catch (Exception (..))
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (..), withArray)
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.Binary (Binary (..), getWord8)
import Data.Binary qualified as Binary
import Data.Binary.Parser (decimal, getLazyByteString)
import Data.Binary.Put (putLazyByteString)
import Data.ByteString.Lazy (LazyByteString)
import Data.ByteString.Lazy qualified as LazyByteString
import Data.Char (chr)
import Data.Either (fromRight)
import Data.Foldable qualified as Foldable
import Data.String (IsString (fromString))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import GHC.Generics (Generic)
import Prelude hiding (log)

data Message a = Message {forall a. Message a -> Int
messageId :: Int, forall a. Message a -> a
messageContent :: a}
    deriving stock (Int -> Message a -> ShowS
[Message a] -> ShowS
Message a -> String
(Int -> Message a -> ShowS)
-> (Message a -> String)
-> ([Message a] -> ShowS)
-> Show (Message a)
forall a. Show a => Int -> Message a -> ShowS
forall a. Show a => [Message a] -> ShowS
forall a. Show a => Message a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Message a -> ShowS
showsPrec :: Int -> Message a -> ShowS
$cshow :: forall a. Show a => Message a -> String
show :: Message a -> String
$cshowList :: forall a. Show a => [Message a] -> ShowS
showList :: [Message a] -> ShowS
Show)

newtype MarionetteMessage = MarionetteMessage LazyByteString

instance Binary MarionetteMessage where
    put :: MarionetteMessage -> Binary.Put
    put :: MarionetteMessage -> Put
put (MarionetteMessage ByteString
lbs) =
        ByteString -> Put
putLazyByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$
            (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> (ByteString -> Int64) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
LazyByteString.length (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
lbs) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
lbs
    get :: Binary.Get MarionetteMessage
    get :: Get MarionetteMessage
get = do
        Int64
len <- Get Int64
forall a. Integral a => Get a
decimal
        Char
':' <- Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Char) -> Get Word8 -> Get Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
        ByteString -> MarionetteMessage
MarionetteMessage (ByteString -> MarionetteMessage)
-> Get ByteString -> Get MarionetteMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int64 -> Get ByteString
getLazyByteString Int64
len

instance Show MarionetteMessage where
    show :: MarionetteMessage -> String
    show :: MarionetteMessage -> String
show = Text -> String
Text.unpack (Text -> String)
-> (MarionetteMessage -> Text) -> MarionetteMessage -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (MarionetteMessage -> ByteString) -> MarionetteMessage -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LazyByteString.toStrict (ByteString -> ByteString)
-> (MarionetteMessage -> ByteString)
-> MarionetteMessage
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarionetteMessage -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode

data Command = Command
    { Command -> Text
command :: Text
    , Command -> Value
parameters :: Value
    }
    deriving stock (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Command -> ShowS
showsPrec :: Int -> Command -> ShowS
$cshow :: Command -> String
show :: Command -> String
$cshowList :: [Command] -> ShowS
showList :: [Command] -> ShowS
Show)

instance IsString Command where
    fromString :: String -> Command
fromString String
str =
        Command
            { command :: Text
command = String -> Text
Text.pack String
str
            , parameters :: Value
parameters = [Pair] -> Value
Aeson.object []
            }

instance ToJSON (Message Command) where
    toJSON :: Message Command -> Value
    toJSON :: Message Command -> Value
toJSON Message{Int
messageId :: forall a. Message a -> Int
messageId :: Int
messageId, messageContent :: forall a. Message a -> a
messageContent = Command{Value
Text
command :: Command -> Text
parameters :: Command -> Value
command :: Text
parameters :: Value
..}} =
        Array -> Value
Array
            [ Scientific -> Value
Number Scientific
0
            , Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
messageId
            , Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
command
            , Value
Item Array
parameters
            ]

instance FromJSON (Message Command) where
    parseJSON :: Value -> Aeson.Parser (Message Command)
    parseJSON :: Value -> Parser (Message Command)
parseJSON = String
-> (Array -> Parser (Message Command))
-> Value
-> Parser (Message Command)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray String
"Command" \Array
a -> do
        case Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Array
a of
            [Number Scientific
0, Item [Value]
messageIdVal, String Text
command, Item [Value]
parameters] -> do
                Int
messageId <- Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item [Value]
messageIdVal
                pure $ Int -> Command -> Message Command
forall a. Int -> a -> Message a
Message Int
messageId (Command -> Message Command) -> Command -> Message Command
forall a b. (a -> b) -> a -> b
$ Command{Value
Text
Item [Value]
command :: Text
parameters :: Value
command :: Text
parameters :: Item [Value]
..}
            [Value]
_ -> Parser (Message Command)
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

type Result = Either Error Value

instance ToJSON (Message Result) where
    toJSON :: Message Result -> Value
    toJSON :: Message Result -> Value
toJSON Message{Int
Result
messageId :: forall a. Message a -> Int
messageContent :: forall a. Message a -> a
messageId :: Int
messageContent :: Result
..} =
        Array -> Value
Array
            [ Scientific -> Value
Number Scientific
1
            , Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
messageId
            , Value
Item Array
errVal
            , Value
Item Array
resVal
            ]
      where
        errVal :: Value
errVal = (Error -> Value) -> (Value -> Value) -> Result -> Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> Value
forall a. ToJSON a => a -> Value
toJSON (Value -> Value -> Value
forall a b. a -> b -> a
const Value
Null) Result
messageContent
        resVal :: Value
resVal = Value -> Result -> Value
forall b a. b -> Either a b -> b
fromRight Value
Null Result
messageContent

instance FromJSON (Message Result) where
    parseJSON :: Value -> Aeson.Parser (Message Result)
    parseJSON :: Value -> Parser (Message Result)
parseJSON = String
-> (Array -> Parser (Message Result))
-> Value
-> Parser (Message Result)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray String
"Result" \Array
a -> do
        case Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Array
a of
            [Number Scientific
1, Item [Value]
messageIdVal, Item [Value]
err, Item [Value]
res] -> do
                Int
messageId <- Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item [Value]
messageIdVal
                Int -> Result -> Message Result
forall a. Int -> a -> Message a
Message Int
messageId
                    (Result -> Message Result)
-> Parser Result -> Parser (Message Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Value
Item [Value]
err Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
Null
                        then Result -> Parser Result
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> Parser Result)
-> (Item [Value] -> Result) -> Item [Value] -> Parser Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result
Item [Value] -> Result
forall a b. b -> Either a b
Right (Item [Value] -> Parser Result) -> Item [Value] -> Parser Result
forall a b. (a -> b) -> a -> b
$ Item [Value]
res
                        else Error -> Result
forall a b. a -> Either a b
Left (Error -> Result) -> Parser Error -> Parser Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Error
forall a. FromJSON a => Value -> Parser a
parseJSON Value
Item [Value]
err
            [Value]
_ -> Parser (Message Result)
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | An error reported by a Marionette or WebDriver command, as returned by
-- the server.
--
-- See <https://w3c.github.io/webdriver/#errors>
data Error = Error
    { Error -> Text
error :: Text
    -- ^ An error code identifying the kind of failure, e.g. @no such element@.
    , Error -> Text
message :: Text
    -- ^ A human-readable description of the failure.
    , Error -> Text
stacktrace :: Text
    -- ^ A stack trace taken on the server side when the error occurred.
    }
    deriving stock ((forall x. Error -> Rep Error x)
-> (forall x. Rep Error x -> Error) -> Generic Error
forall x. Rep Error x -> Error
forall x. Error -> Rep Error x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Error -> Rep Error x
from :: forall x. Error -> Rep Error x
$cto :: forall x. Rep Error x -> Error
to :: forall x. Rep Error x -> Error
Generic)
    deriving anyclass (Show Error
Typeable Error
(Typeable Error, Show Error) =>
(Error -> SomeException)
-> (SomeException -> Maybe Error)
-> (Error -> String)
-> (Error -> Bool)
-> Exception Error
SomeException -> Maybe Error
Error -> Bool
Error -> String
Error -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: Error -> SomeException
toException :: Error -> SomeException
$cfromException :: SomeException -> Maybe Error
fromException :: SomeException -> Maybe Error
$cdisplayException :: Error -> String
displayException :: Error -> String
$cbacktraceDesired :: Error -> Bool
backtraceDesired :: Error -> Bool
Exception, Maybe Error
Value -> Parser [Error]
Value -> Parser Error
(Value -> Parser Error)
-> (Value -> Parser [Error]) -> Maybe Error -> FromJSON Error
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Error
parseJSON :: Value -> Parser Error
$cparseJSONList :: Value -> Parser [Error]
parseJSONList :: Value -> Parser [Error]
$comittedField :: Maybe Error
omittedField :: Maybe Error
FromJSON, [Error] -> Value
[Error] -> Encoding
Error -> Bool
Error -> Value
Error -> Encoding
(Error -> Value)
-> (Error -> Encoding)
-> ([Error] -> Value)
-> ([Error] -> Encoding)
-> (Error -> Bool)
-> ToJSON Error
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Error -> Value
toJSON :: Error -> Value
$ctoEncoding :: Error -> Encoding
toEncoding :: Error -> Encoding
$ctoJSONList :: [Error] -> Value
toJSONList :: [Error] -> Value
$ctoEncodingList :: [Error] -> Encoding
toEncodingList :: [Error] -> Encoding
$comitField :: Error -> Bool
omitField :: Error -> Bool
ToJSON)

instance Show Error where
    show :: Error -> String
show = Text -> String
Text.unpack (Text -> String) -> (Error -> Text) -> Error -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Text
message

data Greeting = Greeting
    { Greeting -> Text
applicationType :: Text
    , Greeting -> Int
marionetteProtocol :: Int
    }
    deriving stock ((forall x. Greeting -> Rep Greeting x)
-> (forall x. Rep Greeting x -> Greeting) -> Generic Greeting
forall x. Rep Greeting x -> Greeting
forall x. Greeting -> Rep Greeting x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Greeting -> Rep Greeting x
from :: forall x. Greeting -> Rep Greeting x
$cto :: forall x. Rep Greeting x -> Greeting
to :: forall x. Rep Greeting x -> Greeting
Generic, Int -> Greeting -> ShowS
[Greeting] -> ShowS
Greeting -> String
(Int -> Greeting -> ShowS)
-> (Greeting -> String) -> ([Greeting] -> ShowS) -> Show Greeting
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Greeting -> ShowS
showsPrec :: Int -> Greeting -> ShowS
$cshow :: Greeting -> String
show :: Greeting -> String
$cshowList :: [Greeting] -> ShowS
showList :: [Greeting] -> ShowS
Show)
    deriving anyclass (Maybe Greeting
Value -> Parser [Greeting]
Value -> Parser Greeting
(Value -> Parser Greeting)
-> (Value -> Parser [Greeting])
-> Maybe Greeting
-> FromJSON Greeting
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Greeting
parseJSON :: Value -> Parser Greeting
$cparseJSONList :: Value -> Parser [Greeting]
parseJSONList :: Value -> Parser [Greeting]
$comittedField :: Maybe Greeting
omittedField :: Maybe Greeting
FromJSON)