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(..))whereimport Aftok.Types (Email(..))import Aftok.Currency.Zcash (ZAddr, ZAddrError)data RegisterError= ZAddrParseError ZAddrErrordata RegisterOps m = RegisterOps, sendConfirmationEmail :: Email -> m ()}{ parseZAddr :: Text -> m (Either ZAddrError ZAddr)
| ZAddrInvalid
| RPCError ederiving (Show)toRequestBody :: RPCCall a -> ValuetoRequestBody = \caseZValidateAddress addr -> validateZAddrRequest addrZImportViewingKey vk -> importViewingKeyRequest vkrpcEval :: A.FromJSON a => Manager -> ZcashdConfig -> RPCCall a -> ExceptT (RPCError e) IO arpcEval mgr cfg call = dolet 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 responseexcept $ case statusCode status of200 -> first ParseError $ A.eitherDecode (responseBody response)_ -> Left (ServiceError status)-- Address Validationdata ZValidateAddressErr= ZAddrInvalid
data ValidateZAddrResponse = ValidateZAddrResponse{ isValid :: Bool, _address :: Maybe Text, addrType :: Maybe ZAddrType}instance A.FromJSON ValidateZAddrResponse whereparseJSON = parseValidateZAddrResponseparseAddrType :: Text -> Maybe ZAddrTypeparseAddrType = \case
decodeAddrType :: Text -> Maybe ZAddrTypedecodeAddrType = \case
parseValidateZAddrResponse :: Value -> Parser ValidateZAddrResponse
parseAddrType :: A.Object -> Parser (Maybe ZAddrType)parseAddrType res = dotypeStr <- res .:? "type"let typeMay = decodeAddrType <$> typeStrtraverse (maybe (fail $ "Not a recognized zaddr type: " <> show typeStr) pure) typeMayparseValidateZAddrResponse :: 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) -> dores <- v .: "result"ZValidateAddressResp <$> res .: "isvalid"-- <*> res .:? "address"<*> parseAddrType res
rpcValidateZAddr :: Manager -> ZcashdConfig -> Text -> IO (Either (RPCError ZValidateAddressErr) ZAddr)rpcValidateZAddr mgr cfg addr = runExceptT $ doresp <- rpcEval mgr cfg (ZValidateAddress addr)except $ if vzrIsValid respthencase vzrAddrType resp ofNothing -> Left (RPCError DataMissing)Just Sprout -> Left (RPCError SproutAddress)Just Sapling -> Right (ZAddr addr)elseLeft $ RPCError ZAddrInvalid
rpcValidateZAddr :: Manager -> ZcashdConfig -> Text -> IO (Either ZAddrError ZAddr)rpcValidateZAddr mgr cfg addr = dolet req = defaultRequest { host = T.encodeUtf8 $ zcashdHost cfg, port = zcashdPort cfg, method = "POST", requestBody = RequestBodyLBS $ encode (validateZAddrRequest addr)}
-- Viewing Keys
response <- httpLbs req mgrlet status = responseStatus responsepure $ case statusCode status of200 ->case A.eitherDecode (responseBody response) ofLeft err -> Left (ParseError err)Right resp ->if isValid respthencase addrType resp ofJust Sprout -> Left SproutAddressJust Sapling -> Right (ZAddr addr)_ -> Left DataMissingelseLeft ZAddrInvalid_ ->Left (ServiceError status)
data ZImportViewingKeyResp = ZImportViewingKeyResp{ addressType :: ZAddrType-- , address :: ZAddr}parseImportViewingKeyResponse :: Value -> Parser ZImportViewingKeyRespparseImportViewingKeyResponse = \case(A.Object v) -> doZImportViewingKeyResp<$> (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 whereparseJSON = parseImportViewingKeyResponsedata ZImportViewingKeyError= SproutViewingKeyimportViewingKeyRequest :: Text -> ValueimportViewingKeyRequest 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 $ doresp <- rpcEval mgr cfg (ZImportViewingKey vk)except $ case addressType resp ofSprout -> Left . RPCError $ SproutViewingKeySapling -> Right ()
data RegisterError= RegParseError String| RegCaptchaError [CaptchaError]| RegZAddrError (RPCError ZValidateAddressErr)instance A.ToJSON RegisterError wheretoJSON = \caseRegParseError 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 ofLeft err ->let cmsg = "Captcha check failed, please try again."in snapErrorJS 400 cmsg (RegCaptchaError err)Right _ -> pure ()
modifyResponse $ setResponseStatus c $ encodeUtf8 twriteText $ ((show c) <> " - " <> t)
let errBytes = encodeUtf8 tlogError errBytesmodifyResponse $ setResponseStatus c errByteswriteText (show c <> " - " <> t)getResponse >>= finishWithsnapErrorJS :: (A.ToJSON err, MonadSnap m) => Int -> Text -> err -> m asnapErrorJS c t err = dolet errBytes = A.encode errlogError (fromLazy errBytes)modifyResponse $ setResponseStatus c (encodeUtf8 t)writeLBS errBytes