Get z-addr checks working.

[?]

Oct 11, 2020, 3:58 PM

SQ7UMLN5WCPHIF66RO4UQVX6RSNRRZBOVZP7HEMSKP7VO6YNQPRAC

Dependencies

[2] MJDIMD5B Improve documentation of local docker-compose setup.
[3] ENNZIQJG Use live signup API for client.
[4] BROSTG5K Beginning of modularization of server.
[5] NSRSSSTR Update nginx.conf, make aftok host configurable for cli scripts.
[6] B6HWAPDP Modularize & update to recent haskoin.
[7] GMYPBCWE Make docker-compose work.
[8] QADKFHAR Adds CreatePayment handler implementation.
[9] 5IDB3IWS Integrate zcashd-based zaddr validation.
[10] IZEVQF62 Work in progress replacing sqlite with postgres.
[11] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[12] NLZ3JXLO Fix formatting with stylish-haskell.
[13] 5W5M56VJ Move library code to 'lib'
[14] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[15] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[16] HMDM3B55 Implement core of payments/billing infrastructure.
[17] KEP5WUFJ Convert project to stack-based build.
[18] AL37SVTC Implement payments service endpoints.
[19] BSIUHCGF Add payment response handler.
[20] 4R7XIYK3 Switch from ClassyPrelude to Relude
[21] U256ZALI Add captcha check to register route.
[22] ZP62WC47 Begin conversion to build with stack.
[23] SEWTRB6S Implement payment request creation functions.
[24] ZIG57EE6 Fix project selection, end log end on project switch.
[25] 4FDQGIXN Make payment request retrieval key an opaque 32-bit hash.
[26] IPG33FAW Add billing daemon
[27] DFOBMSAO Initial work on payments API
[28] I2KHGVD4 Require project permissions for access to most data.
[29] UWMGUJOW Autoformat sources.
[30] NEDDHXUK Reformat via stylish-haskell
[31] JFOEOFGA stylish-haskell formatting.
[32] WZFQDWW4 Add retrieval/storage of current exchange rate data to payment recording.
[33] LTSVBVA2 Update to a recent haskoin-core. Fix Stack build.
[34] M4KM76DG Merge branch 'stackify'
[35] BXGLKYRX Added primitive user registration handler.
[36] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[37] Q5X5RYQL stylish-haskell reformatting
[38] EFSXYZPO Autoformat everything with brittany.
[39] UUR6SMCA Add start of specs for auctions.
[40] Z7KS5XHH Very WIP. Wow.
[41] M3KUPGZK Add invitation email template.
[42] O2BZOX7M Add signup form, captcha check.
[43] HALRDT2F Added initial auction create route.
[*] QO4NFWIY Added sample config file.
[*] W35DDBFY Factor common JSON conversions up into client lib module.
[*] V2VDN77H Enable postgres configuration via environment variable for Heroku.
[*] PBD7LZYQ Postgres & auth are beginning to function.
[*] ADMKQQGC Initial empty Snap project.

Change contents

replacement in aftok.cabal at line 17

[4.528]→[4.59:96](∅→∅)

default-extensions: KindSignatures

[4.528]

[4.96]

default-extensions: GADTs
, KindSignatures
replacement in aftok.cabal at line 34

[4.154]→[4.118:156](∅→∅),[4.203]→[4.118:156](∅→∅)

Aftok.Billables

[4.154]

[4.40]

Aftok.Billing
edit in aftok.cabal at line 50

[4.35]→[4.45:79](∅→∅)

Aftok.Users
replacement in conf/server/aftok.cfg at line 43

[2.2689]→[2.2689:2739](∅→∅)

zcashdHost = "aftok-zcashd"
zcashdPort = 8232

[2.2689]

[2.2739]

rpcHost = "aftok-zcashd"
rpcPort = 8232
rpcUser = "your_user"
rpcPassword = "your_pass"
edit in conf/zcashd/zcash-data/zcash.conf at line 3

[2.2821]

[2.2821]

rpcuser=your_user
rpcpassword=your_pass
replacement in daemon/AftokD/AftokM.hs at line 52

[4.2894]→[4.2894:2953](∅→∅)

