Add signup form, captcha check.

[?]

Sep 9, 2020, 5:26 AM

O2BZOX7MS4JCDS3C6EJQXAWUEQV6HVDCIF2FIN2BCJNRLIU6ZVKAC

Dependencies

[2] UWMGUJOW Autoformat sources.
[3] SAESJLLY Initial experiments in hash routing.
[4] EA5BFM5G Split Login component into its own module.
[5] TKGBRIQT Login component now raises LoginComplete message.
[6] TUA4HMUD Use real API capability for login.
[7] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[8] MB5SHULB Add route for accepting an invitation with an existing account
[9] B6HWAPDP Modularize & update to recent haskoin.
[10] JXG3FCXY Upgrade ps + halogen versions.
[11] 5R2Z7FSX Initial rendering for signup controls.
[12] PBD7LZYQ Postgres & auth are beginning to function.
[13] I2KHGVD4 Require project permissions for access to most data.
[14] NEDDHXUK Reformat via stylish-haskell
[15] OUR4PAOT Use local dates for display of intervals.
[16] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[17] 6L5BK5EH Use generic SMTP rather than Sendmail-specific mail client.
[18] DFOBMSAO Initial work on payments API
[19] BROSTG5K Beginning of modularization of server.
[20] IPG33FAW Add billing daemon
[21] QMEYU4MW Add display for prior intervals.
[22] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[23] BXGLKYRX Added primitive user registration handler.
[24] EFSXYZPO Autoformat everything with brittany.
[25] WRPIYG3E Use project listing functionality to check for whether we have a cookie.
[26] HMDM3B55 Implement core of payments/billing infrastructure.
[27] 3LMXT7Z6 preventDefault on login form submission.
[28] NJNMO72S Add zcash.com submodule and update client to modern halogen.
[29] LTSVBVA2 Update to a recent haskoin-core. Fix Stack build.
[30] 4R7XIYK3 Switch from ClassyPrelude to Relude
[31] PT4276XC Add logout functionality.
[*] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[*] WZFQDWW4 Add retrieval/storage of current exchange rate data to payment recording.
[*] TCOAKCGG Completed conversion to snap.
[*] RSF6UAJK Break out api module for timeline.
[*] RB2ETNIF Add skeletal PureScript client project.
[*] V2VDN77H Enable postgres configuration via environment variable for Heroku.
[*] ADMKQQGC Initial empty Snap project.

Change contents

edit in aftok.cabal at line 164

[34.214]

[34.214]

, http-client-tls
edit in aftok.cabal at line 166

[34.240]

[35.41]

, http-types
edit in client/dev/index.html at line 8

[3.155]

[4.2649]

<script src="https://www.google.com/recaptcha/api.js" async defer></script>
edit in client/spago.dhall at line 12

[4.389]

[4.389]

, "validation"
file addition: Account.purs (----------)

[36.1]

module Aftok.Api.Account where

import Prelude

import Control.Monad.Trans.Class (lift)

import Data.Argonaut.Encode (encodeJson)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))

import Effect.Aff (Aff)
import Effect.Class.Console (log)
import Affjax (post, get, printError)
import Affjax.StatusCode (StatusCode(..))
import Affjax.RequestBody as RB
import Affjax.ResponseFormat as RF

import Halogen as H
import Halogen.HTML.Core (ClassName(..))
import Halogen.HTML as HH
import Halogen.HTML.CSS as CSS
import Halogen.HTML.Events as E
import Web.Event.Event as WE
import Halogen.HTML.Properties as P

import CSS (backgroundImage, url)

import Landkit.Card as Card

import Aftok.Types (System)

type LoginRequest = { username :: String, password :: String }

data LoginResponse
= LoginOK
| LoginForbidden
| LoginError { status :: Maybe StatusCode, message :: String }

-- | Post credentials to the login service and interpret the response
login :: String -> String -> Aff LoginResponse
login user pass = do
log "Sending login request to /api/login ..."
result <- post RF.ignore "/api/login" (Just <<< RB.Json <<< encodeJson $ { username: user, password : pass })
case result of
Left err -> log ("Login failed: " <> printError err)
Right r -> log ("Login status: " <> show r.status)
pure $ case result of
Left err -> LoginError { status: Nothing, message: printError err }
Right r -> case r.status of
StatusCode 403 -> LoginForbidden
StatusCode 200 -> LoginOK
other -> LoginError { status: Just other, message: r.statusText }

