{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module: Captcha.CapMonster.Internal
-- Copyright: (c) 2022 Edward Yang
-- License: MIT
--
-- This module is for internal-use and does not follow pvp versioning policies.
module Captcha.CapMonster.Internal where

import Captcha.CapMonster.Internal.Error (CapMonsterError (CapMonsterResponseError, NetworkError, TimeoutError, UnknownError, UnknownResponseError), CapMonsterErrorCode (CaptchaNotReady))
import qualified Captcha.CapMonster.Internal.Error as CapMonsterError
import Captcha.Internal.Monad (HasCaptchaEnv)
import Captcha.Internal.Monad.Class (CaptchaId (CaptchaId, unCaptchaId), CaptchaRequest (request), CaptchaResponse (parseResult), MonadCaptcha (CaptchaError, createTask, getTask, solve))
import Captcha.Internal.Request (post)
import Captcha.Internal.Types (HasApiKey (apiKey), HasPollingInterval (pollingInterval), HasTimeoutDuration (timeoutDuration))
import Control.Error (note)
import Control.Lens (preview, view, (^.), (^?))
import Control.Monad ((<=<))
import Control.Monad.Except (ExceptT (ExceptT), runExceptT)
import Control.Monad.Reader (MonadReader)
import Data.Aeson (Value)
import Data.Aeson.Lens (key, _Integer, _String, _Value)
import Data.Aeson.QQ (aesonQQ)
import Data.Bifunctor (Bifunctor (bimap))
import Data.ByteString.Lazy (ByteString)
import Data.Either.Extra (fromEither)
import Data.Maybe (fromMaybe)
import Data.String.Interpolate (i, iii)
import Data.Text (Text)
import Network.HTTP.Client (HttpException)
import Network.Wreq (Response, defaults, responseBody)
import Time (Microsecond, Millisecond, Time (Time), toNum)
import Time.Units (threadDelay)
import UnliftIO (MonadUnliftIO, timeout, try)

-- | Used for picking 'MonadCaptcha' instances for CapMonster.
data CapMonster

-- | Parse the http response into the captcha answer, handling any errors found.
parseResponse :: (Value -> Maybe Value) -> Either HttpException (Response ByteString) -> Either CapMonsterError Value
parseResponse :: (Value -> Maybe Value)
-> Either HttpException (Response ByteString)
-> Either CapMonsterError Value
parseResponse Value -> Maybe Value
f Either HttpException (Response ByteString)
response =
  ((Either CapMonsterError Value
 -> (Value -> Either CapMonsterError Value)
 -> Maybe Value
 -> Either CapMonsterError Value)
-> (Value -> Either CapMonsterError Value)
-> Either CapMonsterError Value
-> Maybe Value
-> Either CapMonsterError Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Either CapMonsterError Value
-> (Value -> Either CapMonsterError Value)
-> Maybe Value
-> Either CapMonsterError Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value -> Either CapMonsterError Value
forall a b. b -> Either a b
Right (Either CapMonsterError Value
 -> Maybe Value -> Either CapMonsterError Value)
-> (Value -> Either CapMonsterError Value)
-> Value
-> Maybe Value
-> Either CapMonsterError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CapMonsterError -> Either CapMonsterError Value
forall a b. a -> Either a b
Left (CapMonsterError -> Either CapMonsterError Value)
-> (Value -> CapMonsterError)
-> Value
-> Either CapMonsterError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Value -> CapMonsterError
forall s. AsValue s => Maybe s -> CapMonsterError
parseError (Maybe Value -> CapMonsterError)
-> (Value -> Maybe Value) -> Value -> CapMonsterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just) (Value -> Maybe Value -> Either CapMonsterError Value)
-> (Value -> Maybe Value) -> Value -> Either CapMonsterError Value
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe Value
f (Value -> Either CapMonsterError Value)
-> Either CapMonsterError Value -> Either CapMonsterError Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either CapMonsterError Value
parseBody
  where
    missingResponse :: Text
missingResponse =
      [iii|
        The response body is missing.
        This is likely due to a change in CapMonster's API and will need to be fixed.
      |]
    readError :: Maybe s -> Maybe (Text, Text)
readError Maybe s
responseBody = do
      s
body <- Maybe s
responseBody
      Text
code <- s
body s -> Getting (First Text) s Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' s Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"errorCode" ((Value -> Const (First Text) Value) -> s -> Const (First Text) s)
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> Getting (First Text) s Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Value -> Const (First Text) Value
forall t. AsPrimitive t => Prism' t Text
_String
      Text
description <- s
body s -> Getting (First Text) s Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' s Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"errorDescription" ((Value -> Const (First Text) Value) -> s -> Const (First Text) s)
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> Getting (First Text) s Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Value -> Const (First Text) Value
forall t. AsPrimitive t => Prism' t Text
_String
      (Text, Text) -> Maybe (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
code, Text
description)
    parseError :: Maybe s -> CapMonsterError
parseError Maybe s
responseBody = Either CapMonsterError CapMonsterError -> CapMonsterError
forall a. Either a a -> a
fromEither (Either CapMonsterError CapMonsterError -> CapMonsterError)
-> Either CapMonsterError CapMonsterError -> CapMonsterError
forall a b. (a -> b) -> a -> b
$ do
      (Text
code, Text
description) <- CapMonsterError
-> Maybe (Text, Text) -> Either CapMonsterError (Text, Text)
forall a b. a -> Maybe b -> Either a b
note (CapMonsterErrorCode -> CapMonsterError
CapMonsterResponseError CapMonsterErrorCode
CaptchaNotReady) (Maybe s -> Maybe (Text, Text)
forall s. AsValue s => Maybe s -> Maybe (Text, Text)
readError Maybe s
responseBody)
      CapMonsterError
-> Maybe CapMonsterError -> Either CapMonsterError CapMonsterError
forall a b. a -> Maybe b -> Either a b
note (Text -> Text -> CapMonsterError
UnknownResponseError Text
code Text
description) (CapMonsterErrorCode -> CapMonsterError
CapMonsterResponseError (CapMonsterErrorCode -> CapMonsterError)
-> Maybe CapMonsterErrorCode -> Maybe CapMonsterError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe CapMonsterErrorCode
CapMonsterError.parseError Text
code)
    parseBody :: Either CapMonsterError Value
parseBody = CapMonsterError -> Maybe Value -> Either CapMonsterError Value
forall a b. a -> Maybe b -> Either a b
note (Text -> CapMonsterError
UnknownError Text
missingResponse) (Maybe Value -> Either CapMonsterError Value)
-> Either CapMonsterError (Maybe Value)
-> Either CapMonsterError Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (HttpException -> CapMonsterError)
-> (Response ByteString -> Maybe Value)
-> Either HttpException (Response ByteString)
-> Either CapMonsterError (Maybe Value)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap HttpException -> CapMonsterError
NetworkError (Getting (First Value) (Response ByteString) Value
-> Response ByteString -> Maybe Value
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Getting (First Value) (Response ByteString) Value
 -> Response ByteString -> Maybe Value)
-> Getting (First Value) (Response ByteString) Value
-> Response ByteString
-> Maybe Value
forall a b. (a -> b) -> a -> b
$ (ByteString -> Const (First Value) ByteString)
-> Response ByteString -> Const (First Value) (Response ByteString)
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody ((ByteString -> Const (First Value) ByteString)
 -> Response ByteString
 -> Const (First Value) (Response ByteString))
-> ((Value -> Const (First Value) Value)
    -> ByteString -> Const (First Value) ByteString)
-> Getting (First Value) (Response ByteString) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Value) Value)
-> ByteString -> Const (First Value) ByteString
forall t. AsValue t => Prism' t Value
_Value) Either HttpException (Response ByteString)
response

