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 recaptchaPublicKey :: String
recaptchaPublicKey mbErrorMsg :: Maybe String
mbErrorMsg =
(Html -> Html
script (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
src (String -> String
captchaURL "challenge"), String -> HtmlAttr
thetype "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 "noscript"), String -> HtmlAttr
height "300", String -> HtmlAttr
width "500", Int -> HtmlAttr
frameborder 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 "recaptcha_challenge_field", String -> HtmlAttr
rows "3", String -> HtmlAttr
cols "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 "hidden", String -> HtmlAttr
name "recaptcha_response_field", String -> HtmlAttr
value "manual_challenge"]
]
where captchaURL :: String -> String
captchaURL s :: String
s = "https://www.google.com/recaptcha/api/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "?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 e :: String
e -> "?error=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
Nothing -> ""
validateCaptcha :: String
-> String
-> String
-> String
-> IO (Either String ())
validateCaptcha :: String -> String -> String -> String -> IO (Either String ())
validateCaptcha recaptchaPrivateKey :: String
recaptchaPrivateKey ipaddress :: String
ipaddress challenge :: String
challenge response :: String
response = do
let verifyURIString :: String
verifyURIString = "http://www.google.com/recaptcha/api/verify"
let verifyURI :: URI
verifyURI = case String -> Maybe URI
parseURI String
verifyURIString of
Just uri :: URI
uri -> URI
uri
Nothing -> String -> URI
forall a. HasCallStack => String -> a
error (String -> URI) -> String -> URI
forall a b. (a -> b) -> a -> b
$ "Could not parse URI: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
verifyURIString
let contents :: String
contents = [(String, String)] -> String
urlEncodeVars [("privatekey", String
recaptchaPrivateKey),
("remoteip", String
ipaddress),
("challenge", String
challenge),
("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 "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 }
(_, resp :: 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
== (2,0,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 "response-body-empty"
else if [String] -> String
forall a. [a] -> a
head [String]
respLines String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "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
>= 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
!! 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 "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 "response-code-not-200"