import Aftok.Billables ( Billable

[4.2894]

[4.2953]

import Aftok.Billing ( Billable
edit in docker-compose.yml at line 69

[2.3028]

[2.3028]

expose:
- "18232"
replacement in docker-compose.yml at line 72

[2.3039]→[2.3039:3059](∅→∅)

- "8232:8232"

[2.3039]

[2.3059]

- "18232:18232"
file deletion: Users.hs (----------)

[4.679]→[4.4413:4445](∅→∅),[4.4445]→[4.4049:4049](∅→∅)

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

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

data RegisterError
= ZAddrParseError ZAddrError

data RegisterOps m = RegisterOps
, sendConfirmationEmail :: Email -> m ()
}
{ parseZAddr :: Text -> m (Either ZAddrError ZAddr)
file move: Billables.hs (----------) → Billing.hs (----------)

[4.679]

[4.760]
replacement in lib/Aftok/Billing.hs at line 7

[4.795]→[4.795:824](∅→∅)

module Aftok.Billables where

[4.795]

[4.824]

module Aftok.Billing where
replacement in lib/Aftok/Currency/Zcash.hs at line 6

[4.519]→[4.519:538](∅→∅)

, ZAddrError(..)

[4.519]

[4.538]

, RPCError(..)
, ZValidateAddressErr(..)
edit in lib/Aftok/Currency/Zcash.hs at line 9

[4.559]

[4.559]

, Zatoshi
, ToZatoshi(..)
, rpcAddViewingKey
edit in lib/Aftok/Currency/Zcash.hs at line 15

[4.591]

[4.591]

import Control.Exception ( catch )
edit in lib/Aftok/Currency/Zcash.hs at line 17

[4.654]

[4.654]

import Control.Monad.Trans.Except ( except )
edit in lib/Aftok/Currency/Zcash.hs at line 26

[4.1037]

[4.1037]

, HttpException
edit in lib/Aftok/Currency/Zcash.hs at line 32

[4.1370]

[4.1370]

, applyBasicAuth
edit in lib/Aftok/Currency/Zcash.hs at line 35

[4.1491]

[4.1491]

coin :: Word64
coin = 100000000

maxMoney :: Word64
maxMoney = 21000000 * coin
edit in lib/Aftok/Currency/Zcash.hs at line 45

[4.1582]

[4.1582]

newtype Zatoshi = Zatoshi Word64
deriving (Eq, Ord, Show)
makePrisms ''Zatoshi

class ToZatoshi a where
toZatoshi :: a -> Maybe Zatoshi
edit in lib/Aftok/Currency/Zcash.hs at line 53

[4.1583]

[4.1583]

instance ToZatoshi Word64 where
toZatoshi amt =
if amt > maxMoney then Nothing else Just (Zatoshi amt)
edit in lib/Aftok/Currency/Zcash.hs at line 64

[4.1700]

[4.1700]

, rpcUser :: Text
, rpcPassword :: Text
edit in lib/Aftok/Currency/Zcash.hs at line 67

[4.1704]

[4.1704]

data RPCCall a where
ZValidateAddress :: Text -> RPCCall ZValidateAddressResp
ZImportViewingKey :: Text -> RPCCall ZImportViewingKeyResp
replacement in lib/Aftok/Currency/Zcash.hs at line 72

[4.1705]→[4.1705:1745](∅→∅)

data ZAddrError
= ServiceError Status

[4.1705]

[4.1745]

data RPCError e
= HttpError HttpException
| ServiceError Status
replacement in lib/Aftok/Currency/Zcash.hs at line 76

[4.1767]→[4.1767:1784](∅→∅)

| ZAddrInvalid

[4.1767]

[4.1784]

| RPCError e
deriving (Show)

toRequestBody :: RPCCall a -> Value
toRequestBody = \case
ZValidateAddress addr -> validateZAddrRequest addr
ZImportViewingKey vk -> importViewingKeyRequest vk

rpcEval :: A.FromJSON a => Manager -> ZcashdConfig -> RPCCall a -> ExceptT (RPCError e) IO a
rpcEval mgr cfg call = do
let req = applyBasicAuth (T.encodeUtf8 $ rpcUser cfg) (T.encodeUtf8 $ rpcPassword cfg) $
defaultRequest { host = T.encodeUtf8 $ zcashdHost cfg
, port = zcashdPort cfg
, method = "POST"
, requestBody = RequestBodyLBS . encode $ toRequestBody call
}

response <- ExceptT $ catch
(Right <$> httpLbs req mgr)
(pure . Left . HttpError)

let status = responseStatus response
except $ case statusCode status of
200 -> first ParseError $ A.eitherDecode (responseBody response)
_ -> Left (ServiceError status)

-- Address Validation

data ZValidateAddressErr
= ZAddrInvalid
edit in lib/Aftok/Currency/Zcash.hs at line 108

[4.1818]

[4.1818]

deriving (Eq, Show)

data ZValidateAddressResp = ZValidateAddressResp
{ vzrIsValid :: Bool
--, vzrAddress :: Maybe Text
, vzrAddrType :: Maybe ZAddrType
}

instance A.FromJSON ZValidateAddressResp where
parseJSON = parseValidateZAddrResponse
replacement in lib/Aftok/Currency/Zcash.hs at line 127

[4.2054]→[4.2054:2342](∅→∅)

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

instance A.FromJSON ValidateZAddrResponse where
parseJSON = parseValidateZAddrResponse

parseAddrType :: Text -> Maybe ZAddrType
parseAddrType = \case

[4.2054]

[4.2342]

decodeAddrType :: Text -> Maybe ZAddrType
decodeAddrType = \case
replacement in lib/Aftok/Currency/Zcash.hs at line 133

[4.2412]→[4.2412:2480](∅→∅)

parseValidateZAddrResponse :: Value -> Parser ValidateZAddrResponse

[4.2412]

[4.2480]

parseAddrType :: A.Object -> Parser (Maybe ZAddrType)
parseAddrType res = do
typeStr <- res .:? "type"
let typeMay = decodeAddrType <$> typeStr
traverse (maybe (fail $ "Not a recognized zaddr type: " <> show typeStr) pure) typeMay

parseValidateZAddrResponse :: Value -> Parser ZValidateAddressResp
replacement in lib/Aftok/Currency/Zcash.hs at line 141

[4.2515]→[4.2515:2755](∅→∅)

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

[4.2515]

[4.2755]

(A.Object v) -> do
res <- v .: "result"
ZValidateAddressResp <$> res .: "isvalid"
-- <*> res .:? "address"
<*> parseAddrType res
edit in lib/Aftok/Currency/Zcash.hs at line 150

[4.2834]

[4.2834]

rpcValidateZAddr :: Manager -> ZcashdConfig -> Text -> IO (Either (RPCError ZValidateAddressErr) ZAddr)
rpcValidateZAddr mgr cfg addr = runExceptT $ do
resp <- rpcEval mgr cfg (ZValidateAddress addr)
except $ if vzrIsValid resp
then
case vzrAddrType resp of
Nothing -> Left (RPCError DataMissing)
Just Sprout -> Left (RPCError SproutAddress)
Just Sapling -> Right (ZAddr addr)
else
Left $ RPCError ZAddrInvalid
replacement in lib/Aftok/Currency/Zcash.hs at line 162

[4.2835]→[4.2835:3240](∅→∅)

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)
}

