Skip to content

Commit d478b0d

Browse files
stepcutstepcut
committed
add support for humanity checking on create user page
1 parent 7af4e1c commit d478b0d

6 files changed

Lines changed: 157 additions & 30 deletions

File tree

‎happstack-authenticate.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Cabal-version: 2.2
22
Name: happstack-authenticate
3-
Version: 3.1.1
3+
Version: 3.2.0
44
Synopsis: Happstack Authentication Library
55
Description: A themeable authentication library with support for username+password
66
Homepage: http://www.happstack.com/

‎messages/password/error/en.msg‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ InvalidResetToken: Invalid reset token
99
ExpiredResetToken: The password reset link you used has expired. You must request a new reset link.
1010
PasswordInternalError: Your request could not be processed. You probably need to contact technical support to resolve this issue.
1111
PasswordMismatch: Passwords do not match
12+
HumanityCheckFailed: Humanity checked failed. Are you sure you are not a robot?
1213
SendmailError: A server configuration error prevented an email from being sent. Please contact us directly
1314
UnacceptablePassword msg@Text: Unacceptable Password. #{msg}
1415
CoreError e@CoreError: #{renderMessage HappstackAuthenticateI18N ["en"] e}

‎src/Happstack/Authenticate/Client.hs‎

Lines changed: 45 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ import Dominator.DOMC
4848
import Dominator.JSDOM
4949
import GHCJS.Marshal(toJSVal, fromJSVal)
5050
import GHCJS.Foreign.Export (Export, export, derefExport)
51-
import GHCJS.Foreign.Callback (Callback, syncCallback1, OnBlocked(ContinueAsync))
51+
import GHCJS.Foreign.Callback (OnBlocked(..), Callback, syncCallback1, OnBlocked(ContinueAsync))
5252
import GHCJS.Nullable (Nullable(..), nullableToMaybe, maybeToNullable)
5353
import GHCJS.Types (JSVal, jsval)
5454
import Happstack.Authenticate.Core (ClientInitData(..), Email(..), User(..), Username(..), AuthenticateURL(AmAuthenticated, AuthenticationMethods, InitClient, Logout), AuthenticationMethod(..), JSONResponse(..), Status(..), jsonOptions)
@@ -107,6 +107,7 @@ data AuthenticateModel = AuthenticateModel
107107
, _postLoginRedirectURL :: Maybe Text
108108
, _postSignupRedirectURL :: Maybe Text
109109
, _redraws :: [AuthenticateModel -> IO ()]
110+
, _turnstileToken :: Maybe Text
110111
}
111112
makeLenses ''AuthenticateModel
112113

@@ -143,6 +144,7 @@ initAuthenticateModel = AuthenticateModel
143144
, _postLoginRedirectURL = Nothing
144145
, _postSignupRedirectURL = Nothing
145146
, _redraws = []
147+
, _turnstileToken = Nothing
146148
}
147149