checkLogin :: Aff LoginResponse
checkLogin = do
result <- get RF.ignore "/api/login/check"
case result of
Left err -> do
pure $ LoginError { status: Nothing, message: printError err }
Right r -> do
pure $ case r.status of
StatusCode 200 -> LoginOK
StatusCode _ -> LoginForbidden

logout :: Aff Unit
logout = void $ get RF.ignore "/api/logout"

data RecoverBy
= RecoverByEmail String
| RecoverByZAddr String

type SignupRequest =
{ username :: String
, password :: String
, recoverBy :: RecoverBy
, captchaToken :: String
}

signupRequest :: String -> String -> RecoverBy -> String -> SignupRequest
signupRequest username password recoverBy captchaToken =
{ username, password, recoverBy, captchaToken }

data SignupResponse
= SignupOK
| CaptchaInvalid
| ZAddrInvalid
| UsernameTaken

data UsernameCheckResponse
= UsernameCheckOK
| UsernameCheckTaken

data ZAddrCheckResponse
= ZAddrCheckOK
| ZAddrCheckInvalid

checkUsername :: String -> Aff UsernameCheckResponse
checkUsername uname = do
pure UsernameCheckOK

checkZAddr :: String -> Aff ZAddrCheckResponse
checkZAddr zaddr = do
pure ZAddrCheckOK

signup :: SignupRequest -> Aff SignupResponse
signup req = do
pure SignupOK
file addition: Recaptcha.js (----------)

[36.1]

"use strict";

exports.getRecaptchaResponseInternal = useElemId => elemId => () => {
if (useElemId) {
return grecaptcha.getResponse(elemId);
} else {
return grecaptcha.getResponse();
}
}
file addition: Recaptcha.purs (----------)

[36.1]

module Aftok.Api.Recaptcha
( getRecaptchaResponse
) where

import Prelude (bind, (==), ($), pure)
import Data.Maybe (Maybe(..))
import Effect (Effect)

getRecaptchaResponse :: Maybe String -> Effect (Maybe String)
getRecaptchaResponse elemId = do
resp <- case elemId of
Just eid -> getRecaptchaResponseInternal true eid
Nothing -> getRecaptchaResponseInternal false ""
pure $ if resp == "" then Nothing else Just resp

foreign import getRecaptchaResponseInternal :: Boolean -> String -> Effect String
edit in client/src/Aftok/Login.purs at line 7

[4.97]→[4.295301:295342](∅→∅),[4.295342]→[4.586:618](∅→∅),[4.97]→[4.586:618](∅→∅)

import Data.Argonaut.Encode (encodeJson)
import Data.Either (Either(..))
edit in client/src/Aftok/Login.purs at line 10

[4.295408]→[4.21:55](∅→∅),[4.55]→[4.86:124](∅→∅),[4.30]→[4.86:124](∅→∅),[4.124]→[4.295460:295534](∅→∅),[4.295460]→[4.295460:295534](∅→∅),[4.295534]→[4.125:160](∅→∅)

import Effect.Class.Console (log)
import Affjax (post, get, printError)
import Affjax.StatusCode (StatusCode(..))
import Affjax.RequestBody as RB
import Affjax.ResponseFormat as RF
replacement in client/src/Aftok/Login.purs at line 24

[4.85]→[4.157:158](∅→∅),[4.295631]→[4.157:158](∅→∅),[4.192]→[4.295631:295695](∅→∅),[4.295631]→[4.295631:295695](∅→∅)

type LoginRequest = { username :: String, password :: String }

[4.85]

[4.459]

import Aftok.Api.Account (LoginResponse(..), login, checkLogin, logout)
replacement in client/src/Aftok/Login.purs at line 26

[4.460]→[4.295696:295796](∅→∅)

data LoginResponse
= OK
| Forbidden
| Error { status :: Maybe StatusCode, message :: String }

[4.460]

[4.268]

