{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE AllowAmbiguousTypes    #-}

module CDP.Internal.Utils where

import           Control.Monad
import           Control.Monad.Loops
import           Control.Monad.Trans  (liftIO)
import qualified Data.Map             as M
import           Data.Maybe
import Data.Foldable (for_)
import Data.Functor.Identity
import Data.String
import qualified Data.Text as T
import qualified Data.List as List
import qualified Data.Text.IO         as TI
import qualified Data.Vector          as V
import Data.Aeson.Types (Parser(..))
import           Data.Aeson           (FromJSON (..), ToJSON (..), (.:), (.:?), (.=), (.!=), (.:!))
import qualified Data.Aeson           as A
import qualified Network.WebSockets as WS
import Control.Concurrent
import qualified Data.ByteString.Lazy as BS
import qualified Data.Map as Map
import Data.Proxy
import System.Random
import Control.Applicative
import Data.Default
import Control.Exception
import System.Timeout
import Data.Char
import qualified System.IO as IO
import qualified Data.IORef as IORef

newtype CommandId = CommandId { CommandId -> Int
unCommandId :: Int }
    deriving (CommandId -> CommandId -> Bool
(CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool) -> Eq CommandId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommandId -> CommandId -> Bool
$c/= :: CommandId -> CommandId -> Bool
== :: CommandId -> CommandId -> Bool
$c== :: CommandId -> CommandId -> Bool
Eq, Eq CommandId
Eq CommandId
-> (CommandId -> CommandId -> Ordering)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> CommandId)
-> (CommandId -> CommandId -> CommandId)
-> Ord CommandId
CommandId -> CommandId -> Bool
CommandId -> CommandId -> Ordering
CommandId -> CommandId -> CommandId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CommandId -> CommandId -> CommandId
$cmin :: CommandId -> CommandId -> CommandId
max :: CommandId -> CommandId -> CommandId
$cmax :: CommandId -> CommandId -> CommandId
>= :: CommandId -> CommandId -> Bool
$c>= :: CommandId -> CommandId -> Bool
> :: CommandId -> CommandId -> Bool
$c> :: CommandId -> CommandId -> Bool
<= :: CommandId -> CommandId -> Bool
$c<= :: CommandId -> CommandId -> Bool
< :: CommandId -> CommandId -> Bool
$c< :: CommandId -> CommandId -> Bool
compare :: CommandId -> CommandId -> Ordering
$ccompare :: CommandId -> CommandId -> Ordering
$cp1Ord :: Eq CommandId
Ord, Int -> CommandId -> ShowS
[CommandId] -> ShowS
CommandId -> String
(Int -> CommandId -> ShowS)
-> (CommandId -> String)
-> ([CommandId] -> ShowS)
-> Show CommandId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommandId] -> ShowS
$cshowList :: [CommandId] -> ShowS
show :: CommandId -> String
$cshow :: CommandId -> String
showsPrec :: Int -> CommandId -> ShowS
$cshowsPrec :: Int -> CommandId -> ShowS
Show, Value -> Parser [CommandId]
Value -> Parser CommandId
(Value -> Parser CommandId)
-> (Value -> Parser [CommandId]) -> FromJSON CommandId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CommandId]
$cparseJSONList :: Value -> Parser [CommandId]
parseJSON :: Value -> Parser CommandId
$cparseJSON :: Value -> Parser CommandId
FromJSON, [CommandId] -> Encoding
[CommandId] -> Value
CommandId -> Encoding
CommandId -> Value
(CommandId -> Value)
-> (CommandId -> Encoding)
-> ([CommandId] -> Value)
-> ([CommandId] -> Encoding)
-> ToJSON CommandId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CommandId] -> Encoding
$ctoEncodingList :: [CommandId] -> Encoding
toJSONList :: [CommandId] -> Value
$ctoJSONList :: [CommandId] -> Value
toEncoding :: CommandId -> Encoding
$ctoEncoding :: CommandId -> Encoding
toJSON :: CommandId -> Value
$ctoJSON :: CommandId -> Value
ToJSON)

type CommandResponseBuffer =
    Map.Map CommandId (MVar (Either ProtocolError A.Value))

type SessionId = T.Text

data Subscriptions = Subscriptions
    { Subscriptions
-> Map (String, Maybe SessionId) (Map Int (Value -> IO ()))
subscriptionsHandlers :: Map.Map (String, Maybe SessionId) (Map.Map Int (A.Value -> IO ()))
    , Subscriptions -> Int
subscriptionsNextId   :: Int
    }
 
data Handle = Handle
    { Handle -> Config
config           :: Config
    , Handle -> MVar CommandId
commandNextId    :: MVar CommandId
    , Handle -> IORef Subscriptions
subscriptions    :: IORef.IORef Subscriptions
    , Handle -> IORef CommandResponseBuffer
commandBuffer    :: IORef.IORef CommandResponseBuffer
    , Handle -> Connection
conn             :: WS.Connection
    , Handle -> ThreadId
listenThread     :: ThreadId
    , Handle -> MVar [(String, ByteString)]
responseBuffer   :: MVar [(String, BS.ByteString)]
    }

data Config = Config
    { Config -> (String, Int)
hostPort           :: (String, Int)
      -- | Target of initial connection. 
      --   If False, the initial connection is made to the page.
    , Config -> Bool
connectToBrowser   :: Bool
    , Config -> Bool
doLogResponses     :: Bool
      -- | Number of microseconds to wait for a command response.
      --   Waits forever if Nothing.
    , Config -> Maybe Int
commandTimeout     :: Maybe Int
    } deriving Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show
instance Default Config where
    def :: Config
