diff --git a/.github/workflows/cabal-mtl-2.3.yml b/.github/workflows/cabal-mtl-2.3.yml index d212ed339..423f1dd50 100644 --- a/.github/workflows/cabal-mtl-2.3.yml +++ b/.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 diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 00605139b..bd5f639b1 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.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 }} diff --git a/datafiles/templates/UserSignupReset/SignupRequest.html.st b/datafiles/templates/UserSignupReset/SignupRequest.html.st index f0ba4c186..a608aea50 100644 --- a/datafiles/templates/UserSignupReset/SignupRequest.html.st +++ b/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 e.g. jnovak@example.com (but do not use the style "Jan Novák" <jnovak@example.com>) + + + + +captcha +The captcha will expire in 10 minutes. Click on the image to change one. + +

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. + diff --git a/hackage-server.cabal b/hackage-server.cabal index 4836c0978..0357ebcb3 100644 --- a/hackage-server.cabal +++ b/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 diff --git a/shell.nix b/shell.nix index 95b11a449..909e7de85 100644 --- a/shell.nix +++ b/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; } diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index 915fa7641..a1f4a00a6 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/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