module Text.Recognition.Antigate
(ApiKey
,api_key
,api_host
,CaptchaID
,CaptchaConf(..)
,ApiResult(..)
,SolveException(..)
,SolveConf(..)
,Phase(..)
,solveCaptcha
,solveCaptchaFromFile
,uploadCaptcha
,uploadCaptchaFromFile
,checkCaptcha
,checkCaptchas
,reportBad
,getBalance
,Manager
,newManager
,closeManager
,withManager
,parseUploadResponse
,parseCheckResponse
,parseMultiCheckResponse
,parseMultiCheckResponses
,renderApiResult
) where
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Encoding.Error as TEE
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Lazy.Char8()
import Network.HTTP.Conduit hiding (httpLbs)
import qualified Network.HTTP.Conduit as HC
import Network.HTTP.Client.MultipartFormData
import Control.Concurrent (threadDelay)
import Control.Exception (Exception, throwIO)
import Data.Typeable (Typeable)
import Control.Failure
import Control.Monad.IO.Class
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<$))
import Data.Default (Default(..))
import Data.List (stripPrefix, isPrefixOf, isInfixOf, intercalate)
import Data.Maybe (catMaybes, fromMaybe)
import Data.String (IsString(..))
import Data.Word (Word)
import Safe (readMay)
import Text.Printf (printf)
import Control.DeepSeq (NFData(..), deepseq)
__RESPONSE_TIMEOUT :: Int
__RESPONSE_TIMEOUT = 15000000
decodeUtf8 :: BL.ByteString -> TL.Text
decodeUtf8 = TLE.decodeUtf8With TEE.lenientDecode
httpLbs :: MonadIO m => Request -> Manager -> m (Response BL.ByteString)
httpLbs r = HC.httpLbs r{responseTimeout=Just __RESPONSE_TIMEOUT}
httpGet :: (Failure HttpException m, MonadIO m) => Manager -> String -> m BL.ByteString
httpGet m u = do
rq <- parseUrl u
responseBody `liftM` httpLbs rq m
charDelimit :: Char -> String -> [String]
charDelimit _ [] = []
charDelimit a b =
case break (==a) b of
(c, []) -> [c]
(c, (_:d)) -> c : charDelimit a d
data ApiKey = ApiKey
{api_host :: String
,api_key :: String
}
deriving (Eq, Ord, Show, Read)
instance Default ApiKey where
def = ApiKey
{api_host = "antigate.com"
,api_key = "API KEY IS UNSET"
}
instance IsString ApiKey where
fromString str = ApiKey
{api_host = "antigate.com"
,api_key = str}
instance NFData ApiKey where
rnf (ApiKey h k) = h `deepseq` k `deepseq` ()
type CaptchaID = Int
data CaptchaConf = CaptchaConf
{phrase :: Bool
,regsense :: Bool
,numeric :: Maybe Bool
,calc :: Bool
,min_len :: Word
,max_len :: Word
,is_russian :: Bool
,max_bid :: Maybe Double
}
deriving (Show, Read)
data ApiResult a
= OK a
| CAPCHA_NOT_READY
| ERROR_WRONG_USER_KEY
| ERROR_WRONG_ID_FORMAT
| ERROR_KEY_DOES_NOT_EXIST
| ERROR_ZERO_BALANCE
| ERROR_NO_SLOT_AVAILABLE
| ERROR_ZERO_CAPTCHA_FILESIZE
| ERROR_TOO_BIG_CAPTCHA_FILESIZE
| ERROR_WRONG_FILE_EXTENSION
| ERROR_IMAGE_TYPE_NOT_SUPPORTED
| ERROR_IP_NOT_ALLOWED
| ERROR_UNKNOWN String
deriving (Show, Read, Eq, Functor)
instance Default CaptchaConf where
def = CaptchaConf
{phrase = False
,regsense = False
,numeric = Nothing
,calc = False
,min_len = 0
,max_len = 0
,is_russian = False
,max_bid = Nothing
}
instance NFData CaptchaConf where
rnf (CaptchaConf a b c d e f g h) =
a `deepseq` b `deepseq`
c `deepseq` d `deepseq`
e `deepseq` f `deepseq`
g `deepseq` h `deepseq` ()
instance NFData a => NFData (ApiResult a) where
rnf (OK a) = a `deepseq` ()
rnf x = x `seq` ()
hostExt :: String -> String
hostExt host
| "pixodrom.com" `isInfixOf` host = "aspx"
| otherwise = "php"
captchaConfFields :: CaptchaConf -> [Part]
captchaConfFields c = catMaybes
[bool "phrase" phrase
,bool "regsense" regsense
,tri "numeric" numeric
,bool "calc" calc
,num "min_len" min_len
,num "max_len" max_len
,bool "is_russian" is_russian
,partBS "max_bid" . fromString . printf "%f" <$> max_bid c
]
where fromBool False = "0"
fromBool True = "1"
fromTri Nothing = "0"
fromTri (Just True) = "1"
fromTri (Just False) = "2"
optField :: Eq a => T.Text -> (a -> BS.ByteString) -> CaptchaConf -> (CaptchaConf -> a) -> Maybe Part
optField name conv conf get = do
let rec = get conf
if rec == get def
then Nothing
else Just $ partBS name $ conv rec
bool name = optField name fromBool c
tri name = optField name fromTri c
num name = optField name (fromString . show) c
reportBad :: (Failure HttpException m, MonadIO m) => ApiKey -> CaptchaID -> Manager -> m Bool
reportBad ApiKey{..} captchaid m = do
lbs <- httpGet m $
"http://" ++ api_host ++ "/res." ++ hostExt api_host ++ "?key=" ++
api_key ++ "&action=reportbad&id=" ++ show captchaid
return $ lbs == "OK_REPORT_RECORDED"
getBalance :: (Failure HttpException m, MonadIO m) => ApiKey -> Manager -> m Double
getBalance ApiKey{..} m =
liftM (read . TL.unpack . decodeUtf8) $ httpGet m $
"http://"++ api_host ++ "/res." ++ hostExt api_host ++ "?key=" ++
api_key ++"&action=getbalance"
uploadReq :: (Failure HttpException m, MonadIO m) => Manager -> ApiKey -> CaptchaConf -> Part -> m (ApiResult CaptchaID)
uploadReq m ApiKey{..} conf part = do
url <- parseUrl $ "http://" ++ api_host ++ "/in." ++ hostExt api_host
req <- flip formDataBody url $
[partBS "method" "post"
,partBS "key" $ fromString api_key]
++ captchaConfFields conf
++ [part]
res <- httpLbs req m
return $ parseUploadResponse $ TL.unpack $ decodeUtf8 $ responseBody res
uploadCaptcha
:: (Failure HttpException m, MonadIO m)
=> ApiKey
-> CaptchaConf
-> FilePath
-> BL.ByteString
-> Manager
-> m (ApiResult CaptchaID)
uploadCaptcha key sets filename image m = do
uploadReq m key sets $ partFileRequestBody "file" filename $ RequestBodyLBS image
uploadCaptchaFromFile
:: (Failure HttpException m, MonadIO m)
=> ApiKey
-> CaptchaConf
-> FilePath
-> Manager
-> m (ApiResult CaptchaID)
uploadCaptchaFromFile key sets filename m = do
uploadReq m key sets $ partFile "file" filename
renderApiResult :: ApiResult String -> String
renderApiResult (OK s) = "OK|" ++ s
renderApiResult (ERROR_UNKNOWN s) = s
renderApiResult a = show a
parseUploadResponse :: String -> ApiResult CaptchaID
parseUploadResponse s
| Just e <- readMay s = e
| otherwise =
fromMaybe (ERROR_UNKNOWN s) $
OK <$> (readMay =<< stripPrefix "OK|" s)
parseCheckResponse :: String -> ApiResult String
parseCheckResponse s
| Just e <- readMay s = e
| otherwise =
fromMaybe (ERROR_UNKNOWN s) $
OK <$> stripPrefix "OK|" s
parseMultiCheckResponse :: String -> ApiResult String
parseMultiCheckResponse s
| Just e <- readMay s = e
| isPrefixOf "ERROR_" s = ERROR_UNKNOWN s
| otherwise = OK s
parseMultiCheckResponses :: String -> [ApiResult String]
parseMultiCheckResponses = map parseMultiCheckResponse . charDelimit '|'
checkCaptcha
:: (Failure HttpException m, MonadIO m)
=> ApiKey
-> CaptchaID
-> Manager
-> m (ApiResult String)
checkCaptcha ApiKey{..} captchaid m =
liftM (parseCheckResponse . TL.unpack . decodeUtf8) $ httpGet m $
"http://" ++ api_host ++ "/res." ++ hostExt api_host ++ "?key=" ++
api_key ++ "&action=get&id=" ++ show captchaid
checkCaptchas
:: (Failure HttpException m, MonadIO m)
=> ApiKey
-> [CaptchaID]
-> Manager
-> m [ApiResult String]
checkCaptchas ApiKey{..} captchaids m =
liftM (parseMultiCheckResponses . TL.unpack . decodeUtf8) $ httpGet m $
"http://" ++ api_host ++ "/res." ++ hostExt api_host ++ "?key=" ++
api_key ++ "&action=get&ids=" ++ intercalate "," (map show captchaids)
data SolveException
= SolveExceptionUpload (ApiResult ())
| SolveExceptionCheck CaptchaID (ApiResult ())
deriving (Show, Typeable)
instance Exception SolveException
instance NFData SolveException where
rnf (SolveExceptionUpload a) = a `deepseq` ()
rnf (SolveExceptionCheck a b) = a `deepseq` b `deepseq` ()
data Phase = UploadPhase | CheckPhase
deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance NFData Phase
data SolveConf = SolveConf
{
api_upload_sleep :: [Int]
,api_check_sleep :: [Int]
,api_counter :: Phase
-> Int
-> IO ()
,api_upload_callback :: CaptchaID -> IO ()
}
instance Default SolveConf where
def = SolveConf
{api_upload_sleep = [3000000]
,api_check_sleep = [6000000,2000000,3000000]
,api_counter = const (const (return ()))
,api_upload_callback = const (return ())
}
instance Show SolveConf where
showsPrec d SolveConf{..} =
showParen (d>=11) $ showString "SolveConf{api_upload_sleep = " .
shows api_upload_sleep . showString ", api_check_sleep = " .
shows api_check_sleep . showString
", api_counter = <Phase -> Int -> IO ()>, api_upload_callback = <CaptchaID -> IO ()>}"
instance NFData SolveConf where
rnf (SolveConf a b c d) =
a `deepseq` b `deepseq`
c `deepseq` d `deepseq` ()
solveCaptcha
:: (Failure HttpException m, MonadIO m)
=> SolveConf
-> ApiKey
-> CaptchaConf
-> FilePath
-> BL.ByteString
-> Manager
-> m (CaptchaID, String)
solveCaptcha SolveConf{..} key conf filename image m = do
liftIO $ api_counter UploadPhase 0
captchaid <- goupload 1 api_upload_sleep
liftIO $ api_upload_callback captchaid
liftIO $ api_counter CheckPhase 0
gocheck captchaid 1 api_check_sleep
where
goupload _ [] = error "solveCaptcha: api_upload_sleep is empty"
goupload !c s_@(s:ss) = do
ur <- uploadCaptcha key conf filename image m
case ur of
ERROR_NO_SLOT_AVAILABLE -> do
liftIO $ api_counter UploadPhase c
liftIO $ threadDelay s
goupload (c+1) (if null ss then cycle s_ else ss)
OK i -> return i
a -> liftIO $ throwIO $ SolveExceptionUpload $ () <$ a
gocheck _ _ [] = error "solveCaptcha: api_check_sleep is empty"
gocheck captchaid !c s_@(s:ss) = do
liftIO $ threadDelay s
res <- checkCaptcha key captchaid m
case res of
CAPCHA_NOT_READY -> do
liftIO $ api_counter CheckPhase c
gocheck captchaid (c+1) (if null ss then cycle s_ else ss)
OK answer ->
return (captchaid, answer)
ex -> liftIO $ throwIO $ SolveExceptionCheck captchaid $ () <$ ex
solveCaptchaFromFile
:: (Failure HttpException m, MonadIO m)
=> SolveConf
-> ApiKey
-> CaptchaConf
-> FilePath
-> Manager
-> m (CaptchaID, String)
solveCaptchaFromFile a b c d m = do
s <- liftIO (fromStrict' <$> BS.readFile d)
solveCaptcha a b c d s m
where
#if MIN_VERSION_bytestring(0,10,0)
fromStrict' = BL.fromStrict
#else
fromStrict' x = BL.fromChunks [x]
#endif