[4.2835]

[4.3240]

-- Viewing Keys
replacement in lib/Aftok/Currency/Zcash.hs at line 164

[4.3241]→[4.3241:3782](∅→∅)

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)

[4.3241]

data ZImportViewingKeyResp = ZImportViewingKeyResp
{ addressType :: ZAddrType
-- , address :: ZAddr
}

parseImportViewingKeyResponse :: Value -> Parser ZImportViewingKeyResp
parseImportViewingKeyResponse = \case
(A.Object v) -> do
ZImportViewingKeyResp
<$> (maybe (fail "Missing address type.") pure =<< parseAddrType v)
-- <*> (ZAddr <$> v .: "address")
_ ->
fail "z_importviewingkey response body was not a valid JSON object"

instance A.FromJSON ZImportViewingKeyResp where
parseJSON = parseImportViewingKeyResponse

data ZImportViewingKeyError
= SproutViewingKey

importViewingKeyRequest :: Text -> Value
importViewingKeyRequest vk = object
[ "jsonrpc" .= ("1.0" :: Text)
, "id" .= ("aftok-z_importviewingkey" :: Text)
, "method" .= ("z_importviewingkey" :: Text)
, "params" .= [vk, "no"] -- no need to rescan, for our purposes
]

rpcAddViewingKey :: Manager -> ZcashdConfig -> Text -> IO (Either (RPCError ZImportViewingKeyError) ())
rpcAddViewingKey mgr cfg vk = runExceptT $ do
resp <- rpcEval mgr cfg (ZImportViewingKey vk)
except $ case addressType resp of
Sprout -> Left . RPCError $ SproutViewingKey
Sapling -> Right ()
replacement in lib/Aftok/Database/PostgreSQL.hs at line 42