148150
data SignupPlugin = forall a. SignupPlugin
@@ -188,10 +190,14 @@ dummyPlugin = SignupPlugin
188190
signupPasswordForm :: [(Text, SignupPlugin)] -> JSDocument -> IO (JSNode, AuthenticateModel -> IO ())
189191
signupPasswordForm sps =
190192
[domc|
193+
<div>
194+
<div id="cf-turnstile-widget" class="cf-turnstile"></div>
195+
191196
<d-if cond="isJust (_muser model)">
192197
<p>
193198
<span>You are currently logged in as </span><span>{{ maybe "Unknown" (Text.unpack . _unUsername . _username) (_muser model) }}</span><span>. To create a new account you must first </span><a data-ha-action="logout" href="#">{{ render LogoutMsg }}</a>
194199
</p>
200+
195201
<form role="form">
196202
<div class="form-group error">{{_signupError model}}</div>
197203
<div class="form-group">
@@ -215,7 +221,9 @@ signupPasswordForm sps =
215221
<input class="form-control" type="submit" value="{{render SignUpMsg}}" />
216222
</div>
217223
</form>
224+
218225
</d-if>
226+
</div>
219227
|]
220228
where
221229
pluginList :: JSDocument -> IO (JSNode, SignupPlugin -> IO ())
@@ -615,11 +623,15 @@ signupHandler :: (AuthenticateURL -> Text) -> [(Text, SignupPlugin)] -> JSElemen
615623
signupHandler routeFn sps rootNode inputUsername inputEmail inputPassword inputPasswordConfirm modelTV e =
616624
do preventDefault e
617625
stopPropagation e
626+
618627
musername <- getValue inputUsername
619628
memail <- getValue inputEmail
620629
mpassword <- getValue inputPassword
621630
mpasswordConfirm <- getValue inputPasswordConfirm
622-
debugStrLn $ "signupHandler - " ++ show (musername, memail, mpassword, mpasswordConfirm)
631+
632+
token <- atomically $ fmap _turnstileToken (readTVar modelTV )
633+
debugStrLn $ "signupHandler - " ++ show (musername, memail, mpassword, mpasswordConfirm, token)
634+
623635
case (musername, memail, mpassword, mpasswordConfirm) of
624636
(Just username, Just email, Just password, Just passwordConfirm) ->
625637
do let newAccountData =
@@ -629,6 +641,7 @@ signupHandler routeFn sps rootNode inputUsername inputEmail inputPassword inputP
629641
}
630642
, _naPassword = textFromJSString password
631643
, _naPasswordConfirm = textFromJSString passwordConfirm
644+
, _naTurnstileToken = token
632645
}
633646

634647
-- validate plugins
@@ -858,9 +871,22 @@ clearUser routeFn modelTV =
858871
send xhr
859872
doRedraws modelTV
860873

874+
-- foreign import javascript unsafe "turnstile.render($1, { sitekey: $2, callback: function(token) {console.log('turnstile success', token);} })"
875+
foreign import javascript unsafe "turnstile.render($1, { sitekey: $2, callback: $3 })"
876+
js_turnstileRender :: JSString -> JSString -> Callback (JSVal -> IO ()) -> IO JSVal
877+
878+
-- NOTE: instead of selector, render can also take an implementation of HTMLElement
879+
-- we should implement a binding to that version as well
880+
turnstileRender :: Text -> Text -> (JSString -> IO ()) -> IO JSVal
881+
turnstileRender turnstileId turnstileSiteKey onSuccess =
882+
do cb <- syncCallback1 ThrowWouldBlock (\jsval ->
883+
do (Just token) <- fromJSVal (jsval :: JSVal)
884+
onSuccess token)
885+
js_turnstileRender (textToJSString turnstileId) (textToJSString turnstileSiteKey) cb
886+
861887
-- FIXME: what happens if this is called twice?
862-
initHappstackAuthenticateClient :: Text -> [(Text, SignupPlugin)] -> IO ()
863-
initHappstackAuthenticateClient baseURL sps =
888+
initHappstackAuthenticateClient :: Text -> Maybe Text -> [(Text, SignupPlugin)] -> IO ()
889+
initHappstackAuthenticateClient baseURL mTurnstileKey sps =
864890
do debugStrLn "initHappstackAuthenticateClient"
865891
hSetBuffering stdout LineBuffering
866892
(Just d) <- currentDocument
@@ -955,6 +981,18 @@ initHappstackAuthenticateClient baseURL sps =
955981
let (Just newElem) = fromJSNode @JSElement newNode
956982
addEventListener newNode (ev @Submit) (signupHandler (\url -> baseURL <> toPathInfo url) sps newElem inputUsername inputEmail inputPassword inputPasswordConfirm modelTV) False
957983
addEventListener newNode (ev @Click) (logoutHandler (\url -> baseURL <> toPathInfo url) update modelTV) False
984+
985+
-- add turnstile widget
986+
let addTurnstileToken :: JSString -> IO ()
987+
addTurnstileToken token =
988+
do debugStrLn "Adding turnstile token"
989+
atomically $ modifyTVar' modelTV $ \m -> m { _turnstileToken = Just (textFromJSString token) }
990+
991+
case mTurnstileKey of
992+
Nothing -> pure ()
993+
(Just siteKey) ->
994+
do tId <- turnstileRender "#cf-turnstile-widget" siteKey addTurnstileToken
995+
pure ()
958996
pure update
959997
-- addEventListener newNode (ev @Click) (logoutHandler (\url -> baseURL <> toPathInfo url) update modelTV) False
960998
-- listen for changes to local storage
@@ -1190,8 +1228,10 @@ clientMain sps =
11901228
(Just script) ->
11911229
do mUrl <- getData (toJSNode script) "baseUrl"
11921230
debugStrLn $ "mUrl = " ++ show mUrl
1231+
mTurnstileKey <- getData (toJSNode script) "turnstileKey"
1232+
debugStrLn $ "turnstileKey = " ++ show mTurnstileKey
11931233
case mUrl of
11941234
Nothing -> debugStrLn "could not find base url"
11951235
(Just url) ->
11961236
do mapM_ (debugStrLn . Text.unpack . fst) sps
1197-
initHappstackAuthenticateClient (textFromJSString url) sps
1237+
initHappstackAuthenticateClient (textFromJSString url) (fmap textFromJSString mTurnstileKey) sps

