nuttycom/aftok - Change 5IDB3IWSB6LFW4U772Y7BH5Y3FQOQ7IFWLVXDZE5XS6SKJITFV4QC

Integrate zcashd-based zaddr validation.

Created by Kris Nuttycombe on September 15, 2020

5IDB3IWSB6LFW4U772Y7BH5Y3FQOQ7IFWLVXDZE5XS6SKJITFV4QC

Dependencies

In channels

main

Change contents

Replacement in aftok.cabal at line 35 [4.1]

B:BD[3.237] → [2.371:414]

                      Aftok.Currency.ZCash

[3.237]

[5.238]

                      Aftok.Currency.Zcash

Insertion in aftok.cabal at line 47 [4.1]
[6.35]
[7.1]
```
                      Aftok.Users
```
Insertion in aftok.cabal at line 71 [4.1]
[8.370]
[7.47]
```
    , http-client
    , http-types
```
Replacement in client/src/Aftok/Api/Account.purs at line 107 [9.149]
B:BD[9.2985] → [2.436:456]
```
  let signupJSON = 
```
[9.2985]
[2.456]
```
  let signupJSON = encodeJson $ 
```
Insertion in client/src/Aftok/Api/Account.purs at line 119 [9.149]
[2.974]
[2.974]
```
        , captchaToken: req.captchaToken
```

Insertion in client/src/Aftok/Api/Account.purs at line 121 [9.149]

[2.984]

