{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-|

This module contains the 'WD' monad, which serves as an example of how to use
this library in a standalone fashion.

For more complex usage, you'll probably want to skip this module and write
'WebDriverBase' and 'SessionState' instances for your own monads.

You can find a full example in the project repo at
<https://github.com/haskell-webdriver/haskell-webdriver/blob/main/app/Main.hs>.

-}

module Test.WebDriver.WD (
  WD(..)
  , runWD
  ) where

import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Reader
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.String.Interpolate
import qualified Data.Text as T
import qualified Network.HTTP.Client as HC
import Network.HTTP.Types.Status as N
import Test.WebDriver
import Test.WebDriver.Types
import UnliftIO.Exception

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as A
import qualified Data.Aeson.KeyMap as KM

aesonLookup :: T.Text -> KM.KeyMap v -> Maybe v
aesonLookup :: forall v. Text -> KeyMap v -> Maybe v
aesonLookup = Key -> KeyMap v -> Maybe v
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Key -> KeyMap v -> Maybe v)
-> (Text -> Key) -> Text -> KeyMap v -> Maybe v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
A.fromText
#else
import qualified Data.HashMap.Strict as HM

aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v
aesonLookup = HM.lookup
#endif

newtype WD a = WD (ReaderT Session (LoggingT IO) a)
  deriving ((forall a b. (a -> b) -> WD a -> WD b)
-> (forall a b. a -> WD b -> WD a) -> Functor WD
forall a b. a -> WD b -> WD a
forall a b. (a -> b) -> WD a -> WD b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> WD a -> WD b
fmap :: forall a b. (a -> b) -> WD a -> WD b
$c<$ :: forall a b. a -> WD b -> WD a
<$ :: forall a b. a -> WD b -> WD a
Functor, Functor WD
Functor WD =>
(forall a. a -> WD a)
-> (forall a b. WD (a -> b) -> WD a -> WD b)
-> (forall a b c. (a -> b -> c) -> WD a -> WD b -> WD c)
-> (forall a b. WD a -> WD b -> WD b)
-> (forall a b. WD a -> WD b -> WD a)
-> Applicative WD
forall a. a -> WD a
forall a b. WD a -> WD b -> WD a
forall a b. WD a -> WD b -> WD b
forall a b. WD (a -> b) -> WD a -> WD b
forall a b c. (a -> b -> c) -> WD a -> WD b -> WD c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> WD a
pure :: forall a. a -> WD a
$c<*> :: forall a b. WD (a -> b) -> WD a -> WD b
<*> :: forall a b. WD (a -> b) -> WD a -> WD b
$cliftA2 :: forall a b c. (a -> b -> c) -> WD a -> WD b -> WD c
liftA2 :: forall a b c. (a -> b -> c) -> WD a -> WD b -> WD c
$c*> :: forall a b. WD a -> WD b -> WD b
*> :: forall a b. WD a -> WD b -> WD b
$c<* :: forall a b. WD a -> WD b -> WD a
<* :: forall a b. WD a -> WD b -> WD a
Applicative, Applicative WD
Applicative WD =>
(forall a b. WD a -> (a -> WD b) -> WD b)
-> (forall a b. WD a -> WD b -> WD b)
-> (forall a. a -> WD a)
-> Monad WD
forall a. a -> WD a
forall a b. WD a -> WD b -> WD b
forall a b. WD a -> (a -> WD b) -> WD b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. WD a -> (a -> WD b) -> WD b
>>= :: forall a b. WD a -> (a -> WD b) -> WD b
$c>> :: forall a b. WD a -> WD b -> WD b
>> :: forall a b. WD a -> WD b -> WD b
$creturn :: forall a. a -> WD a
return :: forall a. a -> WD a
Monad, Monad WD
Monad WD => (forall a. IO a -> WD a) -> MonadIO WD
forall a. IO a -> WD a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> WD a
liftIO :: forall a. IO a -> WD a
MonadIO, Monad WD
Monad WD =>
(forall e a. (HasCallStack, Exception e) => e -> WD a)
-> MonadThrow WD
forall e a. (HasCallStack, Exception e) => e -> WD a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> WD a
throwM :: forall e a. (HasCallStack, Exception e) => e -> WD a
MonadThrow, MonadThrow WD
MonadThrow WD =>
(forall e a.
 (HasCallStack, Exception e) =>
 WD a -> (e -> WD a) -> WD a)
-> MonadCatch WD
forall e a.
(HasCallStack, Exception e) =>
WD a -> (e -> WD a) -> WD a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
WD a -> (e -> WD a) -> WD a
catch :: forall e a.
(HasCallStack, Exception e) =>
WD a -> (e -> WD a) -> WD a
MonadCatch, MonadCatch WD
MonadCatch WD =>
(forall b.
 HasCallStack =>
 ((forall a. WD a -> WD a) -> WD b) -> WD b)
-> (forall b.
    HasCallStack =>
    ((forall a. WD a -> WD a) -> WD b) -> WD b)
-> (forall a b c.
    HasCallStack =>
    WD a -> (a -> ExitCase b -> WD c) -> (a -> WD b) -> WD (b, c))
-> MonadMask WD
forall b.
HasCallStack =>
((forall a. WD a -> WD a) -> WD b) -> WD b
forall a b c.
HasCallStack =>
WD a -> (a -> ExitCase b -> WD c) -> (a -> WD b) -> WD (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. WD a -> WD a) -> WD b) -> WD b
mask :: forall b.
HasCallStack =>
((forall a. WD a -> WD a) -> WD b) -> WD b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. WD a -> WD a) -> WD b) -> WD b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. WD a -> WD a) -> WD b) -> WD b
$cgeneralBracket :: forall a b c.
HasCallStack =>
WD a -> (a -> ExitCase b -> WD c) -> (a -> WD b) -> WD (b, c)
generalBracket :: forall a b c.
HasCallStack =>
WD a -> (a -> ExitCase b -> WD c) -> (a -> WD b) -> WD (b, c)
MonadMask, MonadIO WD
MonadIO WD =>
(forall b. ((forall a. WD a -> IO a) -> IO b) -> WD b)
-> MonadUnliftIO WD
forall b. ((forall a. WD a -> IO a) -> IO b) -> WD b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b. ((forall a. WD a -> IO a) -> IO b) -> WD b
withRunInIO :: forall b. ((forall a. WD a -> IO a) -> IO b) -> WD b
MonadUnliftIO, MonadReader Session, Monad WD
Monad WD =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> WD ())
-> MonadLogger WD
forall msg. ToLogStr msg => Loc -> Text -> LogLevel -> msg -> WD ()
forall (m :: * -> *).
Monad m =>
(forall msg.
 ToLogStr msg =>
 Loc -> Text -> LogLevel -> msg -> m ())