‎src/Happstack/Authenticate/Handlers.hs‎

Lines changed: 41 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -146,19 +146,43 @@ deriveSafeCopy 1 'base ''NewAccountMode
146146
-- AuthenticateState
147147
------------------------------------------------------------------------------
148148

149+
data Turnstile = Turnstile
150+
{ turnstileSiteKey :: Text
151+
, turnstileSecretKey :: Text
152+
}
153+
deriving (Eq, Show, Typeable, Generic)
154+
deriveSafeCopy 1 'base ''Turnstile
155+
makeLenses ''Turnstile
156+
149157
-- | this acid-state value contains the state common to all
150158
-- authentication methods
159+
data AuthenticateState_1 = AuthenticateState_1
160+
{ _sharedSecrets_1 :: SharedSecrets
161+
, _users_1 :: IxUser
162+
, _nextUserId_1 :: UserId
163+
, _defaultSessionTimeout_1 :: Int -- ^ default session time out in seconds
164+
, _newAccountMode_1 :: NewAccountMode
165+
}
166+
deriving (Eq, Show, Typeable, Generic)
167+
deriveSafeCopy 1 'base ''AuthenticateState_1
168+
makeLenses ''AuthenticateState_1
169+
151170
data AuthenticateState = AuthenticateState
152171
{ _sharedSecrets :: SharedSecrets
153172
, _users :: IxUser
154173
, _nextUserId :: UserId
155174
, _defaultSessionTimeout :: Int -- ^ default session time out in seconds
156175
, _newAccountMode :: NewAccountMode
176+
, _turnstile :: Maybe Turnstile
157177
}
158178
deriving (Eq, Show, Typeable, Generic)
159-
deriveSafeCopy 1 'base ''AuthenticateState
179+
deriveSafeCopy 2 'extension ''AuthenticateState
160180
makeLenses ''AuthenticateState
161181

182+
instance Migrate AuthenticateState where
183+
type MigrateFrom AuthenticateState = AuthenticateState_1
184+
migrate (AuthenticateState_1 ss us nui dst nam) = AuthenticateState ss us nui dst nam Nothing
185+
162186
-- | a reasonable initial 'AuthenticateState'
163187
initialAuthenticateState :: AuthenticateState
164188
initialAuthenticateState = AuthenticateState
@@ -167,6 +191,7 @@ initialAuthenticateState = AuthenticateState
167191
, _nextUserId = UserId 1
168192
, _defaultSessionTimeout = 60*60
169193
, _newAccountMode = OpenRegistration
194+
, _turnstile = Nothing
170195
}
171196

172197
------------------------------------------------------------------------------
@@ -216,6 +241,19 @@ getNewAccountMode :: Query AuthenticateState NewAccountMode
216241
getNewAccountMode =
217242
view newAccountMode
218243

