SQ7UMLN5WCPHIF66RO4UQVX6RSNRRZBOVZP7HEMSKP7VO6YNQPRAC
MJDIMD5BQEBC265AQAGYE2K6EHHS7ZMZY3I6WE5MCDSTA2E2VY7AC
ENNZIQJG4XJ62QCNRMLNAXN7ICTPCHQFZTURX6QSUYYWNADFJHXQC
64C6AWH66FDKU6UE6Z6JPX2J2GBM2JOPTH2GL6LHKAIUBGNGDZ5AC
4R7XIYK3BP664CO3YJ2VM64ES2JYN27UTQG5KS34OTEPAIODSZLQC
B6HWAPDPXIWH7CHK5VLMWLL6EQN6NOFZEFYO47BPUY2ZO4SL7VDAC
DFOBMSAODB3NKW37B272ZXA2ML5HMIH3N3C4GT2DPEQS7ZFK4SNAC
4U7F3CPIDTK6JSEDMNMHVKSR7HOQDLZQD2PPVMDLHO5SFSIMUXZAC
IPG33FAWXGEQ2PO6OXRT2PWWXHRNMPVUKKADL6UKKN5GD2CNZ25AC
UUR6SMCAJMA7O3ZFUCQMPZFDDIPUVQ5IHUAC5F252YVD6H3JIKPQC
5IDB3IWSB6LFW4U772Y7BH5Y3FQOQ7IFWLVXDZE5XS6SKJITFV4QC
QO4NFWIYHF45PF7BA4IYGVZZ7CVZDHIV2427MQ6NXWHLIGBHBQCAC
EFSXYZPOGA5M4DN65IEIDO7JK6U34DMQELAPHOIL2UAT6HRC66BAC
GMYPBCWEB6NKURRILAHR3TJUKDOGR2ZMK5I6MS6P5G2LAGH36P3QC
IZEVQF627FA7VV25KJAWYWGGC35LZUUBBQRPN5ZAINTQLPEDRTEAC
W35DDBFYF6Z4ZPCFEO5RPAONZLYCSNTXUSTS6FIUUVZHCI6Q7GHAC
NLZ3JXLOOIL37O3RRQWXHNPNSNEOOLPD6MCB754BEBECQB3KGR2AC
HMDM3B557TO5RYP2IGFFC2C2VN6HYZTDQ47CJY2O37BW55DSMFZAC
JFOEOFGA4CQR2LW43IVQGDZSPVJAD4KDN2DZMZXGM2QDIUD7AVCAC
Q5X5RYQLP5K7REYD6VLHOKC4W36ZELJYA45V6YFKTD5S6MPN3NDQC
UWMGUJOW5X5HQTS76T2FD7MNAJF7SESPQVU5FDIZO52V75TT2X6AC
V2VDN77HCSRYYWXDJJ2XOVHV4P6PVWNJZLXZ7JUYPQEZQIH5BZ3QC
2XQD6KKKD6QVHFHAEMVE3XXY7X2T7BLTLL7XIILZAXNJJH2YONUQC
AL37SVTCKRSG4HG2PCYK5Z7QSIZZH5JHH4Q2VLMXFAXSAQRFFG4QC
BSIUHCGFDFDFGWYMHZB7OVU3Z3IHPEUXRISIOPGZI2RUXZFDS2EQC
NEDDHXUK3GNFMOFO3KLU7NRIHCTYNWBT3D6HTKZAOXFDE6HMDZ6AC
BROSTG5KP3NUNLSYPVQID254TE47E5RKQAKLPIY7PGWETE6JNMTAC
U256ZALIPTVWLNACYPIMWLNEYDQWP7CHF4Y4CGMILQTONJHMGQVQC
BXGLKYRXO2O4NRM3BLNWQ7AWVPQXAMFS57MFYHJNOZZEZZW5BH6AC
O2BZOX7MS4JCDS3C6EJQXAWUEQV6HVDCIF2FIN2BCJNRLIU6ZVKAC
PBD7LZYQHXAA3KLH2ZUX5GW4UFML6BQ32KXZF4KZ6OYFASUYFJ5QC
ADMKQQGCGVSHHIMVQ4XFRDCG544SBJCYALSKZV45CQQBZ4ACUH2AC
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)
| ZAddrInvalid
| 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
data ValidateZAddrResponse = ValidateZAddrResponse
{ isValid :: Bool
, _address :: Maybe Text
, addrType :: Maybe ZAddrType
}
instance A.FromJSON ValidateZAddrResponse where
parseJSON = parseValidateZAddrResponse
parseAddrType :: Text -> Maybe ZAddrType
parseAddrType = \case
decodeAddrType :: Text -> Maybe ZAddrType
decodeAddrType = \case
parseValidateZAddrResponse :: Value -> Parser ValidateZAddrResponse
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
(A.Object v) ->
ValidateZAddrResponse <$> v .: "isvalid"
<*> v .:? "address"
<*> ((traverse (maybe (fail "Not a recognized zaddr type") pure) . fmap parseAddrType) =<< v .:? "type")
(A.Object v) -> do
res <- v .: "result"
ZValidateAddressResp <$> res .: "isvalid"
-- <*> res .:? "address"
<*> parseAddrType res
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
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)
}
-- Viewing Keys
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)
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 ()
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) ]
let captchaFailed = throwDenied $ AU.AuthError "Captcha check failed, please try again."
void . either (const captchaFailed) pure $ captchaResult
case captchaResult of
Left err ->
let cmsg = "Captcha check failed, please try again."
in snapErrorJS 400 cmsg (RegCaptchaError err)
Right _ -> pure ()
modifyResponse $ setResponseStatus c $ encodeUtf8 t
writeText $ ((show c) <> " - " <> t)
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