module Text.Recognition.Antigate
(AntigateKey
,CaptchaID
,CaptchaConf(..)
,UploadResult(..)
,CheckResult(..)
,SolveException(..)
,solveCaptcha
,solveCaptchaFromFile
,uploadCaptcha
,checkCaptcha
,checkCaptchas
,reportBad
,getBalance
,parseUploadResult
,parseCheckResult
,parseCheckResults
,parseCheckResultNoOK
,renderUploadResult
,renderCheckResult
) where
import Control.Arrow (first)
import Control.Monad (void)
import Control.Applicative ((<$>))
import Control.Concurrent (threadDelay)
import Control.Exception (Exception, throwIO)
import qualified Codec.Binary.UTF8.Generic as UTF8 (fromString, toString)
import qualified Data.ByteString as S (concat)
import Data.ByteString.Lazy.Char8()
import Data.Default (Default(..))
import Data.List (stripPrefix, isPrefixOf, intercalate)
import Data.Monoid ((<>))
import Data.Maybe (catMaybes, fromMaybe, fromJust)
import Data.String (fromString)
import Data.Typeable (Typeable)
import Data.Word (Word)
import Network.Mime (defaultMimeLookup)
import Safe (readMay)
import Text.Printf (printf)
import qualified Data.ByteString.Lazy as L
import Network.HTTP.Types
import System.Random
import Network.HTTP.Conduit
httpRequest :: String -> IO L.ByteString
httpRequest u =
responseBody <$> withManager
(httpLbs (fromJust $ parseUrl u){responseTimeout = Just 15000000})
delimit :: Char -> String -> [String]
delimit _ [] = []
delimit a b =
case break (==a) b of
(c, []) -> [c]
(c, (_:d)) -> c : delimit a d
randomString :: RandomGen d => Int -> d -> (String, d)
randomString len =
first (map toChar) . sequence' (replicate len (randomR (0, 61)))
where
sequence' [] g = ([], g)
sequence' (f:fs) g =
let (f', g') = f g
(fs', g'') = sequence' fs g'
in (f' : fs', g'')
toChar i
| i < 26 = toEnum $ i + fromEnum 'A'
| i < 52 = toEnum $ i + fromEnum 'a' 26
| otherwise = toEnum $ i + fromEnum '0' 52
randomBoundary :: IO L.ByteString
randomBoundary = do
dashlen <- randomRIO (5, 30)
charlen <- randomRIO (10, 30)
fromString . (replicate dashlen '-' ++) <$> getStdRandom (randomString charlen)
type AntigateKey = String
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)
data Field = Part L.ByteString L.ByteString
| File L.ByteString L.ByteString L.ByteString L.ByteString
deriving (Show)
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
}
renderField :: L.ByteString -> Field -> L.ByteString
renderField boundary (Part name body) =
"--" <> boundary <> "\r\n"
<> "Content-Disposition: form-data; name=\"" <> name <> "\""
<> "\r\n"
<> "\r\n" <> body <> "\r\n"
renderField boundary (File name filename contenttype body) =
"--" <> boundary <> "\r\n"
<> "Content-Disposition: form-data; name=\"" <> name <> "\"; filename=\"" <> filename <> "\""
<> "\r\n" <> "Content-Type: " <> contenttype <> "\r\n"
<> "\r\n" <> body <> "\r\n"
renderFields :: L.ByteString -> [Field] -> L.ByteString
renderFields boundary fields =
L.concat (map (renderField boundary) fields)
<> "--" <> boundary <> "--\r\n"
captchaConfFields :: CaptchaConf -> [Field]
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
,Part "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 => L.ByteString -> (a -> L.ByteString) -> (CaptchaConf -> a) -> Maybe Field
optField name conv rec
| rec c /= rec def = Just $ Part name $ conv $ rec c
| otherwise = Nothing
bool name = optField name fromBool
tri name = optField name fromTri
num name = optField name (fromString . show)
reportBad :: AntigateKey -> CaptchaID -> IO ()
reportBad key captchaid =
void $ httpRequest
("http://antigate.com/res.php?key="++ key ++"&action=reportbad&id=" ++ show captchaid)
getBalance :: AntigateKey -> IO Double
getBalance key =
read . UTF8.toString <$> httpRequest
("http://antigate.com/res.php?key="++ 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)
uploadCaptcha :: AntigateKey -> CaptchaConf -> FilePath -> L.ByteString -> IO UploadResult
uploadCaptcha key sets filename image = do
boundary <- randomBoundary
let req = (fromJust $ parseUrl "http://antigate.com/in.php")
{method = methodPost
,requestHeaders = [(hContentType, S.concat $ L.toChunks $ "multipart/form-data; boundary=" <> boundary)]
,requestBody = RequestBodyLBS $ renderFields boundary $
[Part "method" "post"
,Part "key" (fromString key)
] ++
captchaConfFields sets ++
[File "file" (UTF8.fromString filename)
(L.fromChunks [defaultMimeLookup (fromString filename)])
image
]
}
parseUploadResult . UTF8.toString . responseBody <$> withManager (httpLbs req)
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 :: AntigateKey -> CaptchaID -> IO CheckResult
checkCaptcha key captchaid = do
parseCheckResult . UTF8.toString <$> httpRequest
("http://antigate.com/res.php?key="++ key ++"&action=get&id="++ show captchaid)
checkCaptchas :: AntigateKey -> [CaptchaID] -> IO [CheckResult]
checkCaptchas key captchaids = do
parseCheckResults . UTF8.toString <$> httpRequest
("http://antigate.com/res.php?key="++ key ++"&action=get&ids="++
intercalate "," (map show captchaids))
data SolveException = SolveExceptionUpload UploadResult
| SolveExceptionCheck CaptchaID CheckResult
deriving (Show, Typeable)
instance Exception SolveException
solveCaptcha :: Int
-> Int
-> AntigateKey
-> CaptchaConf
-> FilePath
-> L.ByteString
-> IO (CaptchaID, String)
solveCaptcha sleepwait sleepcaptcha key conf filename image = goupload
where goupload = do
ur <- uploadCaptcha key conf filename image
case ur of
ERROR_NO_SLOT_AVAILABLE -> do
threadDelay sleepwait
goupload
UPLOAD_OK i -> gocheck i
a -> throwIO $ SolveExceptionUpload a
gocheck captchaid = do
threadDelay sleepcaptcha
res <- checkCaptcha key captchaid
case res of
CHECK_OK answer ->
return (captchaid, answer)
CAPCHA_NOT_READY -> do
threadDelay sleepcaptcha
gocheck captchaid
ex -> throwIO $ SolveExceptionCheck captchaid ex
solveCaptchaFromFile :: Int -> Int -> AntigateKey -> CaptchaConf -> FilePath -> IO (CaptchaID, String)
solveCaptchaFromFile a b c d f = solveCaptcha a b c d f =<< L.readFile f