Add captcha for user registration

.github/workflows/cabal-mtl-2.3.yml

@@ -30,11 +30,10 @@ jobs:
         echo "GHC_VER=${GHC_VER}"       >> "${GITHUB_ENV}"
         echo "CABAL_VER=${CABAL_VER}"   >> "${GITHUB_ENV}"
 
-    # Brotli is already installed on ubuntu-22.04
-    # - name: Install the brotli library
-    #   run: |
-    #     sudo apt-get update
-    #     sudo apt-get install -y libbrotli-dev
+    - name: Install necessary deps
+      run: |
+        sudo apt-get update
+        sudo apt-get install -y libgd-dev libpng-dev libjpeg-dev libfontconfig-dev libfreetype-dev libexpat1-dev
 
     - uses: actions/checkout@v3
 

.github/workflows/haskell-ci.yml

@@ -71,7 +71,7 @@ jobs:
           "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
           "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
           apt-get update
-          apt-get install -y libbrotli-dev
+          apt-get install -y libbrotli-dev libgd-dev libpng-dev libjpeg-dev libfontconfig-dev libfreetype-dev libexpat1-dev
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}

datafiles/templates/UserSignupReset/SignupRequest.html.st

@@ -33,6 +33,14 @@ In particular you need an account to be able to upload or help maintain packages
 <td><label for="email">Your email address</label>
 <td><input type="text" name="email" id="email">
 <td>e.g. [email protected] (but do <b>not</b> use the style "Jan Novák" &lt;[email protected]&gt;)