def = Config :: (String, Int) -> Bool -> Bool -> Maybe Int -> Config
Config{Bool
Maybe Int
(String, Int)
commandTimeout :: Maybe Int
doLogResponses :: Bool
connectToBrowser :: Bool
hostPort :: (String, Int)
commandTimeout :: Maybe Int
doLogResponses :: Bool
connectToBrowser :: Bool
hostPort :: (String, Int)
..}
      where
        hostPort :: (String, Int)
hostPort         = (String
"http://127.0.0.1", Int
9222)
        connectToBrowser :: Bool
connectToBrowser = Bool
False
        doLogResponses :: Bool
doLogResponses   = Bool
False
        commandTimeout :: Maybe Int
commandTimeout   = Maybe Int
forall a. Default a => a
def

class FromJSON a => Event a where
    eventName :: Proxy a -> String

class (ToJSON cmd, FromJSON (CommandResponse cmd)) => Command cmd where
    type CommandResponse cmd :: *
    commandName :: Proxy cmd -> String
    fromJSON :: Proxy cmd -> A.Value -> A.Result (CommandResponse cmd)
    fromJSON = (Value -> Result (CommandResponse cmd))
-> Proxy cmd -> Value -> Result (CommandResponse cmd)
forall a b. a -> b -> a
const Value -> Result (CommandResponse cmd)
forall a. FromJSON a => Value -> Result a
A.fromJSON

data ProtocolError = 
      PEParse          String      -- ^ Invalid JSON was received by the server. An error occurred on the server while parsing the JSON text
    | PEInvalidRequest String      -- ^ The JSON sent is not a valid Request object
    | PEMethodNotFound String      -- ^ The method does not exist / is not available
    | PEInvalidParams  String      -- ^ Invalid method parameter (s)
    | PEInternalError  String      -- ^ Internal JSON-RPC error
    | PEServerError    String      -- ^ Server error
    | PEOther          String      -- ^ An uncategorized error
    deriving ProtocolError -> ProtocolError -> Bool
(ProtocolError -> ProtocolError -> Bool)
-> (ProtocolError -> ProtocolError -> Bool) -> Eq ProtocolError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProtocolError -> ProtocolError -> Bool
$c/= :: ProtocolError -> ProtocolError -> Bool
== :: ProtocolError -> ProtocolError -> Bool
$c== :: ProtocolError -> ProtocolError -> Bool
Eq
instance Exception ProtocolError
instance Show ProtocolError where
    show :: ProtocolError -> String
show  (PEParse String
msg)           = [String] -> String
unlines [String
"Server parsing protocol error:", String
msg] 
    show (PEInvalidRequest String
msg)   = [String] -> String
unlines [String
"Invalid request protocol error:", String
msg]
    show (PEMethodNotFound String
msg)   = [String] -> String
unlines [String
"Method not found protocol error:", String
msg]
    show (PEInvalidParams String
msg)    = [String] -> String
unlines [String
"Invalid params protocol error:", String
msg]
    show (PEInternalError String
msg)    = [String] -> String
unlines [String
"Internal protocol error:", String
msg]
    show (PEServerError String
msg)      = [String] -> String
unlines [String
"Server protocol error:", String
msg]
    show (PEOther String
msg)            = [String] -> String
unlines [String
"Other protocol error:", String
msg]
instance FromJSON ProtocolError where
    parseJSON :: Value -> Parser ProtocolError
parseJSON = String
-> (Object -> Parser ProtocolError)
-> Value
-> Parser ProtocolError
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"ProtocolError" ((Object -> Parser ProtocolError) -> Value -> Parser ProtocolError)
-> (Object -> Parser ProtocolError)
-> Value
-> Parser ProtocolError
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
        Double
code <- Object
obj Object -> SessionId -> Parser Double
forall a. FromJSON a => Object -> SessionId -> Parser a
.: SessionId
"code"
        String
msg  <- Object
obj Object -> SessionId -> Parser String
forall a. FromJSON a => Object -> SessionId -> Parser a
.: SessionId
"message"
        ProtocolError -> Parser ProtocolError
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProtocolError -> Parser ProtocolError)
-> ProtocolError -> Parser ProtocolError
forall a b. (a -> b) -> a -> b
$ case (Double
code :: Double) of
            -32700 -> String -> ProtocolError
PEParse          String
msg
            -32600 -> String -> ProtocolError
PEInvalidRequest String
msg
            -32601 -> String -> ProtocolError
PEMethodNotFound String
msg
            -32602 -> String -> ProtocolError
PEInvalidParams  String
msg
            -32603 -> String -> ProtocolError
PEInternalError  String
msg
            Double
_      -> if Double
code Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> -Double
32099 Bool -> Bool -> Bool
&& Double
code Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< -Double
32000 then String -> ProtocolError
PEServerError String
msg else String -> ProtocolError
PEOther String
msg

data Error = 
    ERRNoResponse
    | ERRParse String
    | ERRProtocol ProtocolError
    deriving Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq
instance Exception Error
instance Show Error where
    show :: Error -> String
show Error
ERRNoResponse      = String
"no response received from the browser"
    show (ERRParse String
msg)     = [String] -> String
unlines [String
"error in parsing a message received from the browser:", String
msg]
    show (ERRProtocol ProtocolError
pe)   = [String] -> String
unlines [String
"error encountered by the browser:", ProtocolError -> String
forall a. Show a => a -> String
show ProtocolError
pe] 

uncapitalizeFirst :: String -> String
uncapitalizeFirst :: ShowS
uncapitalizeFirst []     = []
uncapitalizeFirst (Char
x:String
xs) = Char -> Char
toLower Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs