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 (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
src (String -> String
captchaURL String
"challenge"), String -> HtmlAttr
thetype String
"text/javascript"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
noHtml) Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
Html -> Html
noscript (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ Html -> Html
iframe (Html -> Html) -> [HtmlAttr] -> Html -> Html
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] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
noHtml
, Html
br
, Html -> Html
textarea (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
name String
"recaptcha_challenge_field", String -> HtmlAttr
rows String
"3", String -> HtmlAttr
cols String
"40"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
noHtml
, Html
input Html -> [HtmlAttr] -> Html
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/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?k=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recaptchaPublicKey String -> String -> String
forall a. [a] -> [a] -> [a]
++
case Maybe String
mbErrorMsg of
Just String
e -> String
"?error=" String -> String -> String
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 -> String -> URI
forall a. HasCallStack => String -> a
error (String -> URI) -> String -> URI
forall a b. (a -> b) -> a -> b
$ String
"Could not parse URI: " String -> String -> String
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 :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
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 (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
contents) ],
rqBody :: String
rqBody = String
contents }
(URI
_, Response String
resp) <- BrowserAction (HandleStream String) (URI, Response String)
-> IO (URI, Response String)
forall conn a. BrowserAction conn a -> IO a
browse (Request String
-> BrowserAction (HandleStream String) (URI, Response String)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request String
req)
if Response String -> ResponseCode
forall a. Response a -> ResponseCode
rspCode Response String
resp ResponseCode -> ResponseCode -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
2,Int
0,Int
0)
then do
let respLines :: [String]
respLines = String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Response String -> String
forall a. Response a -> a
rspBody Response String
resp
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
respLines
then Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"response-body-empty"
else if [String] -> String
forall a. [a] -> a
head [String]
respLines String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"true"
then Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()
else if [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
respLines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
then Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ [String]
respLines [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
1
else Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"no-error-message"
else Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left String
"response-code-not-200"