data LoginError
= Forbidden
| ServerError
replacement in client/src/Aftok/Login.purs at line 33

[4.295839]→[4.335:376](∅→∅),[4.335]→[4.335:376](∅→∅)

, loginResponse :: Maybe LoginResponse

[4.295839]

[4.376]

, loginError :: Maybe LoginError
replacement in client/src/Aftok/Login.purs at line 65

[4.296368]→[4.296368:296444](∅→∅)

initialState _ = { username: "", password: "", loginResponse: Nothing }

[4.296368]

[4.296444]

initialState _ = { username: "", password: "", loginError: Nothing }
replacement in client/src/Aftok/Login.purs at line 128

[4.299058]→[4.299058:299101](∅→∅)

, case st.loginResponse of

[4.299058]

[4.299101]

, case st.loginError of
replacement in client/src/Aftok/Login.purs at line 131

[4.299165]→[4.299165:299842](∅→∅)

Just OK ->
HH.div
[ P.classes (ClassName <$> ["alert alert-warning"]) ]
[ HH.text "Login ok, but you should have been redirected. Why are you still here?" ]
Just Forbidden ->
HH.div
[ P.classes (ClassName <$> ["alert alert-danger"]) ]
[ HH.text "Login failed. Check your username and password." ]
Just (Error e) ->
HH.div
[ P.classes (ClassName <$> ["alert alert-danger"]) ]
[ HH.text ("Login failed: " <> e.message) ]

[4.299165]

[4.299842]

Just err ->
let message = case err of
Forbidden -> "Login failed. Check your username and password."
ServerError -> "Login failed due to an internal error. Please contact support."
in HH.div
[ P.classes (ClassName <$> ["alert alert-danger"]) ]
[ HH.text message ]
replacement in client/src/Aftok/Login.purs at line 140

[4.299871]→[4.299871:299973](∅→∅)

[ P.classes (ClassName <$> ["btn", "btn-block", "btn-primary"])
]

[4.299871]

[4.299973]

[ P.classes (ClassName <$> ["btn", "btn-block", "btn-primary"]) ]
edit in client/src/Aftok/Login.purs at line 163

[4.300426]→[4.300426:300482](∅→∅)

H.modify_ (_ { loginResponse = Just response })
replacement in client/src/Aftok/Login.purs at line 164

[4.300507]→[4.471:530](∅→∅),[4.530]→[4.300546:300572](∅→∅),[4.300546]→[4.300546:300572](∅→∅),[4.300572]→[4.2466:2467](∅→∅),[4.2466]→[4.2466:2467](∅→∅),[4.2565]→[4.2565:2635](∅→∅),[4.2635]→[4.300573:300620](∅→∅),[4.300620]→[4.2715:2736](∅→∅),[4.2715]→[4.2715:2736](∅→∅),[4.2736]→[4.272:320](∅→∅),[4.320]→[4.217:329](∅→∅),[4.329]→[4.321:338](∅→∅),[4.300846]→[4.321:338](∅→∅),[4.338]→[4.330:449](∅→∅),[4.434]→[4.300846:301097](∅→∅),[4.449]→[4.300846:301097](∅→∅),[4.300846]→[4.300846:301097](∅→∅),[4.301097]→[4.450:902](∅→∅)

OK -> H.raise (LoginComplete { username: user })
_ -> pure unit

-- | Post credentials to the login service and interpret the response
login :: String -> String -> Aff LoginResponse
login user pass = do
log "Sending login request to /api/login ..."
result <- post RF.ignore "/api/login" (Just <<< RB.Json <<< encodeJson $ { username: user, password : pass })
case result of
Left err -> log ("Login failed: " <> printError err)
Right r -> log ("Login status: " <> show r.status)
pure $ case result of
Left err -> Error { status: Nothing, message: printError err }
Right r -> case r.status of
StatusCode 403 -> Forbidden
StatusCode 200 -> OK
other -> Error { status: Just other, message: r.statusText }

checkLogin :: Aff LoginResponse
checkLogin = do
log "Sending login check to /api/login/check ..."
result <- get RF.ignore "/api/login/check"
case result of
Left err -> do
log ("Login failed: " <> printError err)
pure $ Error { status: Nothing, message: printError err }
Right r -> do
log ("Login status: " <> show r.status)
pure $ case r.status of
StatusCode 200 -> OK
StatusCode _ -> Forbidden

