module Text.Recognition.Antigate
(AntigateKey
,CaptchaID
,CaptchaConf(..)
,UploadResult(..)
,CheckResult(..)
,SolveException(..)
,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.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import 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, intercalate)
import Data.Maybe (catMaybes, fromMaybe, fromJust)
import Data.String (fromString)
import Data.Word (Word)
import Safe (readMay)
import Text.Printf (printf)
httpRequest :: MonadResource m => String -> Manager -> m BL.ByteString
httpRequest u m = liftResourceT $ do
rq <- liftIO $ parseUrl u
responseBody <$> httpLbs rq{responseTimeout = Just 15000000} m
delimit :: Char -> String -> [String]
delimit _ [] = []
delimit a b =
case break (==a) b of
(c, []) -> [c]
(c, (_:d)) -> c : delimit a d
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)
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
}
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 => AntigateKey -> CaptchaID -> Manager -> m ()
reportBad key captchaid m = liftResourceT $
void $ flip httpRequest m $
"http://antigate.com/res.php?key=" ++ key ++
"&action=reportbad&id=" ++ show captchaid
getBalance :: MonadResource m => AntigateKey -> Manager -> m Double
getBalance key m = liftResourceT $
read . TL.unpack . TLE.decodeUtf8 <$> httpRequest
("http://antigate.com/res.php?key="++ key ++"&action=getbalance") m
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 -> AntigateKey -> CaptchaConf -> Part m (ResourceT IO) -> m UploadResult
inReq m key conf part = do
req <- (`formDataBody` url) $
([partBS "method" "post"
,partBS "key" (fromString key)
]) ++
(captchaConfFields conf
) ++
[part]
liftResourceT $ parseUploadResult . TL.unpack . TLE.decodeUtf8 . responseBody <$> httpLbs req m
where url = fromJust (parseUrl "http://antigate.com/in.php")
uploadCaptcha :: MonadResource m => AntigateKey -> 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 => AntigateKey -> 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 => AntigateKey -> CaptchaID -> Manager -> m CheckResult
checkCaptcha key captchaid m = liftResourceT $ do
parseCheckResult . TL.unpack . TLE.decodeUtf8 <$> httpRequest
("http://antigate.com/res.php?key="++ key ++"&action=get&id="++ show captchaid) m
checkCaptchas :: MonadResource m => AntigateKey -> [CaptchaID] -> Manager -> m [CheckResult]
checkCaptchas key captchaids m = liftResourceT $ do
parseCheckResults . TL.unpack . TLE.decodeUtf8 <$> httpRequest
("http://antigate.com/res.php?key="++ key ++"&action=get&ids="++
intercalate "," (map show captchaids)) m
data SolveException = SolveExceptionUpload UploadResult
| SolveExceptionCheck CaptchaID CheckResult
deriving (Show, Typeable)
instance Exception SolveException
solveCaptcha :: MonadResource m =>
Int
-> Int
-> AntigateKey
-> CaptchaConf
-> FilePath
-> BL.ByteString
-> Manager
-> m (CaptchaID, String)
solveCaptcha sleepwait sleepcaptcha 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 $ threadDelay sleepwait
goupload
UPLOAD_OK i -> gocheck i
a -> liftIO $ throwIO $ SolveExceptionUpload a
gocheck captchaid = do
liftIO $ threadDelay sleepcaptcha
res <- checkCaptcha key captchaid m
case res of
CHECK_OK answer ->
return (captchaid, answer)
CAPCHA_NOT_READY -> do
liftIO $ threadDelay sleepcaptcha
gocheck captchaid
ex -> liftIO $ throwIO $ SolveExceptionCheck captchaid ex
solveCaptchaFromFile :: (MonadBaseControl IO m, MonadResource m) => Int -> Int -> AntigateKey -> CaptchaConf -> FilePath -> Manager -> m (CaptchaID, String)
solveCaptchaFromFile a b c d f m =
liftIO (BL.readFile f) >>= \s -> solveCaptcha a b c d f s m