-> MonadLogger m
$cmonadLoggerLog :: forall msg. ToLogStr msg => Loc -> Text -> LogLevel -> msg -> WD ()
monadLoggerLog :: forall msg. ToLogStr msg => Loc -> Text -> LogLevel -> msg -> WD ()
MonadLogger)

doCommandBaseWithLogging :: (
  MonadLogger m, MonadUnliftIO m, A.ToJSON p
  ) => Driver -> Method -> T.Text -> p -> m (HC.Response BL.ByteString)
doCommandBaseWithLogging :: forall (m :: * -> *) p.
(MonadLogger m, MonadUnliftIO m, ToJSON p) =>
Driver -> Method -> Text -> p -> m (Response ByteString)
doCommandBaseWithLogging Driver
driver Method
method Text
path p
args = do
  let req :: Request
req = Driver -> Method -> Text -> p -> Request
forall a. ToJSON a => Driver -> Method -> Text -> a -> Request
mkDriverRequest Driver
driver Method
method Text
path p
args
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|--> #{HC.method req} #{HC.path req}#{HC.queryString req} (#{showRequestBody (HC.requestBody req)})|]
  Response ByteString
response <- m (Response ByteString)
-> m (Either SomeException (Response ByteString))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (IO (Response ByteString) -> m (Response ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HC.httpLbs Request
req (Driver -> Manager
_driverManager Driver
driver)) m (Either SomeException (Response ByteString))
-> (Either SomeException (Response ByteString)
    -> m (Response ByteString))
-> m (Response ByteString)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> m (Response ByteString))
-> (Response ByteString -> m (Response ByteString))
-> Either SomeException (Response ByteString)
-> m (Response ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m (Response ByteString)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO Response ByteString -> m (Response ByteString)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
  let (N.Status Int
code Method
_) = Response ByteString -> Status
forall body. Response body -> Status
HC.responseStatus Response ByteString
response

  if | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300 -> case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
HC.responseBody Response ByteString
response) of
         -- For successful responses, try to pull out the "value" and show it
         Right (A.Object (Text -> Object -> Maybe Value
forall v. Text -> KeyMap v -> Maybe v
aesonLookup Text
"value" -> Just Value
value)) -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|<-- #{code} #{A.encode value}|]
         Either String Value
