module Text.Recognition.Antigate
(ApiKey(..)
,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
import Network.HTTP.Conduit.MultipartFormData
import Control.Concurrent (threadDelay)
import Control.Exception (Exception, throwIO)
import Data.Typeable (Typeable)
import Control.Monad.Trans.Resource
import Control.Monad.IO.Class (liftIO)
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)
decodeUtf8 :: BL.ByteString -> TL.Text
decodeUtf8 = TLE.decodeUtf8With TEE.lenientDecode
httpLbs :: Request (ResourceT IO) -> Manager -> ResourceT IO (Response BL.ByteString)
httpLbs r m = Network.HTTP.Conduit.httpLbs r{responseTimeout=Nothing} m
httpGet :: MonadResource m => Manager -> String -> m BL.ByteString
httpGet m u = liftResourceT $ do
rq <- parseUrl u
responseBody <$> httpLbs rq m
delimit :: Char -> String -> [String]
delimit _ [] = []
delimit a b =
case break (==a) b of
(c, []) -> [c]
(c, (_:d)) -> c : delimit a d
data ApiKey = ApiKey
{api_host :: String
,api_key :: String
}
deriving (Eq, Ord, Show, Read)
instance IsString ApiKey where
fromString str = ApiKey
{api_host = "antigate.com"
,api_key = str}
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
}
hostExt :: String -> String
hostExt host
| "pixodrom.com" `isInfixOf` host = "aspx"
| otherwise = "php"
captchaConfFields :: (Monad m, Monad m') => CaptchaConf -> [Part m m']
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 :: (Monad m, Monad m', Eq a) => T.Text -> (a -> BS.ByteString) -> CaptchaConf -> (CaptchaConf -> a) -> Maybe (Part m m')
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 :: MonadResource 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 :: MonadResource m => ApiKey -> Manager -> m Double
getBalance ApiKey{..} m =
fmap (read . TL.unpack . decodeUtf8) $ httpGet m $
"http://"++ api_host ++ "/res." ++ hostExt api_host ++ "?key=" ++
api_key ++"&action=getbalance"
uploadReq :: MonadResource m => Manager -> ApiKey -> CaptchaConf -> Part m (ResourceT IO) -> m (ApiResult CaptchaID)
uploadReq m ApiKey{..} conf part = do
url <- liftIO $ parseUrl $ "http://" ++ api_host ++ "/in." ++ hostExt api_host
req <- (`formDataBody` url) $
([partBS "method" "post"
,partBS "key" (fromString api_key)
]) ++
(captchaConfFields conf
) ++
[part]
liftResourceT $ parseUploadResponse . TL.unpack . decodeUtf8 . responseBody <$> httpLbs req m
uploadCaptcha :: MonadResource 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 :: MonadResource 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 . delimit '|'
checkCaptcha :: MonadResource m => ApiKey -> CaptchaID -> Manager -> m (ApiResult String)
checkCaptcha ApiKey{..} captchaid m =
fmap (parseCheckResponse . TL.unpack . decodeUtf8) $ httpGet m $
"http://" ++ api_host ++ "/res." ++ hostExt api_host ++ "?key=" ++
api_key ++ "&action=get&id=" ++ show captchaid
checkCaptchas :: MonadResource m => ApiKey -> [CaptchaID] -> Manager -> m [ApiResult String]
checkCaptchas ApiKey{..} captchaids m =
fmap (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
data Phase = UploadPhase | CheckPhase
deriving (Show, Read, Eq, Ord, Enum, Bounded)
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 ()>}"
solveCaptcha :: MonadResource 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 :: (MonadBaseControl IO m, MonadResource 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