[9.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

BF:BFD[3.4250] → [2.1263:1295]

BF:BFD[2.1295] → [2.986:986]

B:BD[2.986] → [2.987:1262]

{-# 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 [10.456]

B:BD[3.6775] → [2.1301:1369]

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

[3.6775]

[11.1614]

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

Replacement in lib/Aftok/Types.hs at line 16 [13.805]

B:BD[12.43324] → [2.3158:3216]

import           Aftok.Currency.ZCash           ( ZAddr )

[12.43324]

[3.32939]

import           Aftok.Currency.Zcash           ( ZAddr )

Replacement in lib/Aftok/Types.hs at line 28 [13.805]
B:BD[3.33159] → [2.3217:3238]
```
data AccountRecovery
```
[3.33159]
[2.3238]
```
data AccountRecovery z
```
Replacement in lib/Aftok/Types.hs at line 30 [13.805]
B:BD[2.3263] → [2.3263:3288]
```
  | RecoverByZAddr ZAddr
```
[2.3263]
[2.3288]
```
  | RecoverByZAddr z
```

Replacement in lib/Aftok/Types.hs at line 35 [13.805]

B:BD[2.3374] → [2.3374:3420]

  , _userAccountRecovery  :: !AccountRecovery

[2.3374]

[3.33266]

  , _userAccountRecovery  :: !(AccountRecovery ZAddr)

File addition: Users.hs (----------)

[5.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 ()
  }

Insertion in server/Aftok/QConfig.hs at line 24 [14.4500]
[14.4839]
[15.32613]
```
import           Aftok.Currency.Zcash (ZcashdConfig(..))
```
Insertion in server/Aftok/QConfig.hs at line 39 [14.4500]
[2.4085]
[16.534]
```
  , _zcashdConfig  :: ZcashdConfig
```

Insertion in server/Aftok/QConfig.hs at line 69 [14.4500]

[2.4146]

[17.7968]

    <*> (readZcashdConfig $ C.subconfig "zcashd" cfg)
readZcashdConfig :: CT.Config -> IO ZcashdConfig
readZcashdConfig cfg =
  ZcashdConfig <$> C.require cfg "zcashdHost"
               <*> C.require cfg "zcashdPort"

Insertion in server/Aftok/Snaplet/Users.hs at line 11 [18.3234]
[9.9856]
[12.55437]
```
  , RegisterOps(..)
```

Replacement in server/Aftok/Snaplet/Users.hs at line 40 [18.3234]

B:BD[17.10432] → [2.5197:5259]

∅:D[2.5259] → [11.8814:8846]

∅:D[3.34920] → [11.8814:8846]

∅:D[12.55897] → [11.8814:8846]

B:BD[11.8814] → [11.8814:8846]

B:BD[11.8846] → [19.4056:4087]

B:BD[19.4087] → [2.5260:5289]

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

[17.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
                                                )

Insertion in server/Aftok/Snaplet/Users.hs at line 55 [18.3234]

[12.56003]

[20.268]


data RegUser = RegUser
  { _username             :: !UserName
  , _userAccountRecovery  :: !(AccountRecovery Text)
  }
makeLenses ''RegUser

Replacement in server/Aftok/Snaplet/Users.hs at line 63 [18.3234]
B:BD[2.5435] → [2.5435:5464]
```
  { _cuser           :: User
```
[2.5435]
[11.9043]
```
  { _regUser         :: RegUser
```

Replacement in server/Aftok/Snaplet/Users.hs at line 75 [18.3234]

B:BD[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 [18.3234]

B:BD[2.5823] → [2.5823:5910]

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

[2.5823]

[17.10651]

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

Replacement in server/Aftok/Snaplet/Users.hs at line 81 [18.3234]

B:BD[2.5936] → [2.5936:6019]

∅:D[2.6019] → [12.56251:56316]

B:BD[12.56251] → [12.56251:56316]

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

[2.5936]

[17.10820]

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

Replacement in server/Aftok/Snaplet/Users.hs at line 92 [18.3234]

B:BD[18.4425] → [2.6203:6289]

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

[18.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 [18.3234]

B:BD[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 [18.3234]

B:BD[2.6601] → [2.6601:6636]

  now   <- liftIO C.getCurrentTime

[2.6601]

[12.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 [18.3234]

B:BD[12.56552] → [12.56552:56684]

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

[12.56552]

[12.56684]

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

Replacement in server/Aftok/Snaplet/Users.hs at line 115 [18.3234]
B:BD[12.56716] → [2.6637:6684]
```
      userId <- createUser (userData ^. cuser)
```
[12.56716]
[2.6684]
```
      userId <- createUser $ User uname acctRecovery
```
Insertion in server/Aftok/Snaplet/Users.hs at line 121 [18.3234]
[21.585]
[8.18312]

Insertion in server/Main.hs at line 15 [22.5188]

[12.62333]

[11.11294]

import           Network.HTTP.Client            ( Manager, newManager, defaultManagerSettings )

Insertion in server/Main.hs at line 19 [22.5188]

[23.919]

[11.11331]

import           Aftok.Currency.Zcash           ( rpcValidateZAddr )

Insertion in server/Main.hs at line 22 [22.5188]

[11.11390]

[23.942]

import           Aftok.Users                    ( RegisterError(..) )

Insertion in server/Main.hs at line 50 [22.5188]

[10.8352]

registerOps :: Manager -> QConfig -> RegisterOps IO
registerOps mgr cfg = RegisterOps
  { parseZAddr =
      (pure . first ZAddrParseError)
      <=< rpcValidateZAddr mgr (_zcashdConfig cfg)
  , sendConfirmationEmail = const $ pure ()
  }

Insertion in server/Main.hs at line 60 [22.5188]
[17.12436]
[24.11380]
```
  mgr <- liftIO $ newManager defaultManagerSettings
```
Insertion in server/Main.hs at line 62 [22.5188]
[24.11435]
[25.16334]
```
      rops = registerOps mgr cfg
```

Replacement in server/Main.hs at line 80 [22.5188]

B:BD[17.12971] → [2.8072:8158]

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

[17.12971]

[12.63100]

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

Insertion in shell.nix at line 25 [26.98811]
[26.99189]
[26.99189]
```
    haskellPackages.ormolu
```

Integrate zcashd-based zaddr validation.

Dependencies

In channels

Change contents

Replacement in aftok.cabal at line 35 [4.1]

Insertion in aftok.cabal at line 47 [4.1]

Insertion in aftok.cabal at line 71 [4.1]

Replacement in client/src/Aftok/Api/Account.purs at line 107 [9.149]

Insertion in client/src/Aftok/Api/Account.purs at line 119 [9.149]

Insertion in client/src/Aftok/Api/Account.purs at line 121 [9.149]

File deletion: ZCash.hs

File addition: Zcash.hs (----------)

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 44 [10.456]

Replacement in lib/Aftok/Types.hs at line 16 [13.805]

Replacement in lib/Aftok/Types.hs at line 28 [13.805]

Replacement in lib/Aftok/Types.hs at line 30 [13.805]

Replacement in lib/Aftok/Types.hs at line 35 [13.805]

File addition: Users.hs (----------)

Insertion in server/Aftok/QConfig.hs at line 24 [14.4500]

Insertion in server/Aftok/QConfig.hs at line 39 [14.4500]

Insertion in server/Aftok/QConfig.hs at line 69 [14.4500]

Insertion in server/Aftok/Snaplet/Users.hs at line 11 [18.3234]