_ -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|<-- #{code} #{HC.responseBody response}|]
     -- For non-successful responses, log the entire response.
     -- Reading the WebDriver spec, it would probably be sufficient to just show the "value" as above,
     -- plus the HTTP status message.
     | Bool
otherwise -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|<-- #{code} #{response}|]
  Response ByteString -> m (Response ByteString)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Response ByteString
response

  where
    showRequestBody :: HC.RequestBody -> B.ByteString
    showRequestBody :: RequestBody -> Method
showRequestBody (HC.RequestBodyLBS ByteString
bytes) = ByteString -> Method
BL.toStrict ByteString
bytes
    showRequestBody (HC.RequestBodyBS Method
bytes) = Method
bytes
    showRequestBody RequestBody
_ = Method
"<request body>"

instance WebDriverBase WD where
  doCommandBase :: forall a.
(HasCallStack, ToJSON a) =>
Driver -> Method -> Text -> a -> WD (Response ByteString)
doCommandBase = Driver -> Method -> Text -> a -> WD (Response ByteString)
forall (m :: * -> *) p.
(MonadLogger m, MonadUnliftIO m, ToJSON p) =>
Driver -> Method -> Text -> p -> m (Response ByteString)
doCommandBaseWithLogging

instance WebDriverBase (LoggingT IO) where
  doCommandBase :: forall a.
(HasCallStack, ToJSON a) =>
Driver -> Method -> Text -> a -> LoggingT IO (Response ByteString)
doCommandBase = Driver -> Method -> Text -> a -> LoggingT IO (Response ByteString)
forall (m :: * -> *) p.
(MonadLogger m, MonadUnliftIO m, ToJSON p) =>
Driver -> Method -> Text -> p -> m (Response ByteString)
doCommandBaseWithLogging

instance SessionState WD where
  getSession :: WD Session
getSession = WD Session
forall r (m :: * -> *). MonadReader r m => m r
ask

-- The following is a more general SessionState for MonadReader monads, but it
-- requires UndecidableInstances
-- class HasSession a where
--   extractSession :: a -> Session
-- instance HasSession Session where
--   extractSession = id
-- instance (HasSession a, MonadReader a m) => SessionState m where
--   getSession = asks extractSession

runWD :: Session -> WD a -> LoggingT IO a
runWD :: forall a. Session -> WD a -> LoggingT IO a
runWD Session
sess (WD ReaderT Session (LoggingT IO) a
wd) = ReaderT Session (LoggingT IO) a -> Session -> LoggingT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Session (LoggingT IO) a
wd Session
sess