module Text.Recognition.Antigate
(ApiKey(..)
,CaptchaID
,CaptchaConf(..)
,UploadResult(..)
,CheckResult(..)
,SolveException(..)
,SolveConf(..)
,Phase(..)
,solveCaptcha
,solveCaptchaFromFile
,uploadCaptcha
,uploadCaptchaFromFile
,checkCaptcha
,checkCaptchas
,reportBad
,getBalance
,Manager
,newManager
,closeManager
,withManager
,parseUploadResult
,parseCheckResult
,parseCheckResults
,parseCheckResultNoOK
,renderUploadResult
,renderCheckResult
) 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 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.Monad (void)
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 UploadResult = UPLOAD_OK CaptchaID
| ERROR_WRONG_USER_KEY
| UPLOAD_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
| UPLOAD_ERROR_UNKNOWN String
deriving (Show, Read, Eq, Ord)
data CheckResult = CHECK_OK String
| CAPCHA_NOT_READY
| CHECK_ERROR_KEY_DOES_NOT_EXIST
| ERROR_WRONG_ID_FORMAT
| CHECK_ERROR_UNKNOWN String
deriving (Show, Read, Eq, Ord)
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 ()
reportBad ApiKey{..} captchaid m =
void $ httpGet m $
"http://" ++ api_host ++ "/res." ++ hostExt api_host ++ "?key=" ++
api_key ++ "&action=reportbad&id=" ++ show captchaid
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"
renderUploadResult :: UploadResult -> String
renderUploadResult (UPLOAD_OK i) = "OK|" ++ show i
renderUploadResult (UPLOAD_ERROR_UNKNOWN s) = s
renderUploadResult a = show a
parseUploadResult :: String -> UploadResult
parseUploadResult "ERROR_KEY_DOES_NOT_EXIST" = UPLOAD_ERROR_KEY_DOES_NOT_EXIST
parseUploadResult s
| Just e <- readMay s = e
| otherwise =
fromMaybe (UPLOAD_ERROR_UNKNOWN s) $
UPLOAD_OK <$> (readMay =<< stripPrefix "OK|" s)
inReq :: MonadResource m => Manager -> ApiKey -> CaptchaConf -> Part m (ResourceT IO) -> m UploadResult
inReq 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 $ parseUploadResult . TL.unpack . decodeUtf8 . responseBody <$> httpLbs req m
uploadCaptcha :: MonadResource m => ApiKey -> CaptchaConf -> FilePath -> BL.ByteString -> Manager -> m UploadResult
uploadCaptcha key sets filename image m = do
inReq m key sets $ partFileRequestBody "file" filename $ RequestBodyLBS image
uploadCaptchaFromFile :: MonadResource m => ApiKey -> CaptchaConf -> FilePath -> Manager -> m UploadResult
uploadCaptchaFromFile key sets filename m = do
inReq m key sets $ partFile "file" filename
renderCheckResult :: CheckResult -> String
renderCheckResult (CHECK_OK s) = "OK|" ++ s
renderCheckResult (CHECK_ERROR_UNKNOWN s) = s
renderCheckResult a = show a
parseCheckResult :: String -> CheckResult
parseCheckResult "ERROR_KEY_DOES_NOT_EXIST" = CHECK_ERROR_KEY_DOES_NOT_EXIST
parseCheckResult s
| Just e <- readMay s = e
| otherwise = fromMaybe (CHECK_ERROR_UNKNOWN s) $
CHECK_OK <$> stripPrefix "OK|" s
parseCheckResultNoOK :: String -> CheckResult
parseCheckResultNoOK "ERROR_KEY_DOES_NOT_EXIST" = CHECK_ERROR_KEY_DOES_NOT_EXIST
parseCheckResultNoOK s
| Just e <- readMay s = e
| isPrefixOf "ERROR_" s = CHECK_ERROR_UNKNOWN s
| otherwise = CHECK_OK s
parseCheckResults :: String -> [CheckResult]
parseCheckResults = map parseCheckResultNoOK . delimit '|'
checkCaptcha :: MonadResource m => ApiKey -> CaptchaID -> Manager -> m CheckResult
checkCaptcha ApiKey{..} captchaid m =
fmap (parseCheckResult . 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 [CheckResult]
checkCaptchas ApiKey{..} captchaids m =
fmap (parseCheckResults . 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 UploadResult
| SolveExceptionCheck CaptchaID CheckResult
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 -> IO ()
}
instance Default SolveConf where
def = SolveConf
{api_upload_sleep = 3000000
,api_check_sleep = 3000000
,api_counter = 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 -> IO ()>}"
solveCaptcha :: MonadResource m =>
SolveConf
-> ApiKey
-> CaptchaConf
-> FilePath
-> BL.ByteString
-> Manager
-> m (CaptchaID, String)
solveCaptcha SolveConf{..} key conf filename image m = goupload
where
goupload = do
ur <- uploadCaptcha key conf filename image m
case ur of
ERROR_NO_SLOT_AVAILABLE -> do
liftIO $ api_counter UploadPhase
liftIO $ threadDelay api_upload_sleep
goupload
UPLOAD_OK i -> gocheck i
a -> liftIO $ throwIO $ SolveExceptionUpload a
gocheck captchaid = do
liftIO $ threadDelay api_check_sleep
res <- checkCaptcha key captchaid m
case res of
CHECK_OK answer ->
return (captchaid, answer)
CAPCHA_NOT_READY -> do
liftIO $ api_counter CheckPhase
gocheck captchaid
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 =
liftIO (BL.readFile d) >>= \s -> solveCaptcha a b c d s m