+
+<tr>
+<td><label for="captcha">Captcha</label>
+<td><input type="text" name="captcha" id="captcha">
+<td><a href="javascript:changeCaptcha();"><img src="$base64image$" alt="captcha" id="image"/></a>
+The captcha will expire in 10 minutes. Click on the image to change one.
+<input type="hidden" name="timestamp" id="timestamp" value="$timestamp$">
+<input type="hidden" name="hash" id="hash" value="$hash$">
 </table>
 
 <p>Your email address will be used to confirm your account (and if you ever
@@ -48,4 +56,27 @@ can set your password and activate your account.
 </form>
 
 </div>
+<script type="text/javascript">
+var image = document.getElementById("image");
+var timestamp = document.getElementById("timestamp");
+var hash = document.getElementById("hash");
+
+function changeCaptcha() {
+  var xmlHttp = new XMLHttpRequest();
+  xmlHttp.onreadystatechange = function() { 
+      if (xmlHttp.readyState == 4 && xmlHttp.status == 200) {
+        var res = JSON.parse(xmlHttp.responseText);
+        if (typeof res == "object" && typeof res.timestamp == "string" && typeof res.hash == "string" && typeof res.base64image == "string") {
+          image.setAttribute("src", res.base64image);
+          timestamp.setAttribute("value", res.timestamp);
+          hash.setAttribute("value", res.hash);
+        } else {
+          console.error("Invalid response from /users/register/captcha");
+        }
+      }
+  }
+  xmlHttp.open("GET", "/users/register/captcha", true);
+  xmlHttp.send(null);
+}
+</script>
 </body></html>

hackage-server.cabal

@@ -403,6 +403,7 @@ library lib-server
         -- see https://github.com/haskell/hackage-server/issues/1128
     , happstack-server      ^>= 7.7.1     || ^>= 7.8.0
     , hashable              ^>= 1.3       || ^>= 1.4
+    , hs-captcha            ^>= 1.0
     , hslogger              ^>= 1.3.1
     , lifted-base           ^>= 0.2.1
     , mime-mail             ^>= 0.5

shell.nix

@@ -7,9 +7,9 @@ let
 
   pkgs = import nixpkgs { config = { }; };
 
-in
-pkgs.mkShell {
-  buildInputs = with pkgs; [
+in 
+with pkgs; pkgs.mkShell rec {
+  buildInputs = [
     # Haskell development
     cabal-install
     ghc
@@ -22,5 +22,14 @@ pkgs.mkShell {
     cryptodev
     pkg-config
     brotli
+
+    gd
+    libpng
+    libjpeg
+    fontconfig
+    freetype
+    expat
   ];
+
+  # LD_LIBRARY_PATH = lib.makeLibraryPath buildInputs;
 }

src/Distribution/Server/Features/UserSignup.hs

@@ -28,18 +28,28 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import qualified Data.ByteString.Char8 as BS -- Only used for ASCII data
-
+import qualified Data.ByteString.Lazy as BSL
 import Data.Typeable (Typeable)
 import Control.Monad.Reader (ask)
 import Control.Monad.State (get, put, modify)
 import Data.SafeCopy (base, deriveSafeCopy)
 
 import Distribution.Text (display)
-import Data.Time (UTCTime(..), getCurrentTime, addDays)
+import Data.Time
 import Text.CSV (CSV, Record)
 import Network.Mail.Mime
 import Network.URI (URI(..), URIAuth(..))
+import Graphics.Captcha
+import qualified Data.ByteString.Base64 as Base64
+import qualified Crypto.Hash.SHA256 as SHA256
+import Data.String
+import Data.Char
+import Text.Read (readMaybe)
+import Data.Aeson
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.Aeson.Key as Key
 
 
 -- | A feature to allow open account signup, and password reset,
@@ -306,6 +316,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
     userSignupFeatureInterface = (emptyHackageFeature "user-signup-reset") {
         featureDesc      = "Extra information about user accounts, email addresses etc."
       , featureResources = [signupRequestsResource,
+                            captchaResource,
                             signupRequestResource,
                             resetRequestsResource,
                             resetRequestResource]
@@ -325,6 +336,12 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
       , resourceGet  = [ ("", handlerGetSignupRequestNew) ]
       , resourcePost = [ ("", handlerPostSignupRequestNew) ]
       }
+
+    captchaResource = 
+      (resourceAt "/users/register/captcha") {
+        resourceDesc = [ (GET,  "Get a new captcha") ]
+      , resourceGet  = [ ("json", handlerGetCaptcha) ]
+      }
 
     signupRequestResource =
       (resourceAt "/users/register-request/:nonce") {
@@ -413,20 +430,44 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
       [MText $ "The " ++ thing ++ " token does not exist. It could be that it "
             ++ "has been used already, or that it has expired."]
 
+    hashTimeAndCaptcha :: UTCTime -> String -> BS.ByteString
+    hashTimeAndCaptcha timestamp captcha = Base64.encode (SHA256.hash (fromString (show timestamp ++ map toUpper captcha)))
+
+    makeCaptchaHash :: IO (UTCTime, BS.ByteString, BS.ByteString)
+    makeCaptchaHash = do
+        (code, image) <- makeCaptcha
+        timestamp <- getCurrentTime
+        pure (timestamp, hashTimeAndCaptcha timestamp code, fromString "data:image/png;base64," <> Base64.encode image)
+
     handlerGetSignupRequestNew :: DynamicPath -> ServerPartE Response
     handlerGetSignupRequestNew _ = do
+        (timestamp, hash, base64image) <- liftIO makeCaptchaHash
         template <- getTemplate templates "SignupRequest.html"
-        ok $ toResponse $ template []
+        ok $ toResponse $ template 
+          [ "timestamp"   $= timestamp
+          , "hash"        $= hash
+          , "base64image" $= base64image
+          ]
+
+    handlerGetCaptcha :: DynamicPath -> ServerPartE Response
+    handlerGetCaptcha _ = do
+        (timestamp, hash, base64image) <- liftIO makeCaptchaHash
+        ok $ toResponse $ Object $ KeyMap.fromList $ 
+          [ (Key.fromString "timestamp"  , String (T.pack (show timestamp)))
+          , (Key.fromString "hash"       , String (T.decodeUtf8 hash))
+          , (Key.fromString "base64image", String (T.decodeUtf8 base64image))
+          ]
 
     handlerPostSignupRequestNew :: DynamicPath -> ServerPartE Response
     handlerPostSignupRequestNew _ = do
         templateEmail        <- getTemplate templates "SignupConfirmation.email"
         templateConfirmation <- getTemplate templates "SignupEmailSent.html"
 
-        (username, realname, useremail) <- lookUserNameEmail
+        timestamp <- liftIO getCurrentTime
+
+        (username, realname, useremail) <- lookValidFields timestamp
 
         nonce     <- liftIO (newRandomNonce 10)
-        timestamp <- liftIO getCurrentTime
         let signupInfo = SignupInfo {
               signupUserName     = username,
               signupRealName     = realname,
@@ -462,17 +503,29 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
           templateConfirmation
             [ "useremail" $= useremail ]
       where
-        lookUserNameEmail = do
-          (username, realname, useremail) <-
-            msum [ body $ (,,) <$> lookText' "username"
-                               <*> lookText' "realname"
-                               <*> lookText' "email"
+        lookValidFields now = do
+          (username, realname, useremail, captcha, timestampStr, hash) <-
+            msum [ body $ (,,,,,) <$> lookText' "username"
+                                  <*> lookText' "realname"
+                                  <*> lookText' "email"
+                                  <*> look      "captcha"
+                                  <*> look      "timestamp"
+                                  <*> lookBS    "hash"
                  , errBadRequest "Missing form fields" [] ]
 
           guardValidLookingUserName username
           guardValidLookingName     realname
           guardValidLookingEmail    useremail
 
+          timestamp <- maybe (errBadRequest "Invalid request" [MText "Seems something went wrong with your request."]) 
+            pure (readMaybe timestampStr)
+
+          when (diffUTCTime now timestamp > secondsToNominalDiffTime (10 * 60)) $
+            errBadRequest "Problem with captcha" [MText "Oops, The captcha has expired. Please be quick next time!"]
+
+          unless (hashTimeAndCaptcha timestamp captcha == BSL.toStrict hash) $
+            errBadRequest "Problem with captcha" [MText "Sorry, the captcha is wrong. Please try sign up again."]
+
           return (username, realname, useremail)
 
     handlerGetSignupRequestOutstanding :: DynamicPath -> ServerPartE Response