instance (HasCaptchaEnv r, MonadReader r m, MonadUnliftIO m) => MonadCaptcha CapMonster r m where
  type CaptchaError CapMonster r m = CapMonsterError

  createTask :: forall ctx. CaptchaRequest CapMonster ctx r m => ctx -> m (Either CapMonsterError (CaptchaId ctx))
  createTask :: ctx -> m (Either CapMonsterError (CaptchaId ctx))
createTask ctx
captcha =
    (Value -> Either CapMonsterError (CaptchaId ctx)
forall s ctx.
(Interpolatable 'True s Text, AsNumber s) =>
s -> Either CapMonsterError (CaptchaId ctx)
parseCaptchaId (Value -> Either CapMonsterError (CaptchaId ctx))
-> (Either HttpException (Response ByteString)
    -> Either CapMonsterError Value)
-> Either HttpException (Response ByteString)
-> Either CapMonsterError (CaptchaId ctx)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Value -> Maybe Value)
-> Either HttpException (Response ByteString)
-> Either CapMonsterError Value
parseResponse (Getting (First Value) Value Value -> Value -> Maybe Value
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Getting (First Value) Value Value -> Value -> Maybe Value)
-> Getting (First Value) Value Value -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"taskId")) (Either HttpException (Response ByteString)
 -> Either CapMonsterError (CaptchaId ctx))