244+
------------------------------------------------------------------------------
245+
-- Turnstile AcidState Methods
246+
------------------------------------------------------------------------------
247+
248+
-- | set 'Turnstile' data
249+
setTurnstile :: Maybe Turnstile
250+
-> Update AuthenticateState ()
251+
setTurnstile t =
252+
turnstile .= t
253+
254+
getTurnstile :: Query AuthenticateState (Maybe Turnstile)
255+
getTurnstile = view turnstile
256+
219257
------------------------------------------------------------------------------
220258
-- User related AcidState Methods
221259
------------------------------------------------------------------------------
@@ -328,6 +366,8 @@ makeAcidic ''AuthenticateState
328366
, 'getUserByEmail
329367
, 'getUsersByEmail
330368
, 'getAuthenticateState
369+
, 'setTurnstile
370+
, 'getTurnstile
331371
]
332372

333373
------------------------------------------------------------------------------

‎src/Happstack/Authenticate/Password/Core.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -66,6 +66,7 @@ data PasswordError
6666
| PasswordInternalError
6767
| PasswordMismatch
6868
| SendmailError
69+
| HumanityCheckFailed
6970
| UnacceptablePassword { passwordErrorMessageMsg :: Text }
7071
| CoreError { passwordErrorMessageE :: CoreError }
7172
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
@@ -144,6 +145,7 @@ data NewAccountData = NewAccountData
144145
{ _naUser :: User
145146
, _naPassword :: Text
146147
, _naPasswordConfirm :: Text
148+
, _naTurnstileToken :: Maybe Text
147149
}
148150
deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
149151
makeLenses ''NewAccountData

‎src/Happstack/Authenticate/Password/Handlers.hs‎

Lines changed: 67 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ import Happstack.Authenticate.Password.Core
4141
import Happstack.Server
4242
import HSP.JMacro
4343
import Language.Javascript.JMacro
44+
import Network.HTTP.Simple (Request(..), httpJSON, getResponseBody, parseRequest, setRequestBodyJSON, setRequestMethod)
4445
import Network.HTTP.Types (toQuery, renderQuery)
4546
import Network.Mail.Mime (Address(..), Mail(..), simpleMail', renderAddress, renderMail', renderSendMail, renderSendMailCustom, sendmail)
4647
import System.FilePath (combine)
@@ -166,6 +167,29 @@ verifyPassword authenticateState passwordState username password =
166167
(Just user) ->
167168
query' passwordState (VerifyPasswordForUserId (view userId user) password)
168169