[4.14753]→[4.14753:14805](∅→∅)

import qualified Aftok.Billables as B

[4.14753]

[4.6735]

import qualified Aftok.Billing as B
replacement in lib/Aftok/Database.hs at line 25

[4.26021]→[4.26021:26073](∅→∅)

import Aftok.Billables as B

[4.26021]

[4.26073]

import Aftok.Billing as B
replacement in lib/Aftok/Json.hs at line 44

[4.32326]→[4.32326:32378](∅→∅)

import qualified Aftok.Billables as B

[4.32326]

[4.1326]

import qualified Aftok.Billing as B
replacement in lib/Aftok/Payments/Types.hs at line 30

[4.10817]→[4.40746:40805](∅→∅)

import Aftok.Billables ( Billable

[4.10817]

[4.40805]

import Aftok.Billing ( Billable
replacement in lib/Aftok/Payments.hs at line 50

[4.3623]→[4.2319:2352](∅→∅),[4.6794]→[4.2319:2352](∅→∅),[4.12295]→[4.2319:2352](∅→∅),[4.27398]→[4.2319:2352](∅→∅),[4.5960]→[4.2319:2352](∅→∅)

import Aftok.Billables

[4.6794]

[4.6795]

import Aftok.Billing
replacement in server/Aftok/QConfig.hs at line 73

[4.4670]→[4.4670:4762](∅→∅)

ZcashdConfig <$> C.require cfg "zcashdHost"
<*> C.require cfg "zcashdPort"

[4.4670]

[4.7968]

ZcashdConfig <$> C.require cfg "rpcHost"
<*> C.require cfg "rpcPort"
<*> C.require cfg "rpcUser"
<*> C.require cfg "rpcPassword"
replacement in server/Aftok/Snaplet/Billing.hs at line 20

[4.48557]→[4.34368:34401](∅→∅),[4.34368]→[4.34368:34401](∅→∅)

import Aftok.Billables

[4.34143]

[4.14755]

import Aftok.Billing
replacement in server/Aftok/Snaplet/Payments.hs at line 49

[4.36098]→[4.5963:5996](∅→∅),[4.51517]→[4.5963:5996](∅→∅),[4.5963]→[4.5963:5996](∅→∅)

import Aftok.Billables

[4.51517]

[4.3851]

import Aftok.Billing
replacement in server/Aftok/Snaplet/Users.hs at line 18

[4.5632]→[4.8637:8667](∅→∅),[4.3510]→[4.8637:8667](∅→∅)

import Control.Lens

[4.5632]

[4.4445]

import Control.Lens ( makeLenses, (^.) )
edit in server/Aftok/Snaplet/Users.hs at line 23

[4.4620]

[4.4620]

, (.=)
replacement in server/Aftok/Snaplet/Users.hs at line 42

[4.10432]→[3.4320:4378](∅→∅)

import Aftok.Currency.Zcash ( ZAddr )

[4.10432]

[4.4786]

import Aftok.Currency.Zcash ( ZAddr, RPCError, ZValidateAddressErr )
edit in server/Aftok/Snaplet/Users.hs at line 45

[4.4948]→[4.4948:5016](∅→∅)

import Aftok.Users ( RegisterOps(..) )
edit in server/Aftok/Snaplet/Users.hs at line 57

[4.56003]

[4.5338]

data RegisterOps m = RegisterOps
{ validateZAddr :: Text -> m (Either (RPCError ZValidateAddressErr) ZAddr)
, sendConfirmationEmail :: Email -> m ()
}
edit in server/Aftok/Snaplet/Users.hs at line 98

[4.656]

[4.4424]

data RegisterError
= RegParseError String
| RegCaptchaError [CaptchaError]
| RegZAddrError (RPCError ZValidateAddressErr)

instance A.ToJSON RegisterError where
toJSON = \case
RegParseError msg -> A.object
[ "parseError" .= msg ]
RegCaptchaError e -> A.object
[ "captchaError" .= (show e :: Text) ]
RegZAddrError zerr -> A.object
[ "zaddrError" .= (show zerr :: Text) ]
replacement in server/Aftok/Snaplet/Users.hs at line 120

[3.4785]→[3.4785:4852](∅→∅)

zaddrEither <- liftIO $ parseZAddr ops (T.decodeUtf8 zaddrBytes)

[3.4785]

[3.4852]

zaddrEither <- liftIO $ validateZAddr ops (T.decodeUtf8 zaddrBytes)
edit in server/Aftok/Snaplet/Users.hs at line 128

[3.5006]→[3.5006:5007](∅→∅)
replacement in server/Aftok/Snaplet/Users.hs at line 134

[4.6484]→[4.5911:6061](∅→∅)

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

[4.6484]

[4.6600]

case captchaResult of
Left err ->
let cmsg = "Captcha check failed, please try again."
in snapErrorJS 400 cmsg (RegCaptchaError err)
Right _ -> pure ()
replacement in server/Aftok/Snaplet/Users.hs at line 145

[4.6259]→[4.6259:6305](∅→∅)

zaddrValid <- liftIO $ parseZAddr ops z

[4.6259]

[4.6305]

zaddrValid <- liftIO $ validateZAddr ops z
replacement in server/Aftok/Snaplet/Users.hs at line 147

[4.6330]→[3.5010:5112](∅→∅)

Left _ ->
snapError 400 "The Z-Address provided for account recovery was invalid."

[4.6330]

[3.5112]

Left err ->
let msg = "The Z-Address provided for account recovery was invalid."
in snapErrorJS 400 msg (RegZAddrError err)
edit in server/Aftok/Snaplet/Users.hs at line 180

[4.9320]

[4.10692]
replacement in server/Aftok/Snaplet.hs at line 14

[4.60270]→[4.6969:6996](∅→∅),[4.6969]→[4.6969:6996](∅→∅)

import Data.UUID

[4.60270]

[4.1324]

import Data.UUID ( UUID, fromASCIIBytes )
replacement in server/Aftok/Snaplet.hs at line 18

[4.7061]→[4.10751:10826](∅→∅),[4.36308]→[4.10751:10826](∅→∅),[4.60405]→[4.10751:10826](∅→∅),[4.10751]→[4.10751:10826](∅→∅)

import Aftok.Database
import Aftok.Database.PostgreSQL

[4.60405]

[4.60406]

import Aftok.Database ( DBError(..)
, DBOp
, liftdb
)
import Aftok.Database.PostgreSQL ( runQDBM )
replacement in server/Aftok/Snaplet.hs at line 28

[4.1433]→[4.10855:10882](∅→∅)

import Snap.Core

[4.1433]

[4.18755]

import Snap.Core ( MonadSnap
, getParam
, readRequestBody
, setResponseCode
, modifyResponse
, finishWith
, getResponse
, writeText
, writeLBS
, setResponseStatus
, logError
)
replacement in server/Aftok/Snaplet.hs at line 42

[4.10965]→[4.10965:11050](∅→∅)

import Snap.Snaplet.PostgresqlSimple
import Snap.Snaplet.Session

[4.10965]

[4.1688]

import Snap.Snaplet.PostgresqlSimple ( Postgres
, HasPostgres(..)
, setLocalPostgresState
, liftPG
)
import Snap.Snaplet.Session ( SessionManager )
edit in server/Aftok/Snaplet.hs at line 49

[4.1689]

[4.11051]
replacement in server/Aftok/Snaplet.hs at line 86

[4.2972]→[4.2972:3026](∅→∅),[4.3026]→[4.6098:6137](∅→∅)

modifyResponse $ setResponseStatus c $ encodeUtf8 t
writeText $ ((show c) <> " - " <> t)

[4.2972]

[4.3066]

let errBytes = encodeUtf8 t
logError errBytes
modifyResponse $ setResponseStatus c errBytes
writeText (show c <> " - " <> t)
getResponse >>= finishWith

snapErrorJS :: (A.ToJSON err, MonadSnap m) => Int -> Text -> err -> m a
snapErrorJS c t err = do
let errBytes = A.encode err
logError (fromLazy errBytes)
modifyResponse $ setResponseStatus c (encodeUtf8 t)
writeLBS errBytes
edit in server/Aftok/Snaplet.hs at line 100

[4.3096]

[48.3802]
replacement in server/Main.hs at line 51

[4.7004]→[3.5167:5225](∅→∅)

{ parseZAddr = rpcValidateZAddr mgr (_zcashdConfig cfg)

[4.7004]

[4.7109]

{ validateZAddr = rpcValidateZAddr mgr (_zcashdConfig cfg)