-> m (Either HttpException (Response ByteString))
-> m (Either CapMonsterError (CaptchaId ctx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Response ByteString)
-> m (Either HttpException (Response ByteString))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (ctx -> Text -> m (Response ByteString)
forall api ctx r (m :: * -> *).
CaptchaRequest api ctx r m =>
ctx -> Text -> m (Response ByteString)
request @CapMonster @ctx @r @m ctx
captcha Text
url)
    where
      url :: Text
url = Text
"https://api.capmonster.cloud/createTask"
      parseCaptchaId :: s -> Either CapMonsterError (CaptchaId ctx)
parseCaptchaId s
captchaId =
        Integer -> CaptchaId ctx
forall ctx. Integer -> CaptchaId ctx
CaptchaId (Integer -> CaptchaId ctx)
-> Either CapMonsterError Integer
-> Either CapMonsterError (CaptchaId ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CapMonsterError -> Maybe Integer -> Either CapMonsterError Integer
forall a b. a -> Maybe b -> Either a b
note (Text -> CapMonsterError
UnknownError [i|CaptchaId is not an Integer: #{captchaId}|]) (s
captchaId s -> Getting (First Integer) s Integer -> Maybe Integer
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First Integer) s Integer
forall t. AsNumber t => Prism' t Integer
_Integer)

  getTask :: forall ctx. CaptchaResponse CapMonster ctx => Text -> CaptchaId ctx -> m (Either CapMonsterError Text)
  getTask :: Text -> CaptchaId ctx -> m (Either CapMonsterError Text)
getTask Text
apiKey CaptchaId ctx
captchaId =
    (Value -> Text)
-> Either CapMonsterError Value -> Either CapMonsterError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting Text Value Text -> Value -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Value Text
forall t. AsPrimitive t => Prism' t Text
_String) (Either CapMonsterError Value -> Either CapMonsterError Text)
-> (Either HttpException (Response ByteString)
    -> Either CapMonsterError Value)
-> Either HttpException (Response ByteString)
-> Either CapMonsterError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Maybe Value)
-> Either HttpException (Response ByteString)
-> Either CapMonsterError Value
parseResponse (CaptchaResponse CapMonster ctx => Value -> Maybe Value
forall api ctx. CaptchaResponse api ctx => Value -> Maybe Value
parseResult @CapMonster @ctx) (Either HttpException (Response ByteString)
 -> Either CapMonsterError Text)
-> m (Either HttpException (Response ByteString))
-> m (Either CapMonsterError Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Response ByteString)
-> m (Either HttpException (Response ByteString))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Options -> Text -> Value -> m (Response ByteString)
forall r (m :: * -> *) a.
(HasCaptchaEnv r, MonadReader r m, MonadIO m, Postable a) =>
Options -> Text -> a -> m (Response ByteString)
post Options
defaults Text
url Value
payload)
    where
      url :: Text
url = Text
"https://api.capmonster.cloud/getTaskResult"
      payload :: Value
payload =
        [aesonQQ|
          {
            clientKey: #{apiKey},
            taskId: #{unCaptchaId captchaId}
          }
        |]

  solve ::
    forall ctx.
    ( CaptchaRequest CapMonster ctx r m,
      CaptchaResponse CapMonster ctx,
      HasApiKey ctx Text,
      HasPollingInterval ctx (Maybe (Time Millisecond)),
      HasTimeoutDuration ctx (Maybe (Time Millisecond))
    ) =>
    ctx ->
    m (Either CapMonsterError Text)
  solve :: ctx -> m (Either CapMonsterError Text)
solve ctx
captcha =
    Maybe (Time (1 :% 1000))
-> m (Either CapMonsterError Text)
-> m (Either CapMonsterError Text)
forall (f :: * -> *) (unit :: Rat) b.
(MonadUnliftIO f, KnownRat unit,
 KnownRat (DivRat unit (1 :% 1000000))) =>
Maybe (Time unit)
-> f (Either CapMonsterError b) -> f (Either CapMonsterError b)
handleTimeout (ctx
captcha ctx
-> Getting
     (Maybe (Time (1 :% 1000))) ctx (Maybe (Time (1 :% 1000)))
-> Maybe (Time (1 :% 1000))
forall s a. s -> Getting a s a -> a
^. Getting (Maybe (Time (1 :% 1000))) ctx (Maybe (Time (1 :% 1000)))
forall s a. HasTimeoutDuration s a => Lens' s a
timeoutDuration) (m (Either CapMonsterError Text)
 -> m (Either CapMonsterError Text))
-> (ExceptT CapMonsterError m Text
    -> m (Either CapMonsterError Text))
