refactor(form-honeypots): hide honeypots via custom attribute

2022-04-20 19:01:42 +02:00 · 2022-04-20 19:01:42 +02:00 · 5a3f57715b
commit 5a3f57715b
parent 8085c30420
6 changed files with 135 additions and 38 deletions
--- 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{..}
+
+  
--- 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")

--- a/src/Handler/Utils/Random.hs
+++ 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
--- 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)
--- 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
--- 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
-      <div ##{wrapId} :isHoneypot:style="display: none !important" :not isHoneypot:style="display: inline-block">
+    $forall ((honeypotHiddenSecret, wrapId), view) <- fieldViews
+      <div ##{wrapId} :doHoneypots:data-uw-field-display=#{honeypotHiddenSecret} style="display: inline-block">
        <label .form-group-label.label-pagesize for=#{fvId view}>#{fvLabel view}
        ^{fvInput view}
  $of _
-    $forall ((isHoneypot, wrapId), view) <- fieldViews
+    $forall ((honeypotHiddenSecret, wrapId), view) <- fieldViews
      $if fvId view == idFormSectionNoinput
-        <div ##{wrapId} :isHoneypot:style="display: none !important" .form-section-title .interactive-fieldset__target :isFormVertical:.form--vertical>
+        <div ##{wrapId} :doHoneypots:data-uw-field-display=#{honeypotHiddenSecret} .form-section-title .interactive-fieldset__target :isFormVertical:.form--vertical>
          <h3>
            ^{fvLabel view}
          $maybe hint <- fvTooltip view
            <div .form-section-title__hint .interactive-fieldset__target :isFormVertical:.form--vertical>
              ^{hint}
      $elseif fvId view == idFormMessageNoinput
-        <div ##{wrapId} :isHoneypot:style="display: none !important" .form-section-notification .interactive-fieldset__target :isFormVertical:.form--vertical>
+        <div ##{wrapId} :doHoneypots:data-uw-field-display=#{honeypotHiddenSecret} .form-section-notification .interactive-fieldset__target :isFormVertical:.form--vertical>
          ^{fvInput view}
      $else
-        <div ##{wrapId} :isHoneypot:style="display: none !important" .form-group .interactive-fieldset__target :fvRequired view && not isFormWorkflowDataset:.form-group--required :fvRequired view && isFormWorkflowDataset:.form-group--potentially-required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error :isFormVertical:.form--vertical>
+        <div ##{wrapId} :doHoneypots:data-uw-field-display=#{honeypotHiddenSecret} .form-group .interactive-fieldset__target :fvRequired view && not isFormWorkflowDataset:.form-group--required :fvRequired view && isFormWorkflowDataset:.form-group--potentially-required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error :isFormVertical:.form--vertical>
          $if not (Blaze.null $ fvLabel view)
            <label .form-group-label for=#{fvId view}>
              <span .form-group-label__caption>