[4.300507]

[4.3162]

LoginOK -> H.raise (LoginComplete { username: user })
LoginForbidden -> H.modify_ (_ { loginError = Just Forbidden })
LoginError _ -> H.modify_ (_ { loginError = Just ServerError })
edit in client/src/Aftok/Login.purs at line 168

[4.3163]→[4.903:1159](∅→∅)

logout :: Aff Unit
logout = do
log "Logging out on server with /api/logout ..."
result <- get RF.ignore "/api/logout"
case result of
Left err -> log ("Logout failed: " <> printError err)
Right r -> log ("Logout status: " <> show r.status)
replacement in client/src/Aftok/Login.purs at line 173

[4.1225]→[4.1225:1277](∅→∅)

{ login: \_ _ -> pure OK
, checkLogin: pure OK

[4.1225]

[4.1277]

{ login: \_ _ -> pure LoginOK
, checkLogin: pure LoginOK
replacement in client/src/Aftok/Signup.purs at line 5

[4.45]→[4.45:88](∅→∅)

-- import Control.Monad.Trans.Class (lift)

[4.45]

[4.88]

import Control.Monad.Trans.Class (lift)
edit in client/src/Aftok/Signup.purs at line 7

[4.89]

[4.89]

import Data.Foldable (any)
edit in client/src/Aftok/Signup.purs at line 9

[4.130]

[4.130]

import Data.Either (Either(..), note)
import Data.Validation.Semigroup (V(..), toEither, andThen, invalid)
edit in client/src/Aftok/Signup.purs at line 12

[4.131]

[4.131]

import Effect.Aff (Aff)
import Effect.Class (liftEffect)
edit in client/src/Aftok/Signup.purs at line 33

[4.619]

[4.619]

import Aftok.Api.Account as Acc
import Aftok.Api.Account (SignupRequest, SignupResponse, signupRequest)
import Aftok.Api.Recaptcha (getRecaptchaResponse)
replacement in client/src/Aftok/Signup.purs at line 37

[4.620]→[4.620:707](∅→∅)

data SignupResponse
= OK
| Error { status :: Maybe StatusCode, message :: String }

[4.620]

[4.707]

data SignupError
= UsernameRequired
| UsernameTaken
| PasswordRequired
| ConfirmRequired
| PasswordMismatch
| EmailRequired
| ZAddrRequired
| ZAddrInvalid
| CaptchaError
| APIError { status :: Maybe StatusCode, message :: String }
replacement in client/src/Aftok/Signup.purs at line 62

[4.1028]→[4.1028:1070](∅→∅)

, loginResponse :: Maybe SignupResponse

[4.1028]

[4.1070]

, signupErrors :: Array SignupError
replacement in client/src/Aftok/Signup.purs at line 76

[4.1320]→[4.1320:1362](∅→∅)

= SignupComplete { username :: String }

[4.1320]

[4.1378]

= SignupComplete String
| SigninNav
replacement in client/src/Aftok/Signup.purs at line 82

[4.1459]→[4.1459:1510](∅→∅)

{ signup :: String -> String -> m SignupResponse

[4.1459]

[4.1510]

{ checkUsername :: String -> m Acc.UsernameCheckResponse
, checkZAddr :: String -> m Acc.ZAddrCheckResponse
, signup :: SignupRequest -> m SignupResponse
, getRecaptchaResponse :: Maybe String -> m (Maybe String)
replacement in client/src/Aftok/Signup.purs at line 113

[4.2095]→[4.2095:2126](∅→∅)

, loginResponse: Nothing

[4.2095]

[4.2126]

, signupErrors: []
replacement in client/src/Aftok/Signup.purs at line 136

[4.3157]→[4.3157:3212](∅→∅)

[ P.classes (ClassName <$> ["mb-6"]) ]

[4.3157]

[4.3212]

[ P.classes (ClassName <$> ["mb-6"])
, E.onSubmit (Just <<< Signup)
]
replacement in client/src/Aftok/Signup.purs at line 168

[4.4571]→[4.4571:4610](∅→∅)

, P.id_ "password"

[4.4571]

[4.4610]

, P.id_ "passwordConfirm"
replacement in client/src/Aftok/Signup.purs at line 180

[4.5087]→[4.5087:5159](∅→∅)

[ P.classes (ClassName <$> ["form-group", "mb-3"])

[4.5087]

[4.5159]

[ P.classes (ClassName <$> ["g-recaptcha", "mx-auto"])
replacement in client/src/Aftok/Signup.purs at line 202

[4.5929]→[4.5929:6059](∅→∅)

SetUsername user -> H.modify_ (_ { username = Just user })
SetPassword pass -> H.modify_ (_ { password = Just pass })

[4.5929]

[3.950]

SetUsername user -> do
ures <- lift $ caps.checkUsername user
H.modify_ (_ { username = Just user })
case ures of
Acc.UsernameCheckOK -> pure unit
Acc.UsernameCheckTaken -> H.modify_ (_ { signupErrors = [UsernameTaken] })

SetPassword pass -> do
H.modify_ (_ { password = Just pass })
confirm <- H.gets (_.passwordConfirm)
when (any (notEq pass) confirm) (H.modify_ (_ { signupErrors = [PasswordMismatch] }))

ConfirmPassword confirm -> do
H.modify_ (_ { passwordConfirm = Just confirm })
password <- H.gets (_.password)
when (any (notEq confirm) password) (H.modify_ (_ { signupErrors = [PasswordMismatch] }))
replacement in client/src/Aftok/Signup.purs at line 220

[3.1012]→[4.6059:6156](∅→∅),[4.6059]→[4.6059:6156](∅→∅)

ConfirmPassword pass -> H.modify_ (_ { passwordConfirm = Just pass })
_ -> pure unit

[3.1012]

[4.6156]

SetRecoveryEmail email -> H.modify_ (_ { recoveryEmail = Just email })
SetRecoveryZAddr addr -> do
zres <- lift $ caps.checkZAddr addr
H.modify_ (_ { recoveryZAddr = Just addr })
case zres of
Acc.ZAddrCheckOK -> pure unit
Acc.ZAddrCheckInvalid -> H.modify_ (_ { signupErrors = [ZAddrInvalid] })
edit in client/src/Aftok/Signup.purs at line 228

[4.6157]

[4.6157]

Signin ev -> do
lift $ system.preventDefault (ME.toEvent ev)
H.raise SigninNav

Signup ev -> do
lift $ system.preventDefault ev
recType <- H.gets (_.recoveryType)
usernameV <- V <<< note [UsernameRequired] <$> H.gets (_.username)
pwdFormV <- V <<< note [PasswordRequired] <$> H.gets (_.password)
pwdConfV <- V <<< note [ConfirmRequired ] <$> H.gets (_.passwordConfirm)
recoveryType <- H.gets (_.recoveryType)
recoveryV <- case recoveryType of
RecoveryEmail ->
V <<< note [EmailRequired] <<< map Acc.RecoverByEmail <$> H.gets (_.recoveryEmail)
RecoveryZAddr ->
V <<< note [ZAddrRequired] <<< map Acc.RecoverByZAddr <$> H.gets (_.recoveryZAddr)
recapV <- lift $ V <<< note [CaptchaError] <$> caps.getRecaptchaResponse Nothing
let reqV :: V (Array SignupError) Acc.SignupRequest
reqV = signupRequest <$> usernameV
<*> ((eq <$> pwdFormV <*> pwdConfV) `andThen`
(if _ then pwdFormV else invalid [PasswordMismatch]))
<*> recoveryV
<*> recapV
case toEither reqV of
Left errors ->
H.modify_ (_ { signupErrors = errors })
Right req -> do
response <- lift (caps.signup req)
case response of
Acc.SignupOK -> H.raise (SignupComplete $ req.username)
Acc.CaptchaInvalid -> H.modify_ (_ { signupErrors = [CaptchaError] })
Acc.ZAddrInvalid -> H.modify_ (_ { signupErrors = [ZAddrInvalid] })
Acc.UsernameTaken -> H.modify_ (_ { signupErrors = [UsernameTaken] })
replacement in client/src/Aftok/Signup.purs at line 332

[4.8398]→[3.1343:1401](∅→∅)

mockCapability :: forall m. Applicative m => Capability m

[4.8398]

[3.1401]

mockCapability :: Capability Aff
replacement in client/src/Aftok/Signup.purs at line 334

[3.1419]→[3.1419:1448](∅→∅)

{ signup: \_ _ -> pure OK

[3.1419]

[3.1448]

{ checkUsername: \_ -> pure Acc.UsernameCheckOK
, checkZAddr: \_ -> pure Acc.ZAddrCheckOK
, signup: \_ -> pure Acc.SignupOK
, getRecaptchaResponse: liftEffect <<< getRecaptchaResponse
edit in client/src/Main.purs at line 24

[4.307714]

[3.1541]

import Aftok.Api.Account as Acc
replacement in client/src/Main.purs at line 85

[4.308567]→[3.2072:2142](∅→∅)

initialState _ = { view: VLoading, config: { recaptchaKey: "" } }

[4.308567]

[4.308598]

initialState _ =
{ view: VLoading
, config: { recaptchaKey: "6LdiA78ZAAAAAGGvDId_JmDbhalduIDZSqbuikfq" }
}
replacement in client/src/Main.purs at line 117

[3.2747]→[3.2747:2794](∅→∅)

Login.Forbidden -> pure VLogin

[3.2747]

[3.2794]

Acc.LoginForbidden -> pure VLogin
Acc.LoginError _ -> pure VLogin
edit in client/src/Main.purs at line 128

[3.3055]

[3.3055]

SignupAction (Signup.SigninNav) ->
H.modify_ (_ { view = VLogin })
edit in server/Aftok/QConfig.hs at line 36

[4.4377]

[4.534]

, _recaptchaSecret :: Maybe Text
edit in server/Aftok/QConfig.hs at line 65

[4.45251]

[4.7968]

<*> C.lookup cfg "recaptchaSecret"
replacement in server/Aftok/Snaplet/Projects.hs at line 66

[4.9021]→[4.53858:53951](∅→∅)

uid <- requireUserId
pid <- requireProjectId

[4.9021]

[4.9070]

uid <- requireUserId
pid <- requireProjectId
replacement in server/Aftok/Snaplet/Projects.hs at line 69

[4.9145]→[4.53952:54007](∅→∅)

t <- liftIO C.getCurrentTime

[4.9145]

[4.54007]

t <- liftIO C.getCurrentTime
edit in server/Aftok/Snaplet/Users.hs at line 1

[4.3234]

[4.3072]

{-# LANGUAGE OverloadedStrings #-}
edit in server/Aftok/Snaplet/Users.hs at line 8

[4.477]

[4.55437]

, CaptchaConfig(..)
, CaptchaError(..)
, checkCaptcha
replacement in server/Aftok/Snaplet/Users.hs at line 17

[4.8667]→[4.55448:55500](∅→∅)

import Data.Aeson as A

[4.8667]

[4.55500]

import qualified Data.Aeson as A
import Data.Aeson ((.:), (.:?))
edit in server/Aftok/Snaplet/Users.hs at line 21

[4.55604]

[4.55604]

import Data.Text.Encoding as T
edit in server/Aftok/Snaplet/Users.hs at line 25

[2.15002]

[4.10431]

import Network.HTTP.Client ( parseRequest, responseBody, responseStatus, httpLbs)
import Network.HTTP.Client.TLS ( newTlsManager )
import Network.HTTP.Client.MultipartFormData (formDataBody, partBS)
import Network.HTTP.Types.Status ( statusCode )
replacement in server/Aftok/Snaplet/Users.hs at line 39

[4.3651]→[4.8914:8941](∅→∅),[4.8941]→[4.55898:55950](∅→∅)

import Snap.Core
import Snap.Snaplet as S

[4.3651]

[4.55950]

import qualified Snap.Core as S
import qualified Snap.Snaplet as S
replacement in server/Aftok/Snaplet/Users.hs at line 50

[4.4306]→[4.12457:12487](∅→∅),[4.12487]→[4.9079:9104](∅→∅)

instance FromJSON CUser where
parseJSON (Object v) =

[4.4306]

[4.56004]

instance A.FromJSON CUser where
parseJSON (A.Object v) =
replacement in server/Aftok/Snaplet/Users.hs at line 71

[4.716]→[4.3554:3592](∅→∅)

requestBody <- readRequestBody 4096

[4.678]

[4.11005]

rbody <- S.readRequestBody 4096
replacement in server/Aftok/Snaplet/Users.hs at line 74

[4.56389]→[4.56389:56416](∅→∅)

$ A.decode requestBody

[4.56389]

[4.56416]

$ A.decode rbody
replacement in server/Aftok/Snaplet/Users.hs at line 87

[4.11292]→[4.3764:3800](∅→∅),[4.12605]→[4.3764:3800](∅→∅),[4.56909]→[4.3764:3800](∅→∅),[4.3764]→[4.3764:3800](∅→∅)

authUser <- with auth createSUser

[4.56909]

[4.9235]

authUser <- S.with auth createSUser
replacement in server/Aftok/Snaplet/Users.hs at line 94

[4.56976]→[4.56976:57000](∅→∅)

params <- getParams

[4.56976]

[4.57000]

params <- S.getParams
replacement in server/Aftok/Snaplet/Users.hs at line 96

[4.57068]→[4.57068:57134](∅→∅)

(pure . traverse (parseInvCode . decodeUtf8))

[4.57068]

[4.57134]

(pure . traverse (parseInvCode . T.decodeUtf8))
edit in server/Aftok/Snaplet/Users.hs at line 105

[4.9320]

[4.9320]

type CaptchaCheckResult = Either [CaptchaError] ()
edit in server/Aftok/Snaplet/Users.hs at line 107

[4.9321]

[4.9321]

data CaptchaError
= MissingInputSecret
| InvalidInputSecret
| MissingInputResponse
| InvalidInputResponse
| BadRequest
| TimeoutOrDuplicate
| CaptchaError Text
deriving (Eq, Show)

data CaptchaConfig = CaptchaConfig
{ secretKey :: Text }

data CaptchaResponse = CaptchaResponse
{ success :: Bool
, errorCodes :: [CaptchaError]
}

instance A.FromJSON CaptchaResponse where
parseJSON (A.Object v) =
CaptchaResponse <$> v .: "success"
<*> (fmap toError . join . toList <$> v .:? "error-codes")
where
toError = \case
"missing-input-secret" -> MissingInputSecret
"invalid-input-secret" -> InvalidInputSecret
"missing-input-response" -> MissingInputResponse
"invalid-input-response" -> InvalidInputResponse
"bad-request" -> BadRequest
"timeout-or-duplicate" -> TimeoutOrDuplicate
other -> CaptchaError $ "Unexpected error code: " <> other
parseJSON _ =
fail "Captcha response body was not a valid JSON object."
edit in server/Aftok/Snaplet/Users.hs at line 141

[4.9322]

checkCaptcha :: CaptchaConfig -> Text -> IO CaptchaCheckResult
checkCaptcha cfg token = do
request <- parseRequest "https://www.google.com/recaptcha/api/siteverify"
reqWithBody <- formDataBody [partBS "secret" (T.encodeUtf8 $ secretKey cfg), partBS "response" (T.encodeUtf8 token)] request
manager <- newTlsManager
response <- httpLbs reqWithBody manager
pure $ case statusCode (responseStatus response) of
200 ->
case A.eitherDecode (responseBody response) of
Left err -> Left [CaptchaError $ "Failed to decode JSON response: " <> T.pack err]
Right cr -> if success cr then Right () else Left (errorCodes cr)
errCode ->
Left $ [CaptchaError $ "Unexpected status code: " <> T.pack (show errCode)]
edit in server/Main.hs at line 66

[4.11732]→[4.63040:63099](∅→∅),[4.311276]→[4.63040:63099](∅→∅),[4.63040]→[4.63040:63099](∅→∅)

registerRoute = void $ method POST registerHandler
edit in server/Main.hs at line 67

[4.12971]

[4.63100]

registerRoute = void $ method POST registerHandler