-> ExceptT CapMonsterError m Text
-> m (Either CapMonsterError Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT CapMonsterError m Text -> m (Either CapMonsterError Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CapMonsterError m Text -> m (Either CapMonsterError Text))
-> ExceptT CapMonsterError m Text
-> m (Either CapMonsterError Text)
forall a b. (a -> b) -> a -> b
$
      m (Either CapMonsterError Text) -> ExceptT CapMonsterError m Text
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either CapMonsterError Text) -> ExceptT CapMonsterError m Text)
-> (CaptchaId ctx -> m (Either CapMonsterError Text))
-> CaptchaId ctx
-> ExceptT CapMonsterError m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaptchaId ctx -> m (Either CapMonsterError Text)
pollResult (CaptchaId ctx -> ExceptT CapMonsterError m Text)
-> ExceptT CapMonsterError m (CaptchaId ctx)
-> ExceptT CapMonsterError m Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either CapMonsterError (CaptchaId ctx))
-> ExceptT CapMonsterError m (CaptchaId ctx)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ctx -> m (Either (CaptchaError CapMonster r m) (CaptchaId ctx))
forall api r (m :: * -> *) ctx.
(MonadCaptcha api r m, CaptchaRequest api ctx r m) =>
ctx -> m (Either (CaptchaError api r m) (CaptchaId ctx))
createTask @CapMonster @r @m ctx
captcha)
    where
      handleTimeout :: Maybe (Time unit)
-> f (Either CapMonsterError b) -> f (Either CapMonsterError b)
handleTimeout (Just Time unit
duration) f (Either CapMonsterError b)
f = Either CapMonsterError b
-> Maybe (Either CapMonsterError b) -> Either CapMonsterError b
forall a. a -> Maybe a -> a
fromMaybe (CapMonsterError -> Either CapMonsterError b
forall a b. a -> Either a b
Left CapMonsterError
TimeoutError) (Maybe (Either CapMonsterError b) -> Either CapMonsterError b)
-> f (Maybe (Either CapMonsterError b))
-> f (Either CapMonsterError b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> f (Either CapMonsterError b)
-> f (Maybe (Either CapMonsterError b))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Time unit -> Int
forall (unitTo :: Rat) n (unit :: Rat).
(KnownDivRat unit unitTo, Num n) =>
Time unit -> n
toNum @Microsecond Time unit
duration) f (Either CapMonsterError b)
f
      handleTimeout Maybe (Time unit)
Nothing f (Either CapMonsterError b)
f = f (Either CapMonsterError b)
f
      pollResult :: CaptchaId ctx -> m (Either CapMonsterError Text)
pollResult CaptchaId ctx
captchaId =
        Time (1 :% 1000) -> m ()
forall (unit :: Rat) (m :: * -> *).
(KnownDivRat unit Microsecond, MonadIO m) =>
Time unit -> m ()
threadDelay (Time (1 :% 1000) -> Maybe (Time (1 :% 1000)) -> Time (1 :% 1000)
forall a. a -> Maybe a -> a
fromMaybe (RatioNat -> Time Millisecond
forall (rat :: Rat). RatioNat -> Time rat
Time @Millisecond RatioNat
10_000) (ctx
captcha ctx
-> Getting
     (Maybe (Time (1 :% 1000))) ctx (Maybe (Time (1 :% 1000)))
-> Maybe (Time (1 :% 1000))
forall s a. s -> Getting a s a -> a
^. Getting (Maybe (Time (1 :% 1000))) ctx (Maybe (Time (1 :% 1000)))
forall s a. HasPollingInterval s a => Lens' s a
pollingInterval))
          m ()
-> m (Either CapMonsterError Text)
-> m (Either CapMonsterError Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text
-> CaptchaId ctx -> m (Either (CaptchaError CapMonster r m) Text)
forall api r (m :: * -> *) ctx.
(MonadCaptcha api r m, CaptchaResponse api ctx) =>
Text -> CaptchaId ctx -> m (Either (CaptchaError api r m) Text)
getTask @CapMonster @r @m @ctx (ctx
captcha ctx -> Getting Text ctx Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ctx Text
forall s a. HasApiKey s a => Lens' s a
apiKey) CaptchaId ctx
captchaId
          m (Either CapMonsterError Text)
-> (Either CapMonsterError Text -> m (Either CapMonsterError Text))
-> m (Either CapMonsterError Text)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left (CapMonsterResponseError CapMonsterErrorCode
CaptchaNotReady) -> CaptchaId ctx -> m (Either CapMonsterError Text)
pollResult CaptchaId ctx
captchaId
            Either CapMonsterError Text
x -> Either CapMonsterError Text -> m (Either CapMonsterError Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either CapMonsterError Text
x