Protocol.hs

{-# 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 {messageId :: Int, messageContent :: a}
    deriving stock (Show)

newtype MarionetteMessage = MarionetteMessage LazyByteString

instance Binary MarionetteMessage where
    put :: MarionetteMessage -> Binary.Put
    put (MarionetteMessage lbs) =
        putLazyByteString $
            (fromString . show . LazyByteString.length $ lbs) <> ":" <> lbs
    get :: Binary.Get MarionetteMessage
    get = do
        len <- decimal
        ':' <- chr . fromIntegral <$> getWord8
        MarionetteMessage <$> getLazyByteString len

instance Show MarionetteMessage where
    show :: MarionetteMessage -> String
    show = Text.unpack . Text.decodeUtf8 . LazyByteString.toStrict . Binary.encode

data Command = Command
    { command :: Text
    , parameters :: Value
    }
    deriving stock (Show)

instance IsString Command where
    fromString str =
        Command
            { command = Text.pack str
            , parameters = Aeson.object []
            }

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

instance FromJSON (Message Command) where
    parseJSON :: Value -> Aeson.Parser (Message Command)
    parseJSON = withArray "Command" \a -> do
        case Foldable.toList a of
            [Number 0, messageIdVal, String command, parameters] -> do
                messageId <- parseJSON messageIdVal
                pure $ Message messageId $ Command{..}
            _ -> mzero

type Result = Either Error Value

instance ToJSON (Message Result) where
    toJSON :: Message Result -> Value
    toJSON Message{..} =
        Array
            [ Number 1
            , toJSON messageId
            , errVal
            , resVal
            ]
      where
        errVal = either toJSON (const Null) messageContent
        resVal = fromRight Null messageContent

instance FromJSON (Message Result) where
    parseJSON :: Value -> Aeson.Parser (Message Result)
    parseJSON = withArray "Result" \a -> do
        case Foldable.toList a of
            [Number 1, messageIdVal, err, res] -> do
                messageId <- parseJSON messageIdVal
                Message messageId
                    <$> if err == Null
                        then pure . Right $ res
                        else Left <$> parseJSON err
            _ -> 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
    -- ^ An error code identifying the kind of failure, e.g. @no such element@.
    , message :: Text
    -- ^ A human-readable description of the failure.
    , stacktrace :: Text
    -- ^ A stack trace taken on the server side when the error occurred.
    }
    deriving stock (Generic)
    deriving anyclass (Exception, FromJSON, ToJSON)

instance Show Error where
    show = Text.unpack . message

data Greeting = Greeting
    { applicationType :: Text
    , marionetteProtocol :: Int
    }
    deriving stock (Generic, Show)
    deriving anyclass (FromJSON)