    {-
    Copyright (c) 2008 John MacFarlane
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in the
    documentation and/or other materials provided with the distribution.

    Neither the name of John MacFarlane nor the names of this software's
    contributors may be used to endorse or promote products derived from
    this software without specific prior written permission.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
    A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR
    CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
    EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
    PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
    PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
    LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
    NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    -}

    module Network.Captcha.ReCaptcha
           ( captchaFields
           , validateCaptcha
           )
    where
    import Text.XHtml
    import Network.Browser
    import Network.HTTP
    import Network.URI

    -- | Returns HTML element to be inserted in the form for which a CAPTCHA is wanted.
    captchaFields :: String       -- ^ reCAPTCHA public key
                  -> Maybe String -- ^ @Nothing@ or @Just@ an error message returned by previous validate attempt
                  -> 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
    ""

    -- | Verify a CAPTCHA.
    validateCaptcha :: String                 -- ^ reCAPTCHA private key
                    -> String                 -- ^ IP address of the user who solved the CAPTCHA
                    -> String                 -- ^ value of the recaptcha_challenge_field
                    -> String                 -- ^ value of the recaptcha_response_field
                    -> IO (Either String ())  -- ^ @Left@ error message, or @Right ()@ for success
    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 { 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 a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    contents) ],
                          rqBody :: String
    rqBody = String
    contents }
      (_, 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 rspCode resp == (2,0,0)
         then do
           let 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 null respLines
              then return $ Left "response-body-empty"
              else if head respLines == "true"
                      then return $ Right ()
                      else if length respLines >= 2
                              then return $ Left $ respLines !! 1
                              else return $ Left "no-error-message"
         else return $ Left "response-code-not-200"