From 5a3f57715b7a7720c1d11c180692d81b886932bc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 20 Apr 2022 19:01:42 +0200 Subject: [PATCH] refactor(form-honeypots): hide honeypots via custom attribute --- src/Application.hs | 2 + src/Foundation/SiteLayout.hs | 13 ++++- src/Handler/Utils/Random.hs | 66 ++++++++++++++++++++++++++ src/Utils.hs | 9 +++- src/Utils/Form.hs | 71 +++++++++++++++++----------- templates/widgets/aform/aform.hamlet | 12 ++--- 6 files changed, 135 insertions(+), 38 deletions(-) create mode 100644 src/Handler/Utils/Random.hs diff --git a/src/Application.hs b/src/Application.hs index 7d02e6009..5f86cd20d 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -719,3 +719,5 @@ addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do PWHashConf{..} <- getsYesod $ view _appAuthPWHash (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength void $ insert User{..} + + diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index ebec84d65..0b4fd87bb 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -29,6 +29,7 @@ import Handler.Utils.Memcached import qualified Data.Text as Text import qualified Data.Set as Set import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text.Lazy.Builder as LTB import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E @@ -114,15 +115,16 @@ data MemcachedLimitKeyFavourites deriving anyclass (Hashable, Binary) -siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, YesodPersistBackend UniWorX ~ SqlBackend) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html +siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, MonadSecretBox (HandlerFor UniWorX)) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html siteLayoutMsg = siteLayout . i18n {-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-} -siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, YesodPersistBackend UniWorX ~ SqlBackend) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html +siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, MonadSecretBox (HandlerFor UniWorX)) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html siteLayoutMsg' = siteLayoutMsg siteLayout :: ( BearerAuthSite UniWorX , YesodPersistBackend UniWorX ~ SqlBackend + , MonadSecretBox (HandlerFor UniWorX) ) => WidgetFor UniWorX () -- ^ `pageHeading` -> WidgetFor UniWorX () -> HandlerFor UniWorX Html @@ -130,6 +132,7 @@ siteLayout = siteLayout' . Just siteLayout' :: ( BearerAuthSite UniWorX , YesodPersistBackend UniWorX ~ SqlBackend + , MonadSecretBox (HandlerFor UniWorX) ) => Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading` -> WidgetFor UniWorX () -> HandlerFor UniWorX Html @@ -496,6 +499,12 @@ siteLayout' overrideHeading widget = do toWidget $(juliusFile "templates/current-route.julius") wellKnownHtmlLinks + whenM doFormHoneypots $ do + honeypotSecrets' <- liftHandler $ sortOn (view _2) . ifoldMap (\isHoneypot -> map (isHoneypot, ) . otoList) <$> honeypotSecrets + forM_ honeypotSecrets' $ \(isHoneypot, hpSecret) -> toWidget $ if + | isHoneypot -> CssBuilder . LTB.fromLazyText $ "[data-uw-field-display=\"" <> fromStrict hpSecret <> "\"]{display:none!important}" + | otherwise -> CssBuilder . LTB.fromLazyText $ "[data-uw-field-display=\"" <> fromStrict hpSecret <> "\"]{/*display:none!important*/}" + $(widgetFile "default-layout") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") diff --git a/src/Handler/Utils/Random.hs b/src/Handler/Utils/Random.hs new file mode 100644 index 000000000..6821be9c7 --- /dev/null +++ b/src/Handler/Utils/Random.hs @@ -0,0 +1,66 @@ +module Handler.Utils.Random + ( secretBoxCSPRNGT, secretBoxCSPRNGPure + , secretBoxCSPRNG' + ) where + +import Import.NoModel + +import qualified Crypto.MAC.KMAC as Crypto +import qualified Crypto.Saltine.Class as Saltine +import Crypto.Hash.Algorithms (SHAKE256) +import Data.ByteArray (ByteArrayAccess) +import qualified Data.ByteArray as BA + +import qualified Crypto.Random as Crypto +import Crypto.Error (onCryptoFailure) + +import Control.Monad.Random.Lazy (RandT, Rand, evalRandT) + + +secretBoxCSPRNG' :: forall m m' string ba chunk a. + ( MonadSecretBox m + , MonadThrow m + , Monad m' + , ByteArrayAccess string + , ByteArrayAccess chunk + , LazySequence ba chunk + ) + => (forall b. m' b -> m b) + -> string -- ^ Customization string + -> ba -- ^ Seed + -> RandT ChaChaDRG m' a + -> m a +secretBoxCSPRNG' nat str seed act = do + sBoxKey <- secretBoxKey + let seed' = toDigest $ kmaclazy str (Saltine.encode sBoxKey) seed + where toDigest :: Crypto.KMAC (SHAKE256 320) -> ByteString + toDigest = BA.convert + csprng <- fmap Crypto.drgNewSeed . onCryptoFailure throwM return $ Crypto.seedFromBinary seed' + + nat $ evalRandT act csprng + +secretBoxCSPRNGT :: forall m string ba chunk a. + ( MonadSecretBox m + , MonadThrow m + , ByteArrayAccess string + , ByteArrayAccess chunk + , LazySequence ba chunk + ) + => string -- ^ Customization string + -> ba -- ^ Seed + -> RandT ChaChaDRG m a + -> m a +secretBoxCSPRNGT = secretBoxCSPRNG' id + +secretBoxCSPRNGPure :: forall m string ba chunk a. + ( MonadSecretBox m + , MonadThrow m + , ByteArrayAccess string + , ByteArrayAccess chunk + , LazySequence ba chunk + ) + => string -- ^ Customization string + -> ba -- ^ Seed + -> Rand ChaChaDRG a + -> m a +secretBoxCSPRNGPure = secretBoxCSPRNG' generalize diff --git a/src/Utils.hs b/src/Utils.hs index 70cc0d4d0..2a2e2ae23 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -614,6 +614,9 @@ partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) . mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v) mapFromSetM = (sequenceA .) . Map.fromSet +mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v) +mapFM = sequenceA . mapF + mapFilterM :: (Monad m, Ord k) => (v -> m Bool) -> Map k v -> m (Map k v) mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . assertMM (lift . f) . hoistMaybe)) (Map.keys m) @@ -1447,8 +1450,10 @@ unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a] unstableSort = unstableSortBy compare uniforms :: (RandomGen g, MonadSplit g m, Foldable t) => t a -> m [a] -uniforms xs = LazyRand.evalRand go <$> getSplit - where go = (:) <$> interleave (uniform xs) <*> go +uniforms xs = LazyRand.evalRand (randomInfiniteList $ uniform xs) <$> getSplit + +randomInfiniteList :: MonadInterleave m => m a -> m [a] +randomInfiniteList gen = interleave $ (:) <$> gen <*> randomInfiniteList gen randUUIDC :: MonadIO m => (forall m'. Monad m' => m' UUID -> (forall a. m a -> m' a) -> ConduitT i o m' r) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1f5721d85..5533b9977 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -34,15 +34,15 @@ import qualified Control.Monad.State.Class as State import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST) import Control.Monad.Trans.State (runStateT, evalStateT) import Control.Monad.Trans.Except (ExceptT, runExceptT) +import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT) import Control.Monad.Fix (MonadFix) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Base import Control.Monad.Catch (MonadCatch) -import Control.Monad.Random.Strict (evalRandT) -import Control.Monad.Random.Class (uniformMay, getRandomR, getRandomRs, weighted) +import Control.Monad.Random.Class (uniform, uniformMay, getRandom, getRandomR, getRandomRs, weighted) -import Data.List ((!!)) +import Data.List (nub, (!!)) import Web.PathPieces @@ -69,14 +69,12 @@ import Data.Either (fromRight) import qualified Database.Esqueleto.Legacy as E -import qualified Crypto.MAC.KMAC as Crypto -import qualified Crypto.Saltine.Class as Saltine -import Crypto.Hash.Algorithms (SHAKE256) -import qualified Data.ByteArray as BA +import Handler.Utils.Random + import qualified Data.Binary as Binary -import qualified Crypto.Random as Crypto -import Crypto.Error (maybeCryptoError) +import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded) +import qualified Data.ByteString as BS ------------ @@ -1000,17 +998,21 @@ type RenderAFormSite :: Type -> Constraint type RenderAFormSite site = ( RenderMessage site AFormMessage , RenderMessage site UrlFieldMessage , MonadSecretBox (HandlerFor site) + , MonadSecretBox (MaybeT (RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (Lazy.WriterT [FieldView site] (HandlerFor site)))) , YesodAuth site, HasAppSettings site ) renderAForm :: (MonadHandler m, RenderAFormSite (HandlerSite m)) => FormLayout -> FormRender m a renderAForm formLayout aform' fragment = do (res, ($ []) -> fieldViews') <- aFormToForm aform - fieldViews <- forM fieldViews' . runStateT $ do - isHoneypot <- is _Just <$> preuse (_fvId . _HoneypotFieldId) + doHoneypots <- doFormHoneypots + honeypotSecrets' <- liftHandler honeypotSecrets + fieldViews <- liftHandler . secretBoxCSPRNGT (encodeUtf8 $ tshow ('renderAForm, "fieldViews")) (Binary.encode $ fieldViews' ^.. folded . _fvId) . forM fieldViews' . runStateT $ do + isHoneypot <- and2M (pure doHoneypots) $ is _Just <$> preuse (_fvId . _HoneypotFieldId) when isHoneypot $ - _fvId <~ newIdent - (isHoneypot, ) <$> newIdent + _fvId <~ lift (lift newIdent) + honeypotHiddenSecret <- uniform . toNullable $ honeypotSecrets' Map.! isHoneypot + lift . lift $ (honeypotHiddenSecret, ) <$> newIdent let formHasRequiredFields = any fvRequired fieldViews' widget = $(widgetFile "widgets/aform/aform") return (res, widget) @@ -1078,29 +1080,42 @@ fvWidget :: FieldView site -> WidgetFor site () fvWidget FieldView{..} = $(widgetFile "widgets/field-view/field-view") +doFormHoneypots :: ( MonadHandler m + , HasAppSettings (HandlerSite m) + , YesodAuth (HandlerSite m) + ) + => m Bool +doFormHoneypots = and2M + (getsYesod . views _appBotMitigations $ Set.member SettingBotMitigationUnauthorizedFormHoneypots) + (is _Nothing <$> maybeAuthId) + +honeypotSecrets :: ( MonadSecretBox m + , MonadThrow m + ) + => m (Map Bool (NonNull (Set Text))) +honeypotSecrets = secretBoxCSPRNGPure (encodeUtf8 $ tshow 'honeypotSecrets) (Binary.encode secretsNum) $ do + idents <- take (2 * secretsNum) . nub <$> randomInfiniteList randomIdent + let (hpIdents, noHPIdents) = splitAt secretsNum idents + return . mapF $ impureNonNull . Set.fromList . bool noHPIdents hpIdents + where + secretsNum = 10 + + randomIdent = decodeUtf8 . Base64.encodeUnpadded . BS.pack <$> replicateM 18 getRandom + + aformHoneypot :: forall m a. - ( MonadSecretBox (HandlerFor (HandlerSite m)) - , MonadHandler m, YesodAuth (HandlerSite m), HasAppSettings (HandlerSite m) - , RenderMessage (HandlerSite m) AFormMessage, RenderMessage (HandlerSite m) UrlFieldMessage + ( RenderAFormSite (HandlerSite m) + , MonadHandler m ) => AForm m a -> AForm m a aformHoneypot (aFormToWForm -> wform) = wFormToAForm . maybeT wform $ do - guardM $ and2M - (getsYesod . views _appBotMitigations $ Set.member SettingBotMitigationUnauthorizedFormHoneypots) - (is _Nothing <$> maybeAuthId) + guardM doFormHoneypots (res, fields) <- lift $ wFormFields wform guard $ hasn't (folded . _fvId . _HoneypotFieldId) fields - sBoxKey <- liftHandler secretBoxKey - let - formSeed = toDigest . kmaclazy (encodeUtf8 $ tshow 'aformHoneypot) (Saltine.encode sBoxKey) . Binary.encode $ map (fvId &&& fvRequired) fields - where toDigest :: Crypto.KMAC (SHAKE256 320) -> ByteString - toDigest = BA.convert - csprng <- fmap Crypto.drgNewSeed . hoistMaybe . maybeCryptoError $ Crypto.seedFromBinary formSeed - MsgRenderer mr <- getMsgRenderer - flip evalRandT csprng $ do + hoist (hoist $ hoist liftHandler) . secretBoxCSPRNGT (encodeUtf8 $ tshow 'aformHoneypot) (Binary.encode $ map (fvId &&& fvRequired) fields) $ do k <- getRandomR @_ @Double (0, 1) poss <- getRandomRs (0, length fields) let honeypotCount = 2 + round (realToFrac (fromIntegral (length fields) * honeypotProportion) * k) @@ -1172,7 +1187,7 @@ aformHoneypot (aFormToWForm -> wform) = wFormToAForm . maybeT wform $ do honeypotProportion :: Rational honeypotProportion = 1 % 3 - censorHoneypot :: forall a'. WForm m a' -> WForm m a' + censorHoneypot :: forall a'. WForm (HandlerFor (HandlerSite m)) a' -> WForm (HandlerFor (HandlerSite m)) a' censorHoneypot = hoist $ censor (set (mapped . _fvId) $ _HoneypotFieldId # () :: [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)]) honeypotAttrs = addAttr "tabindex" "-1" . noAutocomplete diff --git a/templates/widgets/aform/aform.hamlet b/templates/widgets/aform/aform.hamlet index 229defc0e..06816b09c 100644 --- a/templates/widgets/aform/aform.hamlet +++ b/templates/widgets/aform/aform.hamlet @@ -2,24 +2,24 @@ $newline never #{fragment} $case formLayout $of FormDBTablePagesize - $forall ((isHoneypot, wrapId), view) <- fieldViews -
+ $forall ((honeypotHiddenSecret, wrapId), view) <- fieldViews +