Integrate zcashd-based zaddr validation.

[?]

Sep 15, 2020, 1:47 PM

5IDB3IWSB6LFW4U772Y7BH5Y3FQOQ7IFWLVXDZE5XS6SKJITFV4QC

Dependencies

[2] U256ZALI Add captcha check to register route.
[3] I2KHGVD4 Require project permissions for access to most data.
[4] O2BZOX7M Add signup form, captcha check.
[5] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[6] BXGLKYRX Added primitive user registration handler.
[7] IPG33FAW Add billing daemon
[8] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[9] IZEVQF62 Work in progress replacing sqlite with postgres.
[10] HMDM3B55 Implement core of payments/billing infrastructure.
[11] KEP5WUFJ Convert project to stack-based build.
[12] NEDDHXUK Reformat via stylish-haskell
[13] GCVQD44V Create amends endpoint, switch to UUID primary keys
[14] HALRDT2F Added initial auction create route.
[15] LTSVBVA2 Update to a recent haskoin-core. Fix Stack build.
[16] O722AOKE Add route to allow crediting of events to users/projects.
[17] EFSXYZPO Autoformat everything with brittany.
[18] BROSTG5K Beginning of modularization of server.
[19] PT4276XC Add logout functionality.
[20] UWMGUJOW Autoformat sources.
[21] ASF3UPJL Add auction creation and bid handlers
[22] B6HWAPDP Modularize & update to recent haskoin.
[*] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[*] UUR6SMCA Add start of specs for auctions.
[*] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[*] V2VDN77H Enable postgres configuration via environment variable for Heroku.
[*] 6L5BK5EH Use generic SMTP rather than Sendmail-specific mail client.
[*] MB5SHULB Add route for accepting an invitation with an existing account
[*] ADMKQQGC Initial empty Snap project.
[*] W35DDBFY Factor common JSON conversions up into client lib module.
[*] RFYEVKZQ Add nix-shell based build environment.

Change contents

replacement in aftok.cabal at line 35

[3.237]→[2.371:414](∅→∅)

Aftok.Currency.ZCash

[3.237]

[3.238]

Aftok.Currency.Zcash
edit in aftok.cabal at line 47

[25.35]

[26.1]

Aftok.Users
edit in aftok.cabal at line 71

[3.370]

[26.47]

, http-client
, http-types
replacement in client/src/Aftok/Api/Account.purs at line 107

[3.2985]→[2.436:456](∅→∅)

let signupJSON =

[3.2985]

[2.456]

let signupJSON = encodeJson $
edit in client/src/Aftok/Api/Account.purs at line 119

[2.974]

[2.974]

, captchaToken: req.captchaToken
edit in client/src/Aftok/Api/Account.purs at line 121

[2.984]

[3.3001]

result <- post RF.ignore "/api/register" (Just <<< RB.Json $ signupJson)
case result of
Left err -> log ("Registration failed: " <> printError err)
Right r -> log ("Registration status: " <> show r.status)
file deletion: ZCash.hs (----------)

[3.4250]→[2.1263:1295](∅→∅),[2.1295]→[2.986:986](∅→∅)

