module Network.Captcha.ReCaptcha
( captchaFields
, validateCaptcha
)
where
import Text.XHtml
import Network.Browser
import Network.HTTP
import Network.URI
captchaFields :: String
-> Maybe String
-> Html
captchaFields :: String -> Maybe String -> Html
captchaFields String
recaptchaPublicKey Maybe String
mbErrorMsg =
(Html -> Html
script forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
src (String -> String
captchaURL String
"challenge"), String -> HtmlAttr
thetype String
"text/javascript"] forall a b. HTML a => (Html -> b) -> a -> b
<< Html
noHtml) forall a b. (HTML a, HTML b) => a -> b -> Html
+++
Html -> Html
noscript forall a b. HTML a => (Html -> b) -> a -> b
<< [ Html -> Html
iframe forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
src (String -> String
captchaURL String
"noscript"), String -> HtmlAttr
height String
"300", String -> HtmlAttr
width String
"500", Int -> HtmlAttr
frameborder Int
0] forall a b. HTML a => (Html -> b) -> a -> b
<< Html
noHtml
, Html
br
, Html -> Html
textarea forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
name String
"recaptcha_challenge_field", String -> HtmlAttr
rows String
"3", String -> HtmlAttr
cols String
"40"] forall a b. HTML a => (Html -> b) -> a -> b
<< Html
noHtml
, Html
input forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thetype String
"hidden", String -> HtmlAttr
name String
"recaptcha_response_field", String -> HtmlAttr
value String
"manual_challenge"]
]
where captchaURL :: String -> String
captchaURL String
s = String
"https://www.google.com/recaptcha/api/" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"?k=" forall a. [a] -> [a] -> [a]
++ String
recaptchaPublicKey forall a. [a] -> [a] -> [a]
++
case Maybe String
mbErrorMsg of
Just String
e -> String
"?error=" forall a. [a] -> [a] -> [a]
++ String
e
Maybe String
Nothing -> String
""
validateCaptcha :: String
-> String
-> String
-> String
-> IO (Either String ())
validateCaptcha :: String -> String -> String -> String -> IO (Either String ())
validateCaptcha String
recaptchaPrivateKey String
ipaddress String
challenge String
response = do
let verifyURIString :: String
verifyURIString = String
"http://www.google.com/recaptcha/api/verify"
let verifyURI :: URI
verifyURI = case String -> Maybe URI
parseURI String
verifyURIString of
Just URI
uri -> URI
uri
Maybe URI
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not parse URI: " forall a. [a] -> [a] -> [a]
++ String
verifyURIString
let contents :: String
contents = [(String, String)] -> String
urlEncodeVars [(String
"privatekey", String
recaptchaPrivateKey),
(String
"remoteip", String
ipaddress),
(String
"challenge", String
challenge),
(String
"response", String
response)]
let req :: Request String
req = Request { rqURI :: URI
rqURI = URI
verifyURI,
rqMethod :: RequestMethod
rqMethod = RequestMethod
POST,
rqHeaders :: [Header]
rqHeaders = [ HeaderName -> String -> Header
Header HeaderName
HdrContentType String
"application/x-www-form-urlencoded",
HeaderName -> String -> Header
Header HeaderName
HdrContentLength (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
contents) ],
rqBody :: String
rqBody = String
contents }
(URI
_, Response String
resp) <- forall conn a. BrowserAction conn a -> IO a
browse (forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request String
req)
if forall a. Response a -> ResponseCode
rspCode Response String
resp forall a. Eq a => a -> a -> Bool
== (Int
2,Int
0,Int
0)
then do
let respLines :: [String]
respLines = String -> [String]
lines forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
rspBody Response String
resp
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
respLines
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"response-body-empty"
else if forall a. [a] -> a
head [String]
respLines forall a. Eq a => a -> a -> Bool
== String
"true"
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
else if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
respLines forall a. Ord a => a -> a -> Bool
>= Int
2
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [String]
respLines forall a. [a] -> Int -> a
!! Int
1
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"no-error-message"
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"response-code-not-200"