module TwoCaptcha.Internal.Client where
import Control.Concurrent (threadDelay)
import Control.Lens ((&), (.~), (?~), (^.), (^?))
import Control.Monad.Catch (MonadCatch, MonadThrow (throwM), try)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson.Lens (key, _Integer, _String)
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Text (Text, unpack)
import GHC.Base (Coercible, coerce)
import Network.Wreq (Response, responseBody)
import Network.Wreq.Session (Session, getWith, postWith)
import System.Clock (Clock (Monotonic), getTime, toNanoSecs)
import TwoCaptcha.Internal.Types.Captcha (Captcha, CaptchaId, CaptchaRes (CaptchaRes), HasCaptchaLenses, HasCommonCaptchaLenses (apiKey, headerACAO), PollingInterval, TimeoutDuration, captchaId, captchaRes, options, parts)
import TwoCaptcha.Internal.Types.Exception (TwoCaptchaErrorCode (CaptchaNotReady), TwoCaptchaException (NetworkException, SolvingTimeout, TwoCaptchaResponseException, UnknownError), readErrorCode)
handle :: (MonadIO m, MonadCatch m) => IO (Response ByteString) -> m Text
handle :: IO (Response ByteString) -> m Text
handle IO (Response ByteString)
method =
m (Response ByteString)
-> m (Either HttpException (Response ByteString))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Response ByteString)
method) m (Either HttpException (Response ByteString))
-> (Either HttpException (Response ByteString) -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left HttpException
exception -> TwoCaptchaException -> m Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TwoCaptchaException -> m Text) -> TwoCaptchaException -> m Text
forall a b. (a -> b) -> a -> b
$ HttpException -> TwoCaptchaException
NetworkException HttpException
exception
Right Response ByteString
response -> do
let statusRequest :: Maybe (Integer, Text)
statusRequest = do
ByteString
body <- Response ByteString
response Response ByteString
-> Getting (First ByteString) (Response ByteString) ByteString
-> Maybe ByteString
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First ByteString) (Response ByteString) ByteString
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody
Integer
status <- ByteString
body ByteString
-> Getting (First Integer) ByteString Integer -> Maybe Integer
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' ByteString Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"status" ((Value -> Const (First Integer) Value)
-> ByteString -> Const (First Integer) ByteString)
-> ((Integer -> Const (First Integer) Integer)
-> Value -> Const (First Integer) Value)
-> Getting (First Integer) ByteString Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Const (First Integer) Integer)
-> Value -> Const (First Integer) Value
forall t. AsNumber t => Prism' t Integer
_Integer
Text
request <- ByteString
body ByteString -> Getting (First Text) ByteString Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' ByteString Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"request" ((Value -> Const (First Text) Value)
-> ByteString -> Const (First Text) ByteString)
-> ((Text -> Const (First Text) Text)
-> Value -> Const (First Text) Value)
-> Getting (First Text) ByteString 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
(Integer, Text) -> Maybe (Integer, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
status, Text
request)
case Maybe (Integer, Text)
statusRequest of
Maybe (Integer, Text)
Nothing -> do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Response ByteString -> IO ()
forall a. Show a => a -> IO ()
print Response ByteString
response
TwoCaptchaException -> m Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TwoCaptchaException -> m Text) -> TwoCaptchaException -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> TwoCaptchaException
UnknownError Text
"The response is not the expected JSON. This is likely due to 2captcha changing their API."
Just (Integer
status, Text
request) -> do
if Integer
status Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
then case String -> Either ParseError TwoCaptchaErrorCode
readErrorCode (Text -> String
unpack Text
request) of
Left ParseError
_ -> TwoCaptchaException -> m Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TwoCaptchaException -> m Text) -> TwoCaptchaException -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> TwoCaptchaException
UnknownError (Text
"Invalid error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
request)
Right TwoCaptchaErrorCode
errorCode -> TwoCaptchaException -> m Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TwoCaptchaException -> m Text) -> TwoCaptchaException -> m Text
forall a b. (a -> b) -> a -> b
$ TwoCaptchaErrorCode -> TwoCaptchaException
TwoCaptchaResponseException TwoCaptchaErrorCode
errorCode
else
Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
request
class TwoCaptchaClient m where
submit :: (Coercible Captcha a, HasCaptchaLenses a, HasCommonCaptchaLenses a) => Session -> a -> m CaptchaId
answer :: Session -> CaptchaRes -> m Text
solve :: (Coercible Captcha a, HasCaptchaLenses a, HasCommonCaptchaLenses a) => PollingInterval -> TimeoutDuration -> Session -> a -> m Text
instance (MonadIO m, MonadCatch m) => TwoCaptchaClient m where
submit :: Session -> a -> m Text
submit Session
session a
captcha' = IO (Response ByteString) -> m Text
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IO (Response ByteString) -> m Text
handle (IO (Response ByteString) -> m Text)
-> IO (Response ByteString) -> m Text
forall a b. (a -> b) -> a -> b
$ Options -> Session -> String -> [Part] -> IO (Response ByteString)
forall a.
Postable a =>
Options -> Session -> String -> a -> IO (Response ByteString)
postWith (Captcha
captcha Captcha -> Getting Options Captcha Options -> Options
forall s a. s -> Getting a s a -> a
^. Getting Options Captcha Options
Lens' Captcha Options
options) Session
session String
"https://2captcha.com/in.php" (Captcha
captcha Captcha -> Getting [Part] Captcha [Part] -> [Part]
forall s a. s -> Getting a s a -> a
^. Getting [Part] Captcha [Part]
Getter Captcha [Part]
parts)
where
captcha :: Captcha
captcha = a -> Captcha
coerce a
captcha'
answer :: Session -> CaptchaRes -> m Text
answer Session
session (CaptchaRes Captcha
captchaRes) = IO (Response ByteString) -> m Text
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IO (Response ByteString) -> m Text
handle (IO (Response ByteString) -> m Text)
-> IO (Response ByteString) -> m Text
forall a b. (a -> b) -> a -> b
$ Options -> Session -> String -> IO (Response ByteString)
getWith (Captcha
captchaRes Captcha -> Getting Options Captcha Options -> Options
forall s a. s -> Getting a s a -> a
^. Getting Options Captcha Options
Lens' Captcha Options
options) Session
session String
"https://2captcha.com/res.php"
solve :: PollingInterval -> Integer -> Session -> a -> m Text
solve PollingInterval
pollingInterval Integer
timeoutDuration Session
session a
captcha = do
Text
captchaId' <- Session -> a -> m Text
forall (m :: * -> *) a.
(TwoCaptchaClient m, Coercible Captcha a, HasCaptchaLenses a,
HasCommonCaptchaLenses a) =>
Session -> a -> m Text
submit Session
session a
captcha
let captchaRes' :: CaptchaRes
captchaRes' =
CaptchaRes
captchaRes
CaptchaRes -> (CaptchaRes -> CaptchaRes) -> CaptchaRes
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> CaptchaRes -> Identity CaptchaRes
forall a. HasCommonCaptchaLenses a => Lens' a (Maybe Text)
apiKey ((Maybe Text -> Identity (Maybe Text))
-> CaptchaRes -> Identity CaptchaRes)
-> Maybe Text -> CaptchaRes -> CaptchaRes
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (a
captcha a -> Getting (Maybe Text) a (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) a (Maybe Text)
forall a. HasCommonCaptchaLenses a => Lens' a (Maybe Text)
apiKey)
CaptchaRes -> (CaptchaRes -> CaptchaRes) -> CaptchaRes
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool))
-> CaptchaRes -> Identity CaptchaRes
forall a. HasCommonCaptchaLenses a => Lens' a (Maybe Bool)
headerACAO ((Maybe Bool -> Identity (Maybe Bool))
-> CaptchaRes -> Identity CaptchaRes)
-> Maybe Bool -> CaptchaRes -> CaptchaRes
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (a
captcha a -> Getting (Maybe Bool) a (Maybe Bool) -> Maybe Bool
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Bool) a (Maybe Bool)
forall a. HasCommonCaptchaLenses a => Lens' a (Maybe Bool)
headerACAO)
CaptchaRes -> (CaptchaRes -> CaptchaRes) -> CaptchaRes
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> CaptchaRes -> Identity CaptchaRes
Lens' CaptchaRes (Maybe Text)
captchaId ((Maybe Text -> Identity (Maybe Text))
-> CaptchaRes -> Identity CaptchaRes)
-> Text -> CaptchaRes -> CaptchaRes
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
captchaId'
let time :: m Integer
time = IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> m Integer) -> IO Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ (\TimeSpec
t -> TimeSpec -> Integer
toNanoSecs TimeSpec
t Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000000) (TimeSpec -> Integer) -> IO TimeSpec -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
getTime Clock
Monotonic
Integer
startTime <- m Integer
time
let pollAnswer :: Integer -> Integer -> m Text
pollAnswer Integer
previousTime Integer
currentTime =
if Integer
currentTime Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
previousTime Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
timeoutDuration
then TwoCaptchaException -> m Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM TwoCaptchaException
SolvingTimeout
else do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ PollingInterval -> IO ()
threadDelay (PollingInterval
pollingInterval PollingInterval -> PollingInterval -> PollingInterval
forall a. Num a => a -> a -> a
* PollingInterval
1000)
Either TwoCaptchaException Text
answerAttempt <- m Text -> m (Either TwoCaptchaException Text)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m Text -> m (Either TwoCaptchaException Text))
-> m Text -> m (Either TwoCaptchaException Text)
forall a b. (a -> b) -> a -> b
$ Session -> CaptchaRes -> m Text
forall (m :: * -> *).
TwoCaptchaClient m =>
Session -> CaptchaRes -> m Text
answer Session
session CaptchaRes
captchaRes'
case Either TwoCaptchaException Text
answerAttempt of
Left (TwoCaptchaResponseException TwoCaptchaErrorCode
CaptchaNotReady) -> do
Integer
updatedTime <- m Integer
time
Integer -> Integer -> m Text
pollAnswer Integer
currentTime Integer
updatedTime
Left TwoCaptchaException
exception -> TwoCaptchaException -> m Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM TwoCaptchaException
exception
Right Text
answer -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
answer
Integer -> Integer -> m Text
pollAnswer Integer
startTime Integer
startTime