{-# LANGUAGE TemplateHaskell #-}

module Aftok.Currency.ZCash where

import Control.Lens ( makePrisms
)

newtype ZAddr = ZAddr { zaddrText :: Text }
deriving (Eq, Ord, Show)
makePrisms ''ZAddr
file addition: Zcash.hs (----------)

[3.4250]

{-# LANGUAGE TemplateHaskell #-}

module Aftok.Currency.Zcash
( ZAddr(..)
, _ZAddr
, ZAddrError(..)
, ZcashdConfig(..)
, rpcValidateZAddr
) where

import Control.Lens ( makePrisms )

import qualified Data.Aeson as A
import Data.Aeson ( Value, (.=), (.:), (.:?), object, encode )
import Data.Aeson.Types ( Parser )
import qualified Data.Text.Encoding as T

import Network.HTTP.Client ( Manager
, RequestBody(..)
, defaultRequest
, responseBody
, responseStatus
, httpLbs
, host, port, method, requestBody
)
import Network.HTTP.Types ( Status, statusCode )

newtype ZAddr = ZAddr { zaddrText :: Text }
deriving (Eq, Ord, Show)
makePrisms ''ZAddr

data ZAddrType
= Sprout
| Sapling

data ZcashdConfig = ZcashdConfig
{ zcashdHost :: Text
, zcashdPort :: Int
}

data ZAddrError
= ServiceError Status
| ParseError String
| ZAddrInvalid
| SproutAddress
| DataMissing

validateZAddrRequest :: Text -> Value
validateZAddrRequest addr = object
[ "jsonrpc" .= ("1.0" :: Text)
, "id" .= ("aftok-z_validateaddress" :: Text)
, "method" .= ("z_validateaddress" :: Text)
, "params" .= [addr]
]

data ValidateZAddrResponse = ValidateZAddrResponse
{ isValid :: Bool
, _address :: Maybe Text
, addrType :: Maybe ZAddrType
}

instance A.FromJSON ValidateZAddrResponse where
parseJSON = parseValidateZAddrResponse

parseAddrType :: Text -> Maybe ZAddrType
parseAddrType = \case
"sprout" -> Just Sprout
"sapling" -> Just Sapling
_ -> Nothing

parseValidateZAddrResponse :: Value -> Parser ValidateZAddrResponse
parseValidateZAddrResponse = \case
(A.Object v) ->
ValidateZAddrResponse <$> v .: "isvalid"
<*> v .:? "address"
<*> ((traverse (maybe (fail "Not a recognized zaddr type") pure) . fmap parseAddrType) =<< v .:? "type")

_ ->
fail "ZAddr validation response body was not a valid JSON object"

rpcValidateZAddr :: Manager -> ZcashdConfig -> Text -> IO (Either ZAddrError ZAddr)
rpcValidateZAddr mgr cfg addr = do
let req = defaultRequest { host = T.encodeUtf8 $ zcashdHost cfg
, port = zcashdPort cfg
, method = "POST"
, requestBody = RequestBodyLBS $ encode (validateZAddrRequest addr)
}

response <- httpLbs req mgr
let status = responseStatus response
pure $ case statusCode status of
200 ->
case A.eitherDecode (responseBody response) of
Left err -> Left (ParseError err)
Right resp ->
if isValid resp
then
case addrType resp of
Just Sprout -> Left SproutAddress
Just Sapling -> Right (ZAddr addr)
_ -> Left DataMissing
else
Left ZAddrInvalid
_ ->
Left (ServiceError status)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 44

[3.6775]→[2.1301:1369](∅→∅)

import Aftok.Currency.ZCash (ZAddr(..), _ZAddr)

[3.6775]

[3.1614]

import Aftok.Currency.Zcash (ZAddr(..), _ZAddr)
replacement in lib/Aftok/Types.hs at line 16

[3.43324]→[2.3158:3216](∅→∅)

import Aftok.Currency.ZCash ( ZAddr )

[3.43324]

[3.32939]

import Aftok.Currency.Zcash ( ZAddr )
replacement in lib/Aftok/Types.hs at line 28

[3.33159]→[2.3217:3238](∅→∅)

data AccountRecovery

[3.33159]

[2.3238]

data AccountRecovery z
replacement in lib/Aftok/Types.hs at line 30

[2.3263]→[2.3263:3288](∅→∅)

| RecoverByZAddr ZAddr

[2.3263]

[2.3288]

| RecoverByZAddr z
replacement in lib/Aftok/Types.hs at line 35

[2.3374]→[2.3374:3420](∅→∅)

, _userAccountRecovery :: !AccountRecovery

[2.3374]

[3.33266]

, _userAccountRecovery :: !(AccountRecovery ZAddr)
file addition: Users.hs (----------)

[3.679]

module Aftok.Users
( RegisterOps(..)
, RegisterError(..)
)
where

import Aftok.Types (Email(..))
import Aftok.Currency.Zcash (ZAddr, ZAddrError)

data RegisterError
= ZAddrParseError ZAddrError

data RegisterOps m = RegisterOps
{ parseZAddr :: Text -> m (Either RegisterError ZAddr)
, sendConfirmationEmail :: Email -> m ()
}
edit in server/Aftok/QConfig.hs at line 24

[27.4839]

[3.32613]

import Aftok.Currency.Zcash (ZcashdConfig(..))
edit in server/Aftok/QConfig.hs at line 39

[2.4085]

[28.534]

, _zcashdConfig :: ZcashdConfig
edit in server/Aftok/QConfig.hs at line 69

[2.4146]

[3.7968]

<*> (readZcashdConfig $ C.subconfig "zcashd" cfg)

readZcashdConfig :: CT.Config -> IO ZcashdConfig
readZcashdConfig cfg =
ZcashdConfig <$> C.require cfg "zcashdHost"
<*> C.require cfg "zcashdPort"
edit in server/Aftok/Snaplet/Users.hs at line 11

[3.9856]

[3.55437]

, RegisterOps(..)
replacement in server/Aftok/Snaplet/Users.hs at line 40

[3.10432]→[2.5197:5259](∅→∅),[2.5259]→[3.8814:8846](∅→∅),[3.34920]→[3.8814:8846](∅→∅),[3.55897]→[3.8814:8846](∅→∅),[3.8814]→[3.8814:8846](∅→∅),[3.8846]→[3.4056:4087](∅→∅),[3.4087]→[2.5260:5289](∅→∅)

import Aftok.Currency.ZCash ( ZAddr(..) )
import Aftok.Database
import Aftok.Project
import Aftok.Types

[3.10432]

[2.5289]

import Aftok.Database ( createUser, acceptInvitation )
import Aftok.Project ( InvitationCode, parseInvCode )
import Aftok.Users ( RegisterOps(..) )
import Aftok.Types ( UserId, User(..)
, AccountRecovery(..)
, Email(..)
, UserName(..), _UserName
)
edit in server/Aftok/Snaplet/Users.hs at line 55

[3.56003]

[3.268]

data RegUser = RegUser
{ _username :: !UserName
, _userAccountRecovery :: !(AccountRecovery Text)
}
makeLenses ''RegUser
replacement in server/Aftok/Snaplet/Users.hs at line 63

[2.5435]→[2.5435:5464](∅→∅)

{ _cuser :: User

[2.5435]

[3.9043]

{ _regUser :: RegUser
replacement in server/Aftok/Snaplet/Users.hs at line 75

[2.5741]→[2.5741:5798](∅→∅)

"zaddr" -> RecoverByZAddr . ZAddr <$> v .: "zaddr"

[2.5741]

[2.5798]

"zaddr" -> RecoverByZAddr <$> v .: "zaddr"
replacement in server/Aftok/Snaplet/Users.hs at line 77

[2.5823]→[2.5823:5910](∅→∅)

user <- User <$> (UserName <$> v .: "username")
<*> pure recovery

[2.5823]

[3.10651]

user <- RegUser <$> (UserName <$> v .: "username")
<*> pure recovery
replacement in server/Aftok/Snaplet/Users.hs at line 81

[2.5936]→[2.5936:6019](∅→∅),[2.6019]→[3.56251:56316](∅→∅),[3.56251]→[3.56251:56316](∅→∅)

<$> (fromString <$> v .: "password")
<*> (v .: "captchaToken")
<*> (parseInvitationCodes =<< v .: "invitation_codes")

[2.5936]

[3.10820]

<$> (fromString <$> v .: "password")
<*> (v .: "captchaToken")
<*> (parseInvitationCodes =<< v .: "invitation_codes")
replacement in server/Aftok/Snaplet/Users.hs at line 92

[3.4425]→[2.6203:6289](∅→∅)

registerHandler :: CaptchaConfig -> S.Handler App App UserId
registerHandler cfg = do

[3.4425]

[2.6289]

registerHandler :: RegisterOps IO -> CaptchaConfig -> S.Handler App App UserId
registerHandler ops cfg = do
replacement in server/Aftok/Snaplet/Users.hs at line 97

[2.6484]→[2.6484:6600](∅→∅)

void . either (const . throwDenied $ AU.AuthError "Captcha check failed, please try again.") pure $ captchaResult

[2.6484]

[2.6600]

let captchaFailed = throwDenied $ AU.AuthError "Captcha check failed, please try again."
void . either (const captchaFailed) pure $ captchaResult
replacement in server/Aftok/Snaplet/Users.hs at line 100

[2.6601]→[2.6601:6636](∅→∅)

now <- liftIO C.getCurrentTime

[2.6601]

[3.56546]

acctRecovery <- case (userData ^. regUser . userAccountRecovery) of
RecoverByEmail e -> do
liftIO $ sendConfirmationEmail ops e
pure $ RecoverByEmail e
RecoverByZAddr z -> do
zaddrValid <- liftIO $ parseZAddr ops z
case zaddrValid of
Left _ -> snapError 400 "The Z-Address provided for account recovery was invalid."
Right r -> pure $ RecoverByZAddr r

now <- liftIO C.getCurrentTime
replacement in server/Aftok/Snaplet/Users.hs at line 112

[3.56552]→[3.56552:56684](∅→∅)

createSUser = AU.createUser (userData ^. (cuser . username . _UserName))
(userData ^. password)

[3.56552]

[3.56684]

uname = userData ^. (regUser . username)
createSUser = AU.createUser (uname ^. _UserName) (userData ^. password)
replacement in server/Aftok/Snaplet/Users.hs at line 115

[3.56716]→[2.6637:6684](∅→∅)

userId <- createUser (userData ^. cuser)

[3.56716]

[2.6684]

userId <- createUser $ User uname acctRecovery
edit in server/Aftok/Snaplet/Users.hs at line 121

[29.585]

[3.18312]
edit in server/Main.hs at line 15

[3.62333]

[3.11294]

import Network.HTTP.Client ( Manager, newManager, defaultManagerSettings )
edit in server/Main.hs at line 19

[31.919]

[3.11331]

import Aftok.Currency.Zcash ( rpcValidateZAddr )
edit in server/Main.hs at line 22

[3.11390]

[31.942]

import Aftok.Users ( RegisterError(..) )
edit in server/Main.hs at line 50

[3.8352]

[3.8352]

registerOps :: Manager -> QConfig -> RegisterOps IO
registerOps mgr cfg = RegisterOps
{ parseZAddr =
(pure . first ZAddrParseError)
<=< rpcValidateZAddr mgr (_zcashdConfig cfg)
, sendConfirmationEmail = const $ pure ()
}
edit in server/Main.hs at line 60

[3.12436]

[3.11380]

mgr <- liftIO $ newManager defaultManagerSettings
edit in server/Main.hs at line 62

[3.11435]

[3.16334]

rops = registerOps mgr cfg
replacement in server/Main.hs at line 80

[3.12971]→[2.8072:8158](∅→∅)

registerRoute = void $ method POST (registerHandler $ cfg ^. recaptchaSecret)

[3.12971]

[3.63100]

registerRoute = void $ method POST (registerHandler rops (cfg ^. recaptchaSecret))
edit in shell.nix at line 25

[32.99189]

[32.99189]

haskellPackages.ormolu