170+
171+
verifyTurnstileToken :: Text -> Maybe Text -> IO (Either (Maybe Value) ())
172+
verifyTurnstileToken _ Nothing = pure (Left Nothing)
173+
verifyTurnstileToken secret (Just token) =
174+
do initReq <- parseRequest "https://challenges.cloudflare.com/turnstile/v0/siteverify"
175+
let reqJson = Object (HashMap.fromList [ ( "secret", String secret)
176+
, ("response", String token)
177+
])
178+
req = setRequestMethod "POST" $
179+
setRequestBodyJSON reqJson $
180+
initReq
181+
resp <- httpJSON req
182+
let json = getResponseBody resp
183+
-- liftIO $ print resp
184+
case json of
185+
(Object obj) ->
186+
case HashMap.lookup "success" obj of
187+
Nothing -> pure (Left (Just json))
188+
(Just success) | success == (Bool True) -> pure (Right ())
189+
| otherwise -> pure (Left (Just json))
190+
_ -> pure (Left (Just json))
191+
192+
169193
-- | account handler
170194
account :: (Happstack m) =>
171195
AcidState AuthenticateState
@@ -182,32 +206,52 @@ account authenticateState passwordState authenticateConfig passwordConfig Nothin
182206
case Aeson.decode body of
183207
Nothing -> badRequest (Left $ CoreError JSONDecodeFailed)
184208
(Just newAccount) ->
185-
case (authenticateConfig ^. usernameAcceptable) (newAccount ^. naUser ^. username) of
186-
(Just e) -> return $ Left (CoreError e)
187-
Nothing ->
188-
case validEmail (authenticateConfig ^. requireEmail) (newAccount ^. naUser ^. email) of
189-
(Just e) -> return $ Left e
190-
Nothing ->
191-
if (newAccount ^. naPassword /= newAccount ^. naPasswordConfirm)
192-
then ok $ Left PasswordMismatch
193-
else case (passwordConfig ^. passwordAcceptable) (newAccount ^. naPassword) of
194-
(Just passwdError) -> ok $ Left (UnacceptablePassword passwdError)
195-
Nothing -> do
196-
eUser <- update' authenticateState (CreateUser $ _naUser newAccount)
197-
case eUser of
198-
(Left e) -> return $ Left (CoreError e)
199-
(Right user) -> do
200-
hashed <- mkHashedPass (_naPassword newAccount)
201-
update' passwordState (SetPassword (user ^. userId) hashed)
202-
case (authenticateConfig ^. createUserCallback) of
203-
Nothing -> pure ()
204-
(Just callback) -> liftIO $ callback user
209+
-- is username acceptable
210+
do case (authenticateConfig ^. usernameAcceptable) (newAccount ^. naUser ^. username) of
211+
(Just e) -> return $ Left (CoreError e)
212+
Nothing ->
213+
-- does email appear to be valid
214+
case validEmail (authenticateConfig ^. requireEmail) (newAccount ^. naUser ^. email) of
215+
(Just e) -> return $ Left e
216+
Nothing ->
217+
-- do the passwords match
218+
if (newAccount ^. naPassword /= newAccount ^. naPasswordConfirm)
219+
then ok $ Left PasswordMismatch
220+
-- is the password acceptable
221+
else case (passwordConfig ^. passwordAcceptable) (newAccount ^. naPassword) of
222+
(Just passwdError) -> ok $ Left (UnacceptablePassword passwdError)
223+
Nothing -> do
224+
mUser <- query' authenticateState (GetUserByUsername (newAccount ^. naUser ^. username))
225+
-- is the username aready in use
226+
case mUser of
227+
(Just _) -> return $ Left (CoreError UsernameAlreadyExists)
228+
Nothing -> do
229+
mTurnstile <- query' authenticateState GetTurnstile
230+
isHuman <-
231+
case mTurnstile of
232+
Nothing -> pure (Right ())
233+
(Just turnstile) ->
234+
liftIO $ verifyTurnstileToken (turnstileSecretKey turnstile) (newAccount ^. naTurnstileToken)
235+
case isHuman of
236+
(Left mError) ->
237+
do -- liftIO $ print mError
238+
pure $ Left HumanityCheckFailed
239+
(Right ()) -> do
240+
eUser <- update' authenticateState (CreateUser $ _naUser newAccount)
241+
case eUser of
242+
(Left e) -> return $ Left (CoreError e)
243+
(Right user) -> do
244+
hashed <- mkHashedPass (_naPassword newAccount)
245+
update' passwordState (SetPassword (user ^. userId) hashed)
246+
case (authenticateConfig ^. createUserCallback) of
247+
Nothing -> pure ()
248+
(Just callback) -> liftIO $ callback user
205249
-- ok $ (Right (user ^. userId))
206-
addTokenCookie authenticateState authenticateConfig user
250+
addTokenCookie authenticateState authenticateConfig user
207251
#if MIN_VERSION_aeson(2,0,0)
208-
resp 201 $ Right (Object $ KM.fromList [("token", toJSON (Token user))])
252+
resp 201 $ Right (Object $ KM.fromList [("token", toJSON (Token user))])
209253
#else
210-
resp 201 $ Right (Object $ HashMap.fromList [("token", toJSON (Token user))])
254+
resp 201 $ Right (Object $ HashMap.fromList [("token", toJSON (Token user))])
211255
#endif
212256
where
213257
validEmail :: Bool -> Maybe Email -> Maybe PasswordError

0 commit comments

Comments
 (0)