This removes a pile of direct dependencies on bitcoin and BIP-70 oriented types in favor of a more modular approach to currency handling. Some pieces (auctions in particular) still need to be updated to use the new approach.
M4PWY5RUV72AEDCNC4O7UKBPHBIACR4354YTSC3SUZGWFV5UBJBQC
Z7CQXTU7NE5TPNLSYN3IQQBSY7IFPCXT3IHVUUSSQCBT24PIXWSAC
ONSJNBNFE5RI2DMUBM3LQXUUIMCEPLZXZIZOVBHSE7DECPNXE3CQC
X3ES7NUA42D2BF7CQDDKXM5CLMVCYA3H5YU5KXLPTGDBFPE2LNVAC
B6HWAPDPXIWH7CHK5VLMWLL6EQN6NOFZEFYO47BPUY2ZO4SL7VDAC
LEINLS3X55PB6TSCNC5RVMDMV56XHTV4MNDUC42H7DDFMPDYUNTAC
5IDB3IWSB6LFW4U772Y7BH5Y3FQOQ7IFWLVXDZE5XS6SKJITFV4QC
64C6AWH66FDKU6UE6Z6JPX2J2GBM2JOPTH2GL6LHKAIUBGNGDZ5AC
4U7F3CPIDTK6JSEDMNMHVKSR7HOQDLZQD2PPVMDLHO5SFSIMUXZAC
HMDM3B557TO5RYP2IGFFC2C2VN6HYZTDQ47CJY2O37BW55DSMFZAC
HALRDT2F22DAQ54M334YSKD2XJCAXDXEZPDKGMOWKH7XELBAS6MAC
WO2MINIF4TXOHWSE7JWXRZYN64XRVLYIRFMF4SMPSOXKA2V77KMQC
OBFPJS2GHO2PEHBHGEHKIUOUAFIQHPIZXEVD2YIE3ZIE2PVMH5VAC
WZFQDWW4XK6M4A4PQ7WQJUTZUPRGQR7V7ZVZY5ZTL5AMGIFMHB2QC
EKI57EJR65DA5FPILAHGHHAIU5ITVGHA6V3775OX7GV5XD67OWRQC
5DRIWGLUKMQZU2ZPBXSTLAWJKAMOD5YXAHM5LEDQHDFGYYLHWCDQC
SEWTRB6S5PO5MQBLCPVBD7XT2BDYNZUE2RO6Z2XENZRIOCN6OZJAC
POX3UAMTGCNS3SU5I6IKDNCCSHEAUSFBZ3WCMQ3EXKPNXETOI6BAC
7KZP4RHZ3QSYTPPQ257A65Z5UPX44TF2LAI2U5EMULQCLDCEUK2AC
IPG33FAWXGEQ2PO6OXRT2PWWXHRNMPVUKKADL6UKKN5GD2CNZ25AC
EFSXYZPOGA5M4DN65IEIDO7JK6U34DMQELAPHOIL2UAT6HRC66BAC
ENNZIQJG4XJ62QCNRMLNAXN7ICTPCHQFZTURX6QSUYYWNADFJHXQC
4R7XIYK3BP664CO3YJ2VM64ES2JYN27UTQG5KS34OTEPAIODSZLQC
LAROLAYUGJ4Q5AEFV5EJMIA2ZKBNCBWHHHPCJ3CKCNIUIYUKRFVQC
DFOBMSAODB3NKW37B272ZXA2ML5HMIH3N3C4GT2DPEQS7ZFK4SNAC
73NDXDEZRMK672GHSTC3CI6YHXFZ2GGJI5IKQGHKFDZKTNSQXLLQC
Y3LIJ5USPMYBG7HKCIQBE7MWVGLQJPJSQD3KPZCTKXP22GOB535QC
AL37SVTCKRSG4HG2PCYK5Z7QSIZZH5JHH4Q2VLMXFAXSAQRFFG4QC
UWMGUJOW5X5HQTS76T2FD7MNAJF7SESPQVU5FDIZO52V75TT2X6AC
SQ7UMLN5WCPHIF66RO4UQVX6RSNRRZBOVZP7HEMSKP7VO6YNQPRAC
IZEVQF627FA7VV25KJAWYWGGC35LZUUBBQRPN5ZAINTQLPEDRTEAC
A6HKMINBNGQLLX4QJMYWKQ4JAEHVJ4HIRVDKPPDI3FJUO2AAB7OQC
QMRKFEPGFBCEWAIXPEIG5ILKAJ2JH5L3TOITHR4HNJXK5FN3KXBQC
4FDQGIXN3Z4J55DILCSI5EOLIIA7R5CADTGFMW5X7N7MH6JIMBWAC
FD7SV5I6VCW27HZ3T3K4MMGB2OYGJTPKFFA263TNTAMRJGQJWVNAC
GCVQD44VRPQVKPZEPIC4AOIXLJIG2ZMV3QI2Y7KALUT6NVUBSGSAC
U256ZALIPTVWLNACYPIMWLNEYDQWP7CHF4Y4CGMILQTONJHMGQVQC
AWWC6P5ZVFDQHX3EAYDG4DKTUZ6A5LHQAV3NIUO3VP6FM7JKPK5AC
LTSVBVA235BQAIU3SQURKSRHIAL33K47G4J6TSEP2K353OCHNJEAC
ZKFETYRKPM2BYO47I4B7ZTZZNIGTUKKYX2KK27KUETVJXUV5O65AC
EKY7U7SKPF45OOUAHJBEQKXSUXWOHFBQFFVJWPBN5ARFJUFM2BPAC
KEP5WUFJXTMKRRNZLYTGYYWA4VLFCMHTKTJYF5EA5IWBYFMU6WYQC
TNR3TEHKVADAEZSTOD2XLSUTSW5AWST2YUW4CWK5KE7DSC6XHZNAC
RN7EI6INGUUHGMNY5RU3NH56WPLRZY5ZMYDNFMNE3TGV4ESFLQIAC
NEDDHXUK3GNFMOFO3KLU7NRIHCTYNWBT3D6HTKZAOXFDE6HMDZ6AC
Z7KS5XHHC6PAMTVBHXY7KUSS3BWAOU6FSYIITUCFOOJZU4OUJHBAC
J6S23MDGHVSCVVIRB6XRNSY3EGTDNWFJHV7RYLIEHBUK5KU63CFQC
2XQD6KKKD6QVHFHAEMVE3XXY7X2T7BLTLL7XIILZAXNJJH2YONUQC
JFOEOFGA4CQR2LW43IVQGDZSPVJAD4KDN2DZMZXGM2QDIUD7AVCAC
BSIUHCGFDFDFGWYMHZB7OVU3Z3IHPEUXRISIOPGZI2RUXZFDS2EQC
O5FVTOM6YFBLEPF3S576K6IMT6ZZ5VQCSB3YVXNS4CKBITKCRZ7AC
LD4GLVSF6YTA7OZWIGJ45H6TUXGM4WKUIYXKWQFNUP36WDMYSMXAC
Q5X5RYQLP5K7REYD6VLHOKC4W36ZELJYA45V6YFKTD5S6MPN3NDQC
WAIX6AGNDVJOKTWZ7OP7QOYSJHAJSX5EOWXZHOAO2IG6ALWUCJ6QC
O227CEAV7BTKSE3SSC7XHC5IWEBXZL2AOOKJMBMOOFNTLINBLQMAC
3QVT6MA6I2CILQH3LUZABS4YQ7MN6CNRYTDRVS376OOHTPLYTFJAC
ZTPDQKLAB6JJGUFYNBE2OYDW7LV64FNI6BXBO3TBWOM4YF5UWI5QC
2J37EVJMX255K3XEJHTZGRPEIRMAQ62JQWOA7JU3YTZUB6PUPWVQC
RPAJLHMTUJU4AYNBOHVGHGGB4NY2NLY3BVPYN5FMWB3ZIMAUQHCQC
RSF6UAJKG7CEKILSVXI6C4YZXY7PIYZM2EMA2IXKQ7SADKNVSH7QC
F4ONFXF4MSA3QM64T7ATRVO3NQR2MC3RVZGVNGSQXCKXXQX2UG7QC
ZIG57EE6RB22JGB3CT33EN2HVYCHCXBT5GROBTBMBLEMDTGQOOBQC
EW2XN7KUMCAQNVFJJ5YTAVDZCPHNWDOEDMRFBUGLY6IE2HKNNX5AC
QADKFHAR3KWQCNYU25Z7PJUGMD5WL26IU3DOAHBTRN2A7NKPUPKAC
NLZ3JXLOOIL37O3RRQWXHNPNSNEOOLPD6MCB754BEBECQB3KGR2AC
5OI44E4EEVYOMHDWNK2WA7K4L4JWRWCUJUNN2UAUGE5VY4W7GTNAC
NAS4BFL43SIUAAC663R6VFBHQ2DKI45K6Y6ZKVQI7S5547HBAN7QC
FXJQACESPGTLPG5ELXBU3M3OQXUZQQIR7HPIEHQ3FNUTMWVH4WBAC
ASF3UPJLCX7KIUCNJD5KAXSPDXCUEJHLL4HBRTRUBPCW73IXOCWQC
W35DDBFYF6Z4ZPCFEO5RPAONZLYCSNTXUSTS6FIUUVZHCI6Q7GHAC
Z3MK2PJ5U222DXRS22WCDHVPZ7HVAR3HOCUNXIGX6VMEPBQDF6PQC
O722AOKEWXWJPRHGJREU6QPW7HEFPPRETZIAADZ2RMAXHARCNEKAC
7VGYLTMURLVSVUYFW7TCRZTDQ6RE2EPSPPA43XKHDOBFWYVVSJHQC
NVOCQVASZWTKQJG7GPH7KHKZZR7NUG4WLV5YY4KAIRPCJRWCZPIAC
KNSI575VAW6HRCZYXOEPQ4DTSML4EORML5MV4DJBRKE7TXCPS4EAC
SCXG6TJWYIPRUMT27KGKIIF6FYKTUTY74UNZ2FQTT63XZ6HIF3AAC
4QX5E5ACVN57KJLCWOM4JEI6JSV4XZNCWVYPOTKSOMUW3SOMCNJAC
PBD7LZYQHXAA3KLH2ZUX5GW4UFML6BQ32KXZF4KZ6OYFASUYFJ5QC
2WOOGXDHVQ6L2MQYUTLJ6H6FVSQNJN6SMJL5DG7HAHFYPJLRT2SAC
SPJCFHXWUHL5DPU72R6MLMVYCRL4YNOMGTDXRFL6GZPN5KOHAW7AC
UOG5H2TW5R3FSHQPJCEMNFDQZS5APZUP7OM54FIBQG7ZP4HASQ7QC
E7GQXOIDEENBMGLE3ZMKIVB4RUWL5H7YTR4E4DTX6V7HAVCBBRYAC
XZLSHL4DE6B5OEJVXALEYXY5JY2EJYUL2SSUJEGMNX65Y6JRJJUAC
NSRSSSTRMJPPUYQANYDWGI5D3NVM6RQEVZCDUUNQAOL3OWQTD27AC
SFWL5626TREXK42DULCXFKKXRCYYGCPAELRZGIRLUMZBNZRAYW7QC
G4BS4NNDS37COYU3K76Q6GXYEK26MWSX5SVPYSQ7VKHZ6YWRITUAC
3MERL4JA5VM7SY5HRIRCZJGVQHWTGVEW3HXFDHTXUEZIDGLMFACQC
QMEYU4MWLTSWPWEEOFRLK2IKE64BY3V5X73323WPLCGPP3TPDYGAC
CDHZL3RP2HGNSSBXD4VDSAW7M3SPBF7LBYB2BL6I3N6EI5URSOJAC
QU5FW67RGCWOWT2YFM4NYMJFFHWIRPQANQBBAHBKZUY7UYMCSIMQC
VRMUVBP66QHIOSLOFYLN7W6EDCZVB42Y6X2MHDMCT3GCJ3KCW7DAC
2G3GNDDUOVPF45PELJ65ZB2IXEHJJXJILFRVHZXGPXUL4BVNZJFQC
NJNMO72S7VIUV22JXB4IFPZMHWTJAOTP6EC6Z4QSKYIROSXT52MQC
BROSTG5KP3NUNLSYPVQID254TE47E5RKQAKLPIY7PGWETE6JNMTAC
UILI6PILCRDPZ3XYA54LGIGPSU7ERWNHCE7R3CE64ZEC7ONOEMOQC
EZQG2APB36DDMIAYDPPDGOIXOD7K2RZZSGC2NKGZIHB2HZBTW7EQC
Z24SZOGZJLDTDTGWH7M25RYQ7MYSU52ZLFWJ2PSQFTMK4J35PIWAC
ADMKQQGCGVSHHIMVQ4XFRDCG544SBJCYALSKZV45CQQBZ4ACUH2AC
EMVTF2IWNQGRL44FC4JNG5FYYQTZSFPNM6SOM7IAEH6T7PPK2NVAC
LHJ2HFXVUQ4VG25I7DADWU73G5K5WNZBDQ3SVNKFYLZ5BEYM4XCQC
2KZPOGRBY6KBMO76F55ZKIVOLSG3O63VP3RHRZVANXYT3OLZ3OWQC
instance P.AsPaymentError AftokDErr where
_PaymentError = _PaymentErr . P._PaymentError
_Overdue = _PaymentErr . P._Overdue
_SigningError = _PaymentErr . P._SigningError
-- instance P.AsPaymentError AftokDErr where
-- _PaymentError = _PaymentErr . P._PaymentError
-- _Overdue = _PaymentErr . P._Overdue
-- _SigningError = _PaymentErr . P._SigningError
instance P.HasPaymentsConfig AftokMEnv where
networkMode = pcfg . P.networkMode
signingKey = pcfg . P.signingKey
pkiData = pcfg . P.pkiData
paymentsConfig = pcfg
-- instance P.HasPaymentsConfig AftokMEnv where
-- networkMode = pcfg . P.networkMode
-- signingKey = pcfg . P.signingKey
-- pkiData = pcfg . P.pkiData
-- paymentsConfig = pcfg
let ops = P.BillingOps memoGen (fmap Just . paymentURL) payloadGen
btcCfg <- asks _pcfg
let btcOps = BillingOps _memoGen (fmap Just . bip70PaymentURL) _payloadGen
zecCfg = Zcash.PaymentsConfig (Zatoshi 100)
pcfg' = P.PaymentsConfig btcOps btcCfg zecCfg
traverse (\uid -> P.createPaymentRequests ops now uid pid) $ subscribers
traverse_ sendPaymentRequestEmail (join requests)
fmap join
. exceptT (throwError . PaymentErr) pure
$ traverse (\s -> fmap (snd s,) <$> P.createSubscriptionPaymentRequests pcfg' now s) subscriptions
traverse_ sendPaymentRequestEmail requests
sendPaymentRequestEmail :: P.PaymentRequestId -> AftokM ()
sendPaymentRequestEmail reqId = do
_Compose :: Iso' (f (g a)) (Compose f g a)
_Compose = iso Compose getCompose
-- | TODO: Currently will only send email for bip70 requests
sendPaymentRequestEmail :: (B.Subscription, (P.PaymentRequestId, P.SomePaymentRequestDetail)) -> AftokM ()
sendPaymentRequestEmail (sub, (_, P.SomePaymentRequest req)) = do
reqMay = do
preq <- DB.findPaymentRequestId reqId
preq' <- traverseOf P.subscription DB.findSubscriptionBillable preq
preq'' <- traverseOf (P.subscription . customer) DB.findUser preq'
traverseOf (P.subscription . billable . project) DB.findProject preq''
req <- maybeT (throwError $ DBErr DB.SubjectNotFound) pure reqMay
bip70URL <- paymentURL (req ^. paymentKey)
mail <- buildPaymentRequestEmail preqCfg req bip70URL
let mailer =
maybe
(SMTP.sendMailWithLogin _smtpHost)
(SMTP.sendMailWithLogin' _smtpHost)
_smtpPort
liftIO $ mailer _smtpUser _smtpPass mail
req' = over P.billable (\b -> Compose $ sub & B.billable .~ b) req
req'' <- enrichWithUser req'
req''' <- enrichWithProject req''
case req''' ^. P.nativeRequest of
P.Bip70Request nreq -> do
bip70URL <- bip70PaymentURL (nreq ^. Bitcoin.paymentRequestKey)
mail <- buildBip70PaymentRequestEmail preqCfg req''' bip70URL
let mailer =
maybe
(SMTP.sendMailWithLogin _smtpHost)
(SMTP.sendMailWithLogin' _smtpHost)
_smtpPort
liftIO $ mailer _smtpUser _smtpPass mail
P.Zip321Request _ -> pure ()
buildPaymentRequestEmail ::
enrichWithUser ::
P.PaymentRequest' (Compose (Subscription' UserId) (Billable' p u)) a ->
AftokM (P.PaymentRequest' (Compose (Subscription' User) (Billable' p u)) a)
enrichWithUser req = do
let sub = req ^. P.billable . from _Compose
sub' <-
maybeT (throwError $ DBErr DB.SubjectNotFound) pure $
traverseOf customer DB.findUser sub
pure (set P.billable (Compose sub') req)
enrichWithProject ::
P.PaymentRequest' (Compose (Subscription' u) (Billable' ProjectId u')) a ->
AftokM (P.PaymentRequest' (Compose (Subscription' u) (Billable' Project u')) a)
enrichWithProject req = do
let sub = req ^. P.billable . from _Compose
sub' <-
maybeT (throwError $ DBErr DB.SubjectNotFound) pure $
traverseOf (B.billable . project) DB.findProject sub
pure (set P.billable (Compose sub') req)
buildBip70PaymentRequestEmail ::
pname = req ^. (subscription . billable . project . projectName)
total = req ^. (P.paymentRequest . to paymentRequestTotal)
pname = req ^. P.billable . to getCompose . B.billable . B.project . projectName
total = req ^. P.billable . to getCompose . B.billable . B.amount
memoGen ::
Subscription' UserId Billable -> C.Day -> C.UTCTime -> AftokM (Maybe Text)
memoGen sub billingDate requestTime = do
req <- traverseOf (billable . project) DB.findProjectOrError sub
_memoGen ::
DB.MonadDB m =>
Billable Satoshi ->
C.Day ->
C.UTCTime ->
m (Maybe Text)
_memoGen bill billingDate requestTime = do
req <- traverseOf B.project DB.findProjectOrError bill
{-# LANGUAGE TemplateHaskell #-}
module Aftok.Currency.Bitcoin.Bip70
( module Bippy.Proto,
)
where
import Bippy.Proto
{-# LANGUAGE TemplateHaskell #-}
module Aftok.Currency.Bitcoin.Payments
( PaymentKey (..),
_PaymentKey,
Payment (..),
PaymentRequest (..),
amount,
txid,
address,
bip70Payment,
paymentKey,
bip70Request,
paymentRequestKey,
)
where
import qualified Bippy.Proto as B
import Bippy.Types (Satoshi)
import Control.Lens (makeLenses, makePrisms)
import Haskoin.Address (Address (..))
-- A unique identifier for a payment request, suitable
-- for URL embedding.
newtype PaymentKey = PaymentKey Text deriving (Eq)
makePrisms ''PaymentKey
data PaymentRequest
= PaymentRequest
{ _paymentRequestKey :: PaymentKey,
_bip70Request :: B.PaymentRequest
}
makeLenses ''PaymentRequest
data Payment
= Payment
{ _amount :: Maybe Satoshi,
_txid :: Maybe Text,
_address :: Maybe Address,
_paymentKey :: PaymentKey,
_bip70Payment :: B.Payment
}
makeLenses ''Payment
toNetwork :: NetworkMode -> NetworkId -> Network
toNetwork LiveMode = \case
BTC -> btc
BCH -> bch
toNetwork TestMode = \case
BTC -> btcTest
BCH -> bchTest
toNetworkId :: Network -> Maybe NetworkId
toNetworkId n = case getNetworkName n of
"btc" -> Just BTC
"btcTest" -> Just BTC
"bch" -> Just BCH
"bchTest" -> Just BCH
_ -> Nothing
getNetwork :: NetworkMode -> Network
getNetwork = \case
LiveMode -> btc
TestMode -> btcTest
{-# LANGUAGE TemplateHaskell #-}
module Aftok.Currency.Zcash.Payments where
import Aftok.Currency.Zcash.Types (Zatoshi)
import Control.Lens (makeLenses, makePrisms)
newtype TxId = TxId Text
makePrisms ''TxId
data Payment
= Payment
{ _amount :: Zatoshi,
_txid :: TxId
}
makeLenses ''Payment
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Aftok.Currency.Zcash.Types where
import Control.Lens (makePrisms)
coin :: Word64
coin = 100000000
maxMoney :: Word64
maxMoney = 21000000 * coin
newtype IVK = IVK {ivkText :: Text}
deriving (Eq, Ord, Show)
makePrisms ''IVK
newtype Address = Address {zaddrText :: Text}
deriving (Eq, Ord, Show)
makePrisms ''Address
newtype Zatoshi = Zatoshi Word64
deriving stock (Eq, Ord, Show)
makePrisms ''Zatoshi
class ToZatoshi a where
toZatoshi :: a -> Maybe Zatoshi
instance ToZatoshi Word64 where
toZatoshi amt =
if amt > maxMoney then Nothing else Just (Zatoshi amt)
instance Semigroup Zatoshi where
(Zatoshi a) <> (Zatoshi b) = Zatoshi (a + b)
data ZAddrType
= Sprout
| Sapling
decodeAddrType :: Text -> Maybe ZAddrType
decodeAddrType = \case
"sprout" -> Just Sprout
"sapling" -> Just Sapling
_ -> Nothing
newtype Memo = Memo ByteString
{-# LANGUAGE TemplateHaskell #-}
module Aftok.Currency.Zcash.Zip321 where
import Aftok.Currency.Zcash.Types
import Control.Lens ((^.), makeLenses, makePrisms)
import Data.Attoparsec.Text
( Parser,
char,
choice,
decimal,
option,
parseOnly,
scientific,
sepBy1,
string,
takeText,
takeTill,
takeWhile1,
)
import Data.ByteString.Base64.URL (decodeBase64, encodeBase64Unpadded)
import Data.Char (isAlpha, isAscii, isDigit)
import Data.List.NonEmpty (zip)
import qualified Data.Map.Strict as M
import Data.Scientific (toBoundedInteger)
import Data.Text (any, intercalate, pack, unpack)
import Network.URI.Encode (decodeText, encodeTextWith)
import Text.Printf (printf)
import Prelude hiding (any, intercalate, zip)
data PaymentItem
= PaymentItem
{ _address :: Address,
_amount :: Zatoshi,
_memo :: Maybe Memo,
_message :: Maybe Text,
_label :: Maybe Text,
_other :: [(Text, Text)] -- TODO: param name restrictions
}
makeLenses ''PaymentItem
data PaymentRequest
= PaymentRequest
{ _items :: NonEmpty PaymentItem
}
makeLenses ''PaymentRequest
-- The set of ASCII characters that are excepted from percent-encoding according
-- to the definition of ZIP 321.
--
-- unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
-- allowed-delims = "!" / "$" / "'" / "(" / ")" / "*" / "+" / "," / ";"
-- qchar = unreserved / pct-encoded / allowed-delims / ":" / "@"
qchar :: Char -> Bool
qchar c =
(isAscii c && isAlpha c)
|| isDigit c
|| any (== c) "-._!$'()*+,;:@"
paramIndex :: Maybe Int -> Text
paramIndex = maybe "" (\i -> pack (printf ".%d" i)) . find (> 0)
addrParam :: Maybe Int -> Address -> Text
addrParam i (Address t) = strParam "address" i t
amountParam :: Maybe Int -> Zatoshi -> Text
amountParam i (Zatoshi value) =
"amount" <> paramIndex i <> "=" <> valueText
where
coins = value `div` coin
zats = value `mod` coin
valueText =
pack $
if zats == 0
then printf "%d" coins
else printf "%d.%0.8d" coins zats
strParam :: Text -> Maybe Int -> Text -> Text
strParam l i value =
l <> paramIndex i <> "=" <> encodeTextWith qchar value
memoParam :: Maybe Int -> Memo -> Text
memoParam i (Memo bytes) = "memo" <> paramIndex i <> "=" <> encodeBase64Unpadded bytes
itemPartial :: Maybe Int -> PaymentItem -> [Text]
itemPartial i item =
catMaybes
[ Just $ amountParam i (item ^. amount),
memoParam i <$> (item ^. memo),
strParam "message" i <$> (item ^. message),
strParam "label" i <$> (item ^. label)
]
itemsParams :: NonEmpty PaymentItem -> NonEmpty Text
itemsParams xs =
intercalate "&" . toList . itemParams <$> zip (Just <$> fromList [1 ..]) xs
where
itemParams (i, item) =
addrParam i (item ^. address) : itemPartial i item
toURI :: PaymentRequest -> Text
toURI req =
case req ^. items of
i :| [] ->
"zcash:" <> zaddrText (i ^. address) <> "?"
<> intercalate "&" (itemPartial Nothing i)
xs ->
"zcash:?" <> intercalate "&" (toList $ itemsParams xs)
addrElem :: Char -> Bool
addrElem c = isDigit c || (isAscii c && isAlpha c)
data Zip321Param
= AddrParam Address
| AmountParam Zatoshi
| MemoParam Memo
| LabelParam Text
| MessageParam Text
| OtherParam Text Text
makePrisms ''Zip321Param
type IndexedParam = (Int, Zip321Param)
zip321Parser :: Parser PaymentRequest
zip321Parser = do
void $ string "zcash:"
addr0 <- toAddress <$> takeTill (== '?')
params' <- sepBy1 zip321Param (char '&')
let params = second (: []) <$> (toList addr0 <> params')
grouped = M.fromListWith (<>) params
groups <- maybe (fail "Parameter list was empty.") pure (nonEmpty $ M.toAscList grouped)
either (fail . unpack) (pure . PaymentRequest) $ traverse (toPaymentItem . snd) groups
where
toAddress addr =
if addr == ""
then Nothing
else Just (0, AddrParam $ Address addr)
zip321Param =
choice
[ parseAddrParam,
parseAmountParam,
parseMemoParam,
parseLabelParam,
parseMessageParam,
parseOtherParam
]
toPaymentItem :: [Zip321Param] -> Either Text PaymentItem
toPaymentItem = error "Not yet implemented." --PaymentItem <$> note "Payment address is required"
indexedParam :: Text -> Parser Zip321Param -> Parser IndexedParam
indexedParam name valuep = do
void $ string name
idx <- option 0 (char '.' *> decimal)
(,) <$> pure idx <*> (char '=' *> valuep)
parseAddrParam :: Parser IndexedParam
parseAddrParam = indexedParam "address" (AddrParam . Address <$> takeWhile1 addrElem)
parseAmountParam :: Parser IndexedParam
parseAmountParam = indexedParam "amount" $ do
s <- scientific
let zats = s * fromIntegral coin
maybe
(fail "Amount is out of bounds")
(pure . AmountParam . Zatoshi)
(toBoundedInteger zats)
parseMemoParam :: Parser IndexedParam
parseMemoParam = indexedParam "memo" $ do
t <- takeText
either
(\e -> fail . unpack $ "Base64 decoding of memo value failed: " <> e)
(pure . MemoParam . Memo)
(decodeBase64 $ encodeUtf8 t)
parseLabelParam :: Parser IndexedParam
parseLabelParam = indexedParam "label" (LabelParam . decodeText <$> takeText)
parseMessageParam :: Parser IndexedParam
parseMessageParam = indexedParam "message" (MessageParam . decodeText <$> takeText)
parseOtherParam :: Parser IndexedParam
parseOtherParam = do
pname <- takeWhile1 paramNameChar
idx <- option 0 (char '.' *> decimal)
void (char '=')
value <- decodeText <$> takeText
pure (idx, OtherParam pname value)
where
paramNameChar c = isDigit c || (isAscii c && isAlpha c) || c == '+' || c == '-'
parseURI :: Text -> Either String PaymentRequest
parseURI = parseOnly zip321Parser
coin :: Word64
coin = 100000000
maxMoney :: Word64
maxMoney = 21000000 * coin
newtype ZAddr = ZAddr {zaddrText :: Text}
deriving (Eq, Ord, Show)
makePrisms ''ZAddr
newtype Zatoshi = Zatoshi Word64
deriving (Eq, Ord, Show)
makePrisms ''Zatoshi
class ToZatoshi a where
toZatoshi :: a -> Maybe Zatoshi
instance ToZatoshi Word64 where
toZatoshi amt =
if amt > maxMoney then Nothing else Just (Zatoshi amt)
data ZAddrType
= Sprout
| Sapling
scaleCurrency :: Currency a c -> c -> Rational -> Maybe c
scaleCurrency c amount factor = case c of
BTC -> (\(Bitcoin.Satoshi amt) -> Just $ Bitcoin.Satoshi ((round $ toRational amt * factor) :: Word64)) amount
ZEC -> (\amt -> Zcash.toZatoshi ((round $ toRational (view Zcash._Zatoshi amt) * factor) :: Word64)) amount
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
module Aftok.Database.PostgreSQL.Auctions
( createAuction,
findAuction,
createBid,
findBids,
)
where
import Aftok.Auction
( Auction (..),
AuctionId (..),
Bid (..),
BidId (..),
_AuctionId,
auctionEnd,
bidAmount,
bidSeconds,
bidTime,
bidUser,
initiator,
projectId,
raiseAmount,
)
-- import Aftok.Currency ( Amount(..) )
-- import qualified Aftok.Currency.Bitcoin as Bitcoin
import Aftok.Currency.Bitcoin (_Satoshi)
-- import qualified Aftok.Currency.Zcash as Zcash
import Aftok.Database ()
import Aftok.Database.PostgreSQL.Types
( DBM,
btcAmountParser,
idParser,
pinsert,
pquery,
utcParser,
)
import Aftok.Types
( ProjectId (..),
UserId (..),
_ProjectId,
_UserId,
)
import Control.Lens
import Data.Hourglass (Seconds (..))
import qualified Data.Thyme.Time as C
import Database.PostgreSQL.Simple (Only (..))
import Database.PostgreSQL.Simple.FromField ()
import Database.PostgreSQL.Simple.FromRow (RowParser, field)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Safe (headMay)
import Prelude hiding (null)
auctionParser :: RowParser Auction
auctionParser =
Auction
<$> idParser ProjectId
<*> idParser UserId
<*> utcParser
<*> btcAmountParser
<*> utcParser
<*> utcParser
bidParser :: RowParser Bid
bidParser =
Bid <$> idParser UserId <*> (Seconds <$> field) <*> btcAmountParser <*> utcParser
createAuction :: Auction -> DBM AuctionId
createAuction auc =
pinsert
AuctionId
[sql| INSERT INTO auctions (project_id, initiator_id, raise_amount, end_time)
VALUES (?, ?, ?, ?) RETURNING id |]
( auc ^. (projectId . _ProjectId),
auc ^. (initiator . _UserId),
auc ^. (raiseAmount . _Satoshi),
auc ^. (auctionEnd . to C.fromThyme)
)
findAuction :: AuctionId -> DBM (Maybe Auction)
findAuction aucId =
headMay
<$> pquery
auctionParser
[sql| SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time
FROM auctions
WHERE id = ? |]
(Only (aucId ^. _AuctionId))
createBid :: AuctionId -> Bid -> DBM BidId
createBid (AuctionId aucId) bid =
pinsert
BidId
[sql| INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time)
VALUES (?, ?, ?, ?, ?) RETURNING id |]
( aucId,
bid ^. (bidUser . _UserId),
case bid ^. bidSeconds of
(Seconds i) -> i,
bid ^. (bidAmount . _Satoshi),
bid ^. (bidTime . to C.fromThyme)
)
findBids :: AuctionId -> DBM [(BidId, Bid)]
findBids aucId =
pquery
((,) <$> idParser BidId <*> bidParser)
[sql| SELECT id, bidder_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ? |]
(Only (aucId ^. _AuctionId))
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
module Aftok.Database.PostgreSQL.Billing
( createBillable,
findBillable,
findBillables,
createSubscription,
findSubscription,
findSubscriptions,
findSubscribers,
storePaymentRequest,
findPaymentRequestByKey,
findPaymentRequestById,
findSubscriptionPaymentRequests,
findSubscriptionUnpaidRequests,
createPayment,
findPayments,
)
where
import Aftok.Billing
( Billable,
Billable' (..),
BillableId (..),
ContactChannel (..),
Recurrence (..),
Subscription,
Subscription' (..),
SubscriptionId (..),
_BillableId,
_SubscriptionId,
amount,
description,
gracePeriod,
name,
paymentRequestEmailTemplate,
paymentRequestMemoTemplate,
project,
recurrence,
recurrenceCount,
recurrenceName,
)
import Aftok.Currency (Amount (..), Currency (..))
import Aftok.Currency.Bitcoin (Satoshi)
import qualified Aftok.Currency.Bitcoin as Bitcoin
import qualified Aftok.Currency.Bitcoin.Payments as Bitcoin
import Aftok.Currency.Zcash (Zatoshi)
import Aftok.Database.PostgreSQL.Json
( nativeRequestJSON,
parseBip70PaymentRequestJSON,
parseBitcoinPaymentJSON,
parseZcashPaymentJSON,
parseZip321PaymentRequestJSON,
paymentJSON,
)
import Aftok.Database.PostgreSQL.Types
( DBM,
currencyAmountParser,
currencyType,
currencyValue,
idParser,
nominalDiffTimeParser,
nullField,
pinsert,
pquery,
)
import Aftok.Payments.Types
( NativePayment (..),
NativeRequest (..),
Payment,
Payment' (Payment),
PaymentId (..),
PaymentRequest,
PaymentRequest' (..),
PaymentRequestId (..),
PaymentRequestId,
SomePaymentRequest (..),
SomePaymentRequestDetail,
_PaymentRequestId,
billingDate,
bip70Request,
createdAt,
nativeRequest,
paymentDate,
paymentRequest,
)
import Aftok.TimeLog
( EventId (..),
_EventId,
)
import Aftok.Types
( Email (..),
ProjectId (..),
UserId (..),
_ProjectId,
_UserId,
)
import Control.Lens ((.~), (^.), (^?), _Just, to, view)
import Data.Aeson (encode)
import Data.Aeson.Types (parseEither)
import qualified Data.Thyme.Clock as C
import qualified Data.Thyme.Time as C
import Database.PostgreSQL.Simple (Only (..), ResultError (Incompatible))
import Database.PostgreSQL.Simple.FromField (FieldParser, returnError, typename)
import Database.PostgreSQL.Simple.FromRow (RowParser, field, fieldWith)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Safe (headMay)
import Prelude hiding (null)
billableParser :: RowParser (Billable Amount)
billableParser =
Billable
<$> idParser ProjectId
<*> idParser UserId
<*> field
<*> field
<*> field
<*> recurrenceParser
<*> currencyAmountParser
<*> field
<*> fieldWith nominalDiffTimeParser
<*> field
<*> field
recurrenceParser :: RowParser Recurrence
recurrenceParser = join $ fieldWith recurrenceParser'
recurrenceParser' :: FieldParser (RowParser Recurrence)
recurrenceParser' f v = do
tn <- typename f
if tn /= "recurrence_t"
then returnError Incompatible f "column was not of type recurrence_t"
else maybe empty (pure . parser . decodeUtf8) v
where
parser :: Text -> RowParser Recurrence
parser = \case
"annually" -> nullField *> pure Annually
"monthly" -> Monthly <$> field
--"semimonthly" = nullField *> pure SemiMonthly
"weekly" -> Weekly <$> field
"onetime" -> nullField *> pure OneTime
_ -> empty
subscriptionParser :: RowParser Subscription
subscriptionParser =
Subscription
<$> idParser UserId
<*> idParser BillableId
<*> (EmailChannel . Email <$> field)
<*> (C.toThyme <$> field)
<*> ((fmap C.toThyme) <$> field)
bip70RequestParser :: RowParser (NativeRequest Satoshi)
bip70RequestParser =
Bip70Request <$> ((either (const empty) pure . parseEither parseBip70PaymentRequestJSON) =<< field)
zip321RequestParser :: RowParser (NativeRequest Zatoshi)
zip321RequestParser =
Zip321Request <$> ((either (const empty) pure . parseEither parseZip321PaymentRequestJSON) =<< field)
paymentRequestDetailParser :: RowParser SomePaymentRequestDetail
paymentRequestDetailParser = do
billable <- billableParser
ctime :: C.UTCTime <- C.toThyme <$> field
billDay :: C.Day <- C.toThyme <$> field
case billable ^. amount of
(Amount BTC sats) -> do
nativeReq <- bip70RequestParser
pure . SomePaymentRequest $ PaymentRequest (billable & amount .~ sats) ctime billDay nativeReq
(Amount ZEC zats) -> do
nativeReq <- zip321RequestParser
pure . SomePaymentRequest $ PaymentRequest (billable & amount .~ zats) ctime billDay nativeReq
paymentParser :: Bitcoin.NetworkMode -> PaymentRequestId -> Currency a c -> RowParser (Payment c)
paymentParser nmode prid ccy = do
d :: C.UTCTime <- C.toThyme <$> field
case ccy of
BTC -> Payment (Const prid) d <$> bitcoinPaymentParser nmode
ZEC -> Payment (Const prid) d <$> zcashPaymentParser
bitcoinPaymentParser :: Bitcoin.NetworkMode -> RowParser (NativePayment Satoshi)
bitcoinPaymentParser nmode = do
pvalue <- field
either
(const empty)
(pure . BitcoinPayment)
(parseEither (parseBitcoinPaymentJSON nmode) pvalue)
zcashPaymentParser :: RowParser (NativePayment Zatoshi)
zcashPaymentParser = do
pvalue <- field
either
(const empty)
(pure . ZcashPayment)
(parseEither parseZcashPaymentJSON pvalue)
createBillable :: EventId -> UserId -> Billable Amount -> DBM BillableId
createBillable eventId _ b = do
pinsert
BillableId
[sql| INSERT INTO billables
( project_id, event_id, name, description
, recurrence_type, recurrence_count
, billing_currency, billing_amount
, grace_period_days
, payment_request_email_template
, payment_request_memo_template)
VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) RETURNING id |]
( b ^. (project . _ProjectId),
eventId ^. _EventId,
b ^. name,
b ^. description,
b ^. (recurrence . to recurrenceName),
b ^. (recurrence . to recurrenceCount),
b ^. (amount . to currencyType),
b ^. (amount . to currencyValue),
b ^. (gracePeriod),
b ^. (paymentRequestEmailTemplate),
b ^. (paymentRequestMemoTemplate)
)
findBillable :: BillableId -> DBM (Maybe (Billable Amount))
findBillable bid =
headMay
<$> pquery
billableParser
[sql| SELECT b.project_id, e.created_by,
b.name, b.description, b.message,
b.recurrence_type, b.recurrence_count,
b.billing_currency, b.billing_amount,
b.grace_period_days, b.request_expiry_seconds,
b.payment_request_email_template, b.payment_request_memo_template
FROM billables b JOIN aftok_events e ON e.id = b.event_id
WHERE b.id = ? |]
(Only (bid ^. _BillableId))
findBillables :: ProjectId -> DBM [(BillableId, Billable Amount)]
findBillables pid =
pquery
((,) <$> idParser BillableId <*> billableParser)
[sql| SELECT b.id, b.project_id, e.created_by,
b.name, b.description, b.message,
b.recurrence_type, b.recurrence_count,
b.billing_currency, b.billing_amount,
b.grace_period_days, b.request_expiry_seconds,
b.payment_request_email_template, b.payment_request_memo_template
FROM billables b JOIN aftok_events e ON e.id = b.event_id
WHERE b.project_id = ? |]
(Only (pid ^. _ProjectId))
createSubscription :: EventId -> UserId -> BillableId -> C.Day -> DBM SubscriptionId
createSubscription eventId uid bid start_date =
pinsert
SubscriptionId
[sql| INSERT INTO subscriptions
(user_id, billable_id, event_id, start_date)
VALUES (?, ?, ?, ?) RETURNING id |]
( view _UserId uid,
view _BillableId bid,
view _EventId eventId,
C.fromThyme start_date
)
findSubscription :: SubscriptionId -> DBM (Maybe Subscription)
findSubscription sid =
headMay
<$> pquery
subscriptionParser
[sql| SELECT id, billable_id, contact_email, start_date, end_date
FROM subscriptions s
WHERE s.id = ? |]
(Only (sid ^. _SubscriptionId))
findSubscriptions :: ProjectId -> UserId -> DBM [(SubscriptionId, Subscription)]
findSubscriptions pid uid =
pquery
((,) <$> idParser SubscriptionId <*> subscriptionParser)
[sql| SELECT s.id, user_id, billable_id, contact_email, start_date, end_date
FROM subscriptions s
JOIN billables b ON b.id = s.billable_id
WHERE s.user_id = ?
AND b.project_id = ? |]
(uid ^. _UserId, pid ^. _ProjectId)
findSubscribers :: ProjectId -> DBM [UserId]
findSubscribers pid =
pquery
(idParser UserId)
[sql| SELECT s.user_id
FROM subscripions s
JOIN billables b ON s.billable_id = b.id
WHERE b.project_id = ? |]
(Only (pid ^. _ProjectId))
storePaymentRequest ::
EventId ->
Maybe SubscriptionId ->
PaymentRequest c ->
DBM PaymentRequestId
storePaymentRequest eid sid req =
pinsert
PaymentRequestId
[sql| INSERT INTO payment_requests
(subscription_id, event_id, request_json, url_key, request_time, billing_date)
VALUES (?, ?, ?, ?, ?, ?) RETURNING id |]
( (^. _SubscriptionId) <$> sid,
eid ^. _EventId,
req ^. nativeRequest . to nativeRequestJSON,
req ^? nativeRequest . to bip70Request . _Just . Bitcoin.paymentRequestKey . Bitcoin._PaymentKey,
req ^. createdAt . to C.fromThyme,
req ^. billingDate . to C.fromThyme
)
findPaymentRequestByKey :: Bitcoin.PaymentKey -> DBM (Maybe (PaymentRequestId, SomePaymentRequestDetail))
findPaymentRequestByKey (Bitcoin.PaymentKey k) =
headMay
<$> pquery
((,) <$> idParser PaymentRequestId <*> paymentRequestDetailParser)
[sql|
SELECT r.id,
b.project_id, e.created_by, b.name, b.description, b.recurrence_type,
b.recurrence_count, b.billing_currency, b.billing_amount, b.grace_period_days,
b.payment_request_email_template, b.payment_request_memo_template
r.request_time, r.billing_date, r.request_json,
FROM payment_requests r
JOIN billables b on b.id = s.billable_id
JOIN aftok_events e on e.id = b.event_id
WHERE r.url_key = ?
|]
(Only k)
findPaymentRequestById :: PaymentRequestId -> DBM (Maybe SomePaymentRequestDetail)
findPaymentRequestById (PaymentRequestId prid) =
headMay
<$> pquery
paymentRequestDetailParser
[sql|
SELECT
b.project_id, e.created_by, b.name, b.description, b.recurrence_type,
b.recurrence_count, b.billing_currency, b.billing_amount, b.grace_period_days,
b.payment_request_email_template, b.payment_request_memo_template
r.request_time, r.billing_date, r.request_json,
FROM payment_requests r
JOIN billables b on b.id = s.billable_id
JOIN aftok_events e on e.id = b.event_id
WHERE r.id = ?
|]
(Only prid)
findSubscriptionPaymentRequests :: SubscriptionId -> DBM [(PaymentRequestId, SomePaymentRequestDetail)]
findSubscriptionPaymentRequests sid =
pquery
((,) <$> idParser PaymentRequestId <*> paymentRequestDetailParser)
[sql|
SELECT r.id,
b.project_id, e.created_by, b.name, b.description, b.recurrence_type,
b.recurrence_count, b.billing_currency, b.billing_amount, b.grace_period_days,
b.payment_request_email_template, b.payment_request_memo_template
r.request_time, r.billing_date, r.request_json,
FROM payment_requests r
JOIN billables b on b.id = s.billable_id
JOIN aftok_events e on e.id = b.event_id
WHERE subscription_id = ?
|]
(Only (sid ^. _SubscriptionId))
findSubscriptionUnpaidRequests :: SubscriptionId -> DBM [(PaymentRequestId, SomePaymentRequestDetail)]
findSubscriptionUnpaidRequests sid =
pquery
((,) <$> idParser PaymentRequestId <*> paymentRequestDetailParser)
[sql| SELECT r.id,
b.project_id, e.created_by, b.name, b.description, b.recurrence_type,
b.recurrence_count, b.billing_currency, b.billing_amount, b.grace_period_days,
b.payment_request_email_template, b.payment_request_memo_template
r.request_time, r.billing_date, r.request_json,
FROM payment_requests r
JOIN subscriptions s on s.id = r.subscription_id
JOIN billables b on b.id = s.billable_id
JOIN aftok_events e on e.id = b.event_id
WHERE subscription_id = ?
AND r.id NOT IN (SELECT payment_request_id FROM payments)
|]
(Only (sid ^. _SubscriptionId))
createPayment :: EventId -> Payment c -> DBM PaymentId
createPayment eventId p = do
nmode <- asks fst
pinsert
PaymentId
[sql| INSERT INTO payments
(payment_request_id, event_id, payment_data, payment_date)
VALUES (?, ?, ?, ?) RETURNING id |]
( p ^. (paymentRequest . to getConst . _PaymentRequestId),
eventId ^. _EventId,
p ^. (to (paymentJSON nmode) . to encode),
p ^. (paymentDate . to C.fromThyme)
)
findPayments :: Currency a c -> PaymentRequestId -> DBM [(PaymentId, Payment c)]
findPayments ccy rid = do
nmode <- asks fst
pquery
((,) <$> idParser PaymentId <*> paymentParser nmode rid ccy)
[sql| SELECT id, payment_request_id, payment_date, payment_data
FROM payments
WHERE payment_request_id = ? |]
(Only (rid ^. _PaymentRequestId))
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
module Aftok.Database.PostgreSQL.Events
( storeEvent,
storeEvent',
createEvent,
findEvent,
findEvents,
amendEvent,
readWorkIndex,
)
where
import Aftok.Database
( DBError (EventStorageFailed),
DBOp
( CreateBillable,
CreatePayment,
CreateSubscription,
StorePaymentRequest
),
KeyedLogEntry,
)
import Aftok.Database.PostgreSQL.Json
( nativeRequestJSON,
paymentJSON,
)
import Aftok.Database.PostgreSQL.Types
( DBM,
creditToName,
creditToParser,
idParser,
pinsert,
pquery,
utcParser,
)
import Aftok.Interval
import Aftok.Json
( billableJSON,
createSubscriptionJSON,
)
import Aftok.Payments.Types
import Aftok.TimeLog
import Aftok.Types
import Control.Lens ((^.), _Just, preview)
import Control.Monad.Trans.Except (throwE)
import Data.Aeson
( Value,
)
import Data.Thyme.Clock as C
import Data.Thyme.Time
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.FromRow
import Database.PostgreSQL.Simple.SqlQQ
( sql,
)
import Safe (headMay)
import Prelude hiding (null)
eventTypeParser :: FieldParser (C.UTCTime -> LogEvent)
eventTypeParser f v = do
tn <- typename f
if tn /= "event_t"
then returnError Incompatible f "column was not of type event_t"
else
maybe
(returnError UnexpectedNull f "event type may not be null")
( maybe (returnError Incompatible f "unrecognized event type value") pure
. nameEvent
. decodeUtf8
)
v
logEntryParser :: RowParser LogEntry
logEntryParser =
LogEntry
<$> creditToParser
<*> (fieldWith eventTypeParser <*> utcParser)
<*> field
keyedLogEntryParser :: RowParser KeyedLogEntry
keyedLogEntryParser =
(,,) <$> idParser ProjectId <*> idParser UserId <*> logEntryParser
storeEvent :: DBOp a -> Maybe (DBM EventId)
storeEvent = \case
(CreateBillable uid b) ->
Just $ storeEventJSON (Just uid) "create_billable" (billableJSON b)
(CreateSubscription uid bid t) ->
Just $
storeEventJSON
(Just uid)
"create_subscription"
(createSubscriptionJSON uid bid t)
(StorePaymentRequest req) ->
Just $
storeEventJSON Nothing "create_payment_request" (nativeRequestJSON (req ^. nativeRequest))
(CreatePayment p) ->
Just $ do
nmode <- asks fst
storeEventJSON Nothing "create_payment" (paymentJSON nmode p)
_ -> Nothing
storeEvent' :: DBOp a -> DBM EventId
storeEvent' = maybe (lift $ throwE EventStorageFailed) id . storeEvent
type EventType = Text
storeEventJSON :: Maybe UserId -> EventType -> Value -> DBM EventId
storeEventJSON uid etype v = do
timestamp <- liftIO C.getCurrentTime
pinsert
EventId
[sql| INSERT INTO aftok_events
(event_time, created_by, event_type, event_json)
VALUES (?, ?, ?, ?) RETURNING id |]
(fromThyme timestamp, preview (_Just . _UserId) uid, etype, v)
createEvent :: ProjectId -> UserId -> LogEntry -> DBM EventId
createEvent (ProjectId pid) (UserId uid) (LogEntry c e m) = case c of
CreditToAccount aid' -> do
pinsert
EventId
[sql| INSERT INTO work_events
( project_id, user_id, credit_to_type, credit_to_account,
, event_type, event_time, event_metadata )
VALUES (?, ?, ?, ?, ?, ?, ?)
RETURNING id |]
( pid,
uid,
creditToName c,
aid' ^. _AccountId,
eventName e,
fromThyme $ e ^. eventTime,
m
)
CreditToProject pid' ->
pinsert
EventId
[sql| INSERT INTO work_events
( project_id, user_id, credit_to_type, credit_to_project_id
, event_type, event_time, event_metadata )
VALUES (?, ?, ?, ?, ?, ?, ?)
RETURNING id |]
( pid,
uid,
creditToName c,
pid' ^. _ProjectId,
eventName e,
fromThyme $ e ^. eventTime,
m
)
CreditToUser uid' ->
pinsert
EventId
[sql| INSERT INTO work_events
( project_id, user_id, credit_to_type, credit_to_user_id
, event_type, event_time, event_metadata)
VALUES (?, ?, ?, ?, ?, ?, ?)
RETURNING id |]
( pid,
uid,
creditToName c,
uid' ^. _UserId,
eventName e,
fromThyme $ e ^. eventTime,
m
)
findEvent :: EventId -> DBM (Maybe KeyedLogEntry)
findEvent (EventId eid) = do
headMay
<$> pquery
keyedLogEntryParser
[sql| SELECT project_id, user_id,
credit_to_type, credit_to_account, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata FROM work_events
WHERE id = ? |]
(Only eid)
findEvents :: ProjectId -> UserId -> RangeQuery -> Word32 -> DBM [LogEntry]
findEvents (ProjectId pid) (UserId uid) rquery limit = do
case rquery of
(Before e) ->
pquery
logEntryParser
[sql| SELECT credit_to_type,
credit_to_account, credit_to_user_id, credit_to_project_id,
event_type, event_time,
event_metadata
FROM work_events
WHERE project_id = ? AND user_id = ? AND event_time <= ?
ORDER BY event_time DESC
LIMIT ?
|]
(pid, uid, fromThyme e, limit)
(During s e) ->
pquery
logEntryParser
[sql| SELECT credit_to_type,
credit_to_account, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata
FROM work_events
WHERE project_id = ? AND user_id = ?
AND event_time >= ? AND event_time <= ?
ORDER BY event_time DESC
LIMIT ?
|]
(pid, uid, fromThyme s, fromThyme e, limit)
(After s) ->
pquery
logEntryParser
[sql| SELECT credit_to_type,
credit_to_account, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata
FROM work_events
WHERE project_id = ? AND user_id = ? AND event_time >= ?
ORDER BY event_time DESC
LIMIT ?
|]
(pid, uid, fromThyme s, limit)
(Always) ->
pquery
logEntryParser
[sql| SELECT credit_to_type,
credit_to_account, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata
FROM work_events
WHERE project_id = ? AND user_id = ?
ORDER BY event_time DESC
LIMIT ?
|]
(pid, uid, limit)
amendEvent :: EventId -> EventAmendment -> DBM AmendmentId
amendEvent (EventId eid) = \case
(TimeChange mt t) ->
pinsert
AmendmentId
[sql| INSERT INTO event_time_amendments
(event_id, amended_at, event_time)
VALUES (?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, fromThyme t)
(CreditToChange mt c@(CreditToAccount acctId)) ->
pinsert
AmendmentId
[sql| INSERT INTO event_credit_to_amendments
(event_id, amended_at, credit_to_type, credit_to_account)
VALUES (?, ?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, creditToName c, acctId ^. _AccountId)
(CreditToChange mt c@(CreditToProject pid)) ->
pinsert
AmendmentId
[sql| INSERT INTO event_credit_to_amendments
(event_id, amended_at, credit_to_type, credit_to_project_id)
VALUES (?, ?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. _ProjectId)
(CreditToChange mt c@(CreditToUser uid)) ->
pinsert
AmendmentId
[sql| INSERT INTO event_credit_to_amendments
(event_id, amended_at, credit_to_type, credit_to_user_id)
VALUES (?, ?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId)
(MetadataChange mt v) ->
pinsert
AmendmentId
[sql| INSERT INTO event_metadata_amendments
(event_id, amended_at, event_metadata)
VALUES (?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, v)
readWorkIndex :: ProjectId -> DBM WorkIndex
readWorkIndex (ProjectId pid) = do
logEntries <-
pquery
logEntryParser
[sql| SELECT credit_to_type,
credit_to_account, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata
FROM work_events
WHERE project_id = ? |]
(Only pid)
pure $ workIndex logEntries
{-# LANGUAGE TypeApplications #-}
module Aftok.Database.PostgreSQL.Json where
import Aftok.Currency.Bitcoin (NetworkMode, Satoshi (..), _Satoshi, getNetwork)
import qualified Aftok.Currency.Bitcoin.Payments as Bitcoin
import Aftok.Currency.Zcash (Zatoshi (..), _Zatoshi)
import qualified Aftok.Currency.Zcash.Payments as Zcash
import qualified Aftok.Currency.Zcash.Zip321 as Zip321
import Aftok.Json (idValue, obj, parseBtcAddr, v1)
import Aftok.Payments.Types
( NativePayment (..),
NativeRequest (..),
Payment,
_PaymentRequestId,
nativePayment,
paymentDate,
paymentRequest,
)
-- import qualified Bippy.Proto as BP
import Control.Lens ((^.), (^?), _Just, review, to, view)
import Data.Aeson
import Data.Aeson.Types (Parser)
import qualified Data.ByteString.Base64 as B64
import Data.ProtocolBuffers (Decode, Encode, decodeMessage, encodeMessage)
import Data.Serialize.Get (runGet)
import Data.Serialize.Put (runPut)
import Data.Text (unpack)
-- import Data.Thyme.Calendar (showGregorian)
import Haskoin.Address (addrToText)
protoBase64 :: Encode a => a -> Text
protoBase64 = B64.encodeBase64 . runPut . encodeMessage
fromBase64Proto :: Decode a => Text -> Either Text a
fromBase64Proto t = (first toText . runGet decodeMessage) <=< B64.decodeBase64 $ encodeUtf8 t
bip70PaymentRequestJSON :: Bitcoin.PaymentRequest -> Value
bip70PaymentRequestJSON r =
v1 . obj $
[ "bip70_request"
.= object
[ "payment_key" .= (r ^. Bitcoin.paymentRequestKey . Bitcoin._PaymentKey),
"payment_request_protobuf_64" .= (r ^. Bitcoin.bip70Request . to protoBase64)
]
]
parseBip70PaymentRequestJSON :: Value -> Parser Bitcoin.PaymentRequest
parseBip70PaymentRequestJSON = \case
Object wrapper -> do
o <- wrapper .: "bip70_request"
Bitcoin.PaymentRequest
<$> (Bitcoin.PaymentKey <$> o .: "paymentKey")
<*> ( either (fail . toString) pure . fromBase64Proto =<< (o .: "payment_request_protobuf_64")
)
nonobject ->
fail $ "Value " <> show nonobject <> " is not a JSON object."
zip321PaymentRequestJSON :: Zip321.PaymentRequest -> Value
zip321PaymentRequestJSON r =
v1 . obj $
["zip321_request" .= (toJSON . Zip321.toURI $ r)]
parseZip321PaymentRequestJSON :: Value -> Parser Zip321.PaymentRequest
parseZip321PaymentRequestJSON = \case
Object o ->
either fail pure . Zip321.parseURI =<< (o .: "zip321_request")
nonobject ->
fail $ "Value " <> show nonobject <> " is not a JSON object."
nativeRequestJSON :: NativeRequest c -> Value
nativeRequestJSON = \case
Bip70Request r -> bip70PaymentRequestJSON r
Zip321Request r -> zip321PaymentRequestJSON r
bitcoinPaymentJSON :: NetworkMode -> Bitcoin.Payment -> Value
bitcoinPaymentJSON nmode bp =
object
[ "amount" .= (bp ^? Bitcoin.amount . _Just . _Satoshi),
"txid" .= (bp ^. Bitcoin.txid),
"address" .= addrText,
"payment_key" .= (bp ^. Bitcoin.paymentKey . Bitcoin._PaymentKey),
"payment_protobuf_64" .= (bp ^. Bitcoin.bip70Payment . to protoBase64)
]
where
addrText = addrToText (getNetwork nmode) <$> (bp ^. Bitcoin.address)
parseBitcoinPaymentJSON :: NetworkMode -> Value -> Parser Bitcoin.Payment
parseBitcoinPaymentJSON nmode = \case
Object o ->
Bitcoin.Payment
<$> (fmap Satoshi <$> o .:? "amount")
<*> (o .:? "txid")
<*> (traverse (parseBtcAddr nmode) =<< o .:? "address")
<*> (Bitcoin.PaymentKey <$> o .: "paymentKey")
<*> ( either (fail . unpack) pure . fromBase64Proto =<< (o .: "payment_protobuf_64")
)
nonobject ->
fail $ "Value " <> show nonobject <> " is not a JSON object."
zcashPaymentJSON :: Zcash.Payment -> Value
zcashPaymentJSON zp =
v1 . obj $
[ "amount" .= (zp ^. Zcash.amount . _Zatoshi),
"txid" .= (zp ^. Zcash.txid . Zcash._TxId)
]
parseZcashPaymentJSON :: Value -> Parser Zcash.Payment
parseZcashPaymentJSON = \case
(Object o) ->
Zcash.Payment
<$> (Zatoshi <$> o .: "amount")
<*> (review Zcash._TxId <$> o .: "txid")
val ->
fail $ "Value " <> show val <> " is not a JSON object."
paymentJSON :: NetworkMode -> Payment c -> Value
paymentJSON nmode p =
v1 . obj $
[ "payment_request_id" .= idValue (paymentRequest . to getConst . _PaymentRequestId) p,
"payment_date" .= view paymentDate p,
"payment_value" .= nativePaymentValue
]
where
nativePaymentValue :: Value
nativePaymentValue = case view nativePayment p of
BitcoinPayment bp -> bitcoinPaymentJSON nmode bp
ZcashPayment bp -> zcashPaymentJSON bp
{-# LANGUAGE QuasiQuotes #-}
module Aftok.Database.PostgreSQL.Projects
( createProject,
listProjects,
findProject,
findUserProjects,
addUserToProject,
createInvitation,
findInvitation,
acceptInvitation,
)
where
import Aftok.Database
( InvitedUID,
InvitingUID,
)
import Aftok.Database.PostgreSQL.Types
( DBM,
SerDepFunction (..),
idParser,
pexec,
pinsert,
pquery,
ptransact,
utcParser,
)
import Aftok.Project
( Invitation (..),
InvitationCode (..),
Project (..),
depf,
inceptionDate,
initiator,
projectName,
randomInvCode,
renderInvCode,
)
import Aftok.Types
( Email (..),
ProjectId (..),
UserId (..),
_ProjectId,
_UserId,
)
import Control.Lens
import Data.Aeson (toJSON)
import qualified Data.Thyme.Time as C
import Database.PostgreSQL.Simple (Only (..))
import Database.PostgreSQL.Simple.FromField (fromJSONField)
import Database.PostgreSQL.Simple.FromRow (RowParser, field, fieldWith)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Safe (headMay)
import Prelude hiding (null)
projectParser :: RowParser Project
projectParser =
Project
<$> field
<*> utcParser
<*> idParser UserId
<*> (unSerDepFunction <$> fieldWith fromJSONField)
invitationParser :: RowParser Invitation
invitationParser =
Invitation
<$> idParser ProjectId
<*> idParser UserId
<*> fmap Email field
<*> utcParser
<*> fmap (fmap C.toThyme) field
createProject :: Project -> DBM ProjectId
createProject p =
pinsert
ProjectId
[sql| INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn)
VALUES (?, ?, ?, ?) RETURNING id |]
( p ^. projectName,
p ^. (inceptionDate . to C.fromThyme),
p ^. (initiator . _UserId),
toJSON $ p ^. depf . to SerDepFunction
)
listProjects :: DBM [ProjectId]
listProjects =
pquery (idParser ProjectId) [sql| SELECT id FROM projects |] ()
findProject :: ProjectId -> DBM (Maybe Project)
findProject (ProjectId pid) =
headMay
<$> pquery
projectParser
[sql| SELECT project_name, inception_date, initiator_id, depreciation_fn FROM projects WHERE id = ? |]
(Only pid)
findUserProjects :: UserId -> DBM [(ProjectId, Project)]
findUserProjects (UserId uid) =
pquery
((,) <$> idParser ProjectId <*> projectParser)
[sql| SELECT DISTINCT ON (p.inception_date, p.id)
p.id, p.project_name, p.inception_date, p.initiator_id, p.depreciation_fn
FROM projects p LEFT OUTER JOIN project_companions pc ON pc.project_id = p.id
WHERE pc.user_id = ?
OR p.initiator_id = ?
ORDER BY p.inception_date, p.id |]
(uid, uid)
addUserToProject :: ProjectId -> InvitingUID -> InvitedUID -> DBM ()
addUserToProject pid current new =
void $
pexec
[sql| INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?) |]
(pid ^. _ProjectId, new ^. _UserId, current ^. _UserId)
createInvitation :: ProjectId -> InvitingUID -> Email -> C.UTCTime -> DBM InvitationCode
createInvitation (ProjectId pid) (UserId uid) (Email e) t = do
invCode <- liftIO randomInvCode
void $
pexec
[sql| INSERT INTO invitations (project_id, invitor_id, invitee_email, invitation_key, invitation_time)
VALUES (?, ?, ?, ?, ?) |]
(pid, uid, e, renderInvCode invCode, C.fromThyme t)
pure invCode
findInvitation :: InvitationCode -> DBM (Maybe Invitation)
findInvitation ic =
headMay
<$> pquery
invitationParser
[sql| SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time
FROM invitations WHERE invitation_key = ? |]
(Only $ renderInvCode ic)
acceptInvitation :: UserId -> InvitationCode -> C.UTCTime -> DBM ()
acceptInvitation (UserId uid) ic t = ptransact $ do
void $
pexec
[sql| UPDATE invitations SET acceptance_time = ? WHERE invitation_key = ? |]
(C.fromThyme t, renderInvCode ic)
void $
pexec
[sql| INSERT INTO project_companions (project_id, user_id, invited_by, joined_at)
SELECT i.project_id, ?, i.invitor_id, ?
FROM invitations i
WHERE i.invitation_key = ? |]
(uid, C.fromThyme t, renderInvCode ic)
module Aftok.Database.PostgreSQL.Types where
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Aftok.Database.PostgreSQL.Types
( DBM,
SerDepFunction (..),
pexec,
pinsert,
pquery,
ptransact,
askNetworkMode,
idParser,
utcParser,
nullField,
nominalDiffTimeParser,
creditToParser,
creditToName,
bitcoinAddressParser,
zcashAddressParser,
zcashIvkParser,
currencyAmountParser,
btcAmountParser,
zecAmountParser,
currencyType,
currencyValue,
)
where
import Aftok.Currency (Amount (..), Currency (..))
import Aftok.Currency.Bitcoin (Satoshi (..), _Satoshi)
import qualified Aftok.Currency.Bitcoin as Bitcoin
import Aftok.Currency.Zcash (Zatoshi (..), _Zatoshi)
import qualified Aftok.Currency.Zcash as Zcash
import Aftok.Database (DBError)
)
import qualified Data.List as L
import qualified Data.Text as T
import Data.Thyme.Clock as C
import Data.Thyme.Time as C
import Data.UUID (UUID)
import Database.PostgreSQL.Simple
( Connection,
Query,
ResultError (Incompatible),
ToRow,
execute,
fromOnly,
query,
queryWith,
withTransaction,
)
import Database.PostgreSQL.Simple.FromField
( FieldParser,
ResultError (ConversionFailed),
fromField,
returnError,
typename,
type DBM a = ReaderT (Bitcoin.NetworkMode, Connection) (ExceptT DBError IO) a
pexec :: (ToRow d) => Query -> d -> DBM Int64
pexec q d = do
conn <- asks snd
lift . lift $ execute conn q d
pinsert :: (ToRow d) => (UUID -> r) -> Query -> d -> DBM r
pinsert f q d = do
conn <- asks snd
ids <- lift . lift $ query conn q d
pure . f . fromOnly $ L.head ids
pquery :: (ToRow d) => RowParser r -> Query -> d -> DBM [r]
pquery p q d = do
conn <- asks snd
lift . lift $ queryWith p conn q d
ptransact :: DBM a -> DBM a
ptransact rt = do
env <- ask
lift . ExceptT $ withTransaction (snd env) (runExceptT $ runReaderT rt env)
askNetworkMode :: DBM Bitcoin.NetworkMode
askNetworkMode = asks fst
idParser :: (UUID -> a) -> RowParser a
idParser f = f <$> field
utcParser :: RowParser C.UTCTime
utcParser = C.toThyme <$> field
nullField :: RowParser Null
nullField = field
nominalDiffTimeParser :: FieldParser NominalDiffTime
nominalDiffTimeParser f v = C.fromSeconds' <$> fromField f v
creditToName :: CreditTo -> Text
creditToName (CreditToAccount _) = "credit_to_account"
creditToName (CreditToUser _) = "credit_to_user"
creditToName (CreditToProject _) = "credit_to_project"
creditToParser :: RowParser CreditTo
creditToParser = join $ fieldWith creditToParser'
creditToParser' :: FieldParser (RowParser CreditTo)
creditToParser' f v = do
tn <- typename f
if tn /= "credit_to_t"
then returnError Incompatible f "column was not of type credit_to_t"
else maybe empty (pure . parser . decodeUtf8) v
where
parser :: Text -> RowParser CreditTo
parser = \case
"credit_to_account" ->
CreditToAccount <$> (idParser AccountId <* nullField <* nullField)
"credit_to_user" ->
CreditToUser <$> (nullField *> idParser UserId <* nullField)
"credit_to_project" ->
CreditToProject
<$> (nullField *> nullField *> idParser ProjectId)
_ -> empty
bitcoinAddressParser :: Bitcoin.NetworkMode -> RowParser Bitcoin.Address
bitcoinAddressParser nmode =
fieldWith $ addrFieldParser (Bitcoin.getNetwork nmode)
where
addrFieldParser :: Bitcoin.Network -> FieldParser Bitcoin.Address
addrFieldParser n f v = do
fieldValue <- fromField f v
let addrMay = Bitcoin.textToAddr n fieldValue
let err =
returnError
ConversionFailed
f
( "could not deserialize value "
<> T.unpack fieldValue
<> " to a valid BTC address for network "
<> show n
)
maybe err pure addrMay
btcAmountParser :: RowParser Satoshi
btcAmountParser = (Satoshi . fromInteger) <$> field
zecAmountParser :: RowParser Zatoshi
zecAmountParser = (Zatoshi . fromInteger) <$> field
currencyAmountParser :: RowParser Amount
currencyAmountParser = join $ fieldWith currencyAmountParser'
currencyAmountParser' :: FieldParser (RowParser Amount)
currencyAmountParser' f v = do
tn <- typename f
if tn /= "currency_t"
then returnError Incompatible f "column was not of type currency_t"
else maybe empty (pure . parser . decodeUtf8) v
where
parser :: Text -> RowParser Amount
parser = \case
"ZEC" -> Amount ZEC <$> zecAmountParser
"BTC" -> Amount BTC <$> btcAmountParser
_ -> empty
-- TODO: address validation here?
zcashAddressParser :: RowParser Zcash.Address
zcashAddressParser = Zcash.Address <$> field
-- TODO: ivk validation here?
zcashIvkParser :: RowParser Zcash.IVK
zcashIvkParser = Zcash.IVK <$> field
currencyType :: Amount -> Text
currencyType = \case
Amount BTC _ -> "BTC"
Amount ZEC _ -> "ZEC"
currencyValue :: Amount -> Word64
currencyValue = \case
Amount BTC sats -> sats ^. _Satoshi
Amount ZEC zats -> zats ^. _Zatoshi
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
module Aftok.Database.PostgreSQL.Users
( createUser,
findUser,
findUserByName,
findUserPaymentAddress,
findAccountPaymentAddress,
findAccountZcashIVK,
)
where
import Aftok.Currency (Currency (..))
import qualified Aftok.Currency.Zcash as Zcash
import Aftok.Database ()
import Aftok.Database.PostgreSQL.Types
( DBM,
askNetworkMode,
bitcoinAddressParser,
idParser,
pinsert,
pquery,
zcashAddressParser,
zcashIvkParser,
)
import Aftok.Types
import Control.Lens
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.FromRow
import Database.PostgreSQL.Simple.SqlQQ
( sql,
)
import Safe (headMay)
import Prelude hiding (null)
userParser :: RowParser User
userParser = do
uname <- UserName <$> field
remail <- fmap (RecoverByEmail . Email) <$> field
rzaddr <- fmap (RecoverByZAddr . Zcash.Address) <$> field
User uname <$> maybe empty pure (remail <|> rzaddr)
createUser :: User -> DBM UserId
createUser user' = do
pinsert
UserId
[sql| INSERT INTO users (handle, recovery_email, recovery_zaddr)
VALUES (?, ?, ?) RETURNING id |]
( user' ^. (username . _UserName),
user' ^? userAccountRecovery . _RecoverByEmail . _Email,
user' ^? userAccountRecovery . _RecoverByZAddr . Zcash._Address
)
findUser :: UserId -> DBM (Maybe User)
findUser (UserId uid) = do
headMay
<$> pquery
userParser
[sql| SELECT handle, recovery_email, recovery_zaddr FROM users WHERE id = ? |]
(Only uid)
findUserByName :: UserName -> DBM (Maybe (UserId, User))
findUserByName (UserName h) = do
headMay
<$> pquery
((,) <$> idParser UserId <*> userParser)
[sql| SELECT id, handle, recovery_email, recovery_zaddr FROM users WHERE handle = ? |]
(Only h)
findUserPaymentAddress :: UserId -> Currency a c -> DBM (Maybe a)
findUserPaymentAddress uid = \case
BTC -> do
mode <- askNetworkMode
headMay
<$> pquery
(bitcoinAddressParser mode)
[sql| SELECT btc_addr FROM cryptocurrency_accounts
WHERE user_id = ?
AND currency = 'BTC'
AND is_primary = true |]
(Only $ view _UserId uid)
ZEC -> do
headMay
<$> pquery
(zcashAddressParser)
[sql| SELECT zcash_addr FROM cryptocurrency_accounts
WHERE user_id = ?
AND currency = 'ZEC'
AND is_primary = true |]
(Only $ view _UserId uid)
findAccountPaymentAddress :: AccountId -> Currency a c -> DBM (Maybe a)
findAccountPaymentAddress aid = \case
BTC -> do
mode <- askNetworkMode
headMay
<$> pquery
(bitcoinAddressParser mode)
[sql| SELECT btc_addr FROM cryptocurrency_accounts
WHERE id = ?
AND btc_addr IS NOT NULL |]
(Only $ view _AccountId aid)
ZEC -> do
headMay
<$> pquery
(zcashAddressParser)
[sql| SELECT zcash_addr FROM cryptocurrency_accounts
WHERE id = ?
AND zcash_addr IS NOT NULL |]
(Only $ view _AccountId aid)
-- TODO: rework this for the case where someone wants to
-- use new diversified addresses for each purchase?
findAccountZcashIVK :: AccountId -> DBM (Maybe Zcash.IVK)
findAccountZcashIVK aid =
headMay
<$> pquery
(zcashIvkParser)
[sql| SELECT zcash_ivk FROM cryptocurrency_accounts
WHERE id = ?
AND zcash_ivk IS NOT NULL |]
(Only $ view _AccountId aid)
import Aftok.Database.PostgreSQL.Types
( SerDepFunction (..),
)
import Aftok.Interval
import Aftok.Json
( billableJSON,
createSubscriptionJSON,
paymentJSON,
paymentRequestJSON,
)
import Aftok.Payments.Types
import qualified Aftok.Project as P
import Aftok.TimeLog
import Aftok.Types
import Bippy.Types (Satoshi (..))
import Control.Lens
import qualified Aftok.Database.PostgreSQL.Auctions as Q
import qualified Aftok.Database.PostgreSQL.Billing as Q
import qualified Aftok.Database.PostgreSQL.Events as Q
import qualified Aftok.Database.PostgreSQL.Projects as Q
import qualified Aftok.Database.PostgreSQL.Users as Q
import Data.Aeson
( Value,
toJSON,
)
import Data.Hourglass
import qualified Data.List as L
import Data.ProtocolBuffers
( decodeMessage,
encodeMessage,
)
import Data.Serialize.Get (runGet)
import Data.Serialize.Put (runPut)
import qualified Data.Text as T
import Data.Thyme.Clock as C
import Data.Thyme.Time
import Data.UUID (UUID)
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.FromRow
import Database.PostgreSQL.Simple.SqlQQ
( sql,
)
import Database.PostgreSQL.Simple.Types
( Null,
)
import Haskoin.Address
( Address,
addrToText,
textToAddr,
)
import Haskoin.Constants (Network)
import Safe (headMay)
idParser :: (UUID -> a) -> RowParser a
idParser f = f <$> field
networkIdParser :: FieldParser NetworkId
networkIdParser f b = do
networkName <- fromField f b
case networkName of
Just "btc" -> pure BTC
Just "bch" -> pure BCH
Just other ->
returnError
ConversionFailed
f
("Network identifier " <> other <> " is not supported.")
Nothing -> pure BTC
btcAddressParser :: NetworkMode -> RowParser (NetworkId, Address)
btcAddressParser mode = do
networkId <- fieldWith (networkIdParser)
address <- fieldWith $ addrFieldParser (toNetwork mode networkId)
pure (networkId, address)
addrFieldParser :: Network -> FieldParser Address
addrFieldParser n f v = do
fieldValue <- fromField f v
let addrMay = textToAddr n fieldValue
let err =
returnError
ConversionFailed
f
( "could not deserialize value "
<> T.unpack fieldValue
<> " to a valid BTC address for network "
<> show n
)
maybe err pure addrMay
btcParser :: RowParser Satoshi
btcParser = (Satoshi . fromInteger) <$> field
utcParser :: RowParser C.UTCTime
utcParser = toThyme <$> field
nullField :: RowParser Null
nullField = field
eventTypeParser :: FieldParser (C.UTCTime -> LogEvent)
eventTypeParser f v = do
tn <- typename f
if tn /= "event_t"
then returnError Incompatible f "column was not of type event_t"
else
maybe
(returnError UnexpectedNull f "event type may not be null")
( maybe (returnError Incompatible f "unrecognized event type value") pure
. nameEvent
. decodeUtf8
)
v
nominalDiffTimeParser :: FieldParser NominalDiffTime
nominalDiffTimeParser f v = C.fromSeconds' <$> fromField f v
creditToParser :: NetworkMode -> RowParser (CreditTo (NetworkId, Address))
creditToParser mode = join $ fieldWith (creditToParser' mode)
creditToParser' ::
NetworkMode -> FieldParser (RowParser (CreditTo (NetworkId, Address)))
creditToParser' mode f v = do
tn <- typename f
if tn /= "credit_to_t"
then returnError Incompatible f "column was not of type credit_to_t"
else maybe empty (pure . parser . decodeUtf8) v
where
parser :: Text -> RowParser (CreditTo (NetworkId, Address))
parser = \case
"credit_to_address" ->
CreditToCurrency <$> (btcAddressParser mode <* nullField <* nullField)
"credit_to_user" ->
CreditToUser <$> (nullField *> nullField *> idParser UserId <* nullField)
"credit_to_project" ->
CreditToProject
<$> (nullField *> nullField *> nullField *> idParser ProjectId)
_ -> empty
logEntryParser :: NetworkMode -> RowParser (LogEntry (NetworkId, Address))
logEntryParser mode =
LogEntry
<$> creditToParser mode
<*> (fieldWith eventTypeParser <*> utcParser)
<*> field
qdbLogEntryParser ::
NetworkMode -> RowParser (KeyedLogEntry (NetworkId, Address))
qdbLogEntryParser mode =
(,,) <$> idParser ProjectId <*> idParser UserId <*> logEntryParser mode
auctionParser :: RowParser A.Auction
auctionParser =
A.Auction
<$> idParser ProjectId
<*> idParser UserId
<*> utcParser
<*> btcParser
<*> utcParser
<*> utcParser
bidParser :: RowParser A.Bid
bidParser =
A.Bid <$> idParser UserId <*> (Seconds <$> field) <*> btcParser <*> utcParser
userParser :: RowParser User
userParser =
User
<$> (UserName <$> field)
<*> ( (maybe empty pure =<< fmap (RecoverByEmail . Email) <$> field)
<|> (maybe empty pure =<< fmap (RecoverByZAddr . ZAddr) <$> field)
)
projectParser :: RowParser P.Project
projectParser =
P.Project
<$> field
<*> utcParser
<*> idParser UserId
<*> (unSerDepFunction <$> fieldWith fromJSONField)
invitationParser :: RowParser P.Invitation
invitationParser =
P.Invitation
<$> idParser ProjectId
<*> idParser UserId
<*> fmap Email field
<*> utcParser
<*> fmap (fmap toThyme) field
billableParser :: RowParser B.Billable
billableParser =
B.Billable
<$> idParser ProjectId
<*> idParser UserId
<*> field
<*> field
<*> recurrenceParser
<*> btcParser
<*> field
<*> fieldWith (optionalField nominalDiffTimeParser)
<*> field
<*> field
recurrenceParser :: RowParser B.Recurrence
recurrenceParser =
let prec :: Text -> RowParser B.Recurrence
prec = \case
"annually" -> nullField *> pure B.Annually
"monthly" -> B.Monthly <$> field
--"semimonthly" = nullField *> pure B.SemiMonthly
"weekly" -> B.Weekly <$> field
"onetime" -> nullField *> pure B.OneTime
_ -> empty
in field >>= prec
subscriptionParser :: RowParser B.Subscription
subscriptionParser =
B.Subscription
<$> idParser UserId
<*> idParser B.BillableId
<*> (B.EmailChannel . Email <$> field)
<*> (toThyme <$> field)
<*> ((fmap toThyme) <$> field)
paymentRequestParser :: RowParser PaymentRequest
paymentRequestParser =
PaymentRequest
<$> fmap B.SubscriptionId field
<*> ((either (const empty) pure . runGet decodeMessage) =<< field)
<*> fmap PaymentKey field
<*> fmap toThyme field
<*> fmap toThyme field
paymentParser :: RowParser Payment
paymentParser =
Payment
<$> (PaymentRequestId <$> field)
<*> (field >>= (either (const empty) pure . runGet decodeMessage))
<*> (toThyme <$> field)
<*> field
pexec :: (ToRow d) => Query -> d -> QDBM Int64
pexec q d = QDBM $ do
conn <- asks snd
lift . lift $ execute conn q d
pinsert :: (ToRow d) => (UUID -> r) -> Query -> d -> QDBM r
pinsert f q d = QDBM $ do
conn <- asks snd
ids <- lift . lift $ query conn q d
pure . f . fromOnly $ L.head ids
pquery :: (ToRow d) => RowParser r -> Query -> d -> QDBM [r]
pquery p q d = QDBM $ do
conn <- asks snd
lift . lift $ queryWith p conn q d
transactQDBM :: QDBM a -> QDBM a
transactQDBM (QDBM rt) = QDBM $ do
env <- ask
lift . ExceptT $ withTransaction (snd env) (runExceptT $ runReaderT rt env)
storeEvent :: DBOp a -> Maybe (QDBM EventId)
storeEvent (CreateBillable uid b) =
Just $ storeEventJSON (Just uid) "create_billable" (billableJSON b)
storeEvent (CreateSubscription uid bid t) =
Just $
storeEventJSON
(Just uid)
"create_subscription"
(createSubscriptionJSON uid bid t)
storeEvent (CreatePaymentRequest req) =
Just $
storeEventJSON Nothing "create_payment_request" (paymentRequestJSON req)
storeEvent (CreatePayment req) =
Just $ storeEventJSON Nothing "create_payment" (paymentJSON req)
storeEvent _ = Nothing
type EventType = Text
storeEventJSON :: Maybe UserId -> EventType -> Value -> QDBM EventId
storeEventJSON uid t v = do
timestamp <- liftIO C.getCurrentTime
pinsert
EventId
[sql| INSERT INTO aftok_events
(event_time, created_by, event_type, event_json)
VALUES (?, ?, ?, ?) RETURNING id |]
(fromThyme timestamp, preview (_Just . _UserId) uid, t, v)
askNetworkMode :: QDBM NetworkMode
askNetworkMode = QDBM $ asks fst
pgEval (CreateEvent (ProjectId pid) (UserId uid) (LogEntry c e m)) = case c of
CreditToCurrency (nid, addr) -> do
mode <- askNetworkMode
let network = toNetwork mode nid
pinsert
EventId
[sql| INSERT INTO work_events
( project_id, user_id, credit_to_type, credit_to_network, credit_to_address
, event_type, event_time, event_metadata )
VALUES (?, ?, ?, ?, ?, ?, ?)
RETURNING id |]
( pid,
uid,
creditToName c,
renderNetworkId nid,
addrToText network addr,
eventName e,
fromThyme $ e ^. eventTime,
m
)
CreditToProject pid' ->
pinsert
EventId
[sql| INSERT INTO work_events
( project_id, user_id, credit_to_type, credit_to_project_id
, event_type, event_time, event_metadata )
VALUES (?, ?, ?, ?, ?, ?, ?)
RETURNING id |]
( pid,
uid,
creditToName c,
pid' ^. _ProjectId,
eventName e,
fromThyme $ e ^. eventTime,
m
)
CreditToUser uid' ->
pinsert
EventId
[sql| INSERT INTO work_events
(project_id, user_id, credit_to_type, credit_to_user_id, event_type, event_time, event_metadata)
VALUES (?, ?, ?, ?, ?, ?, ?)
RETURNING id |]
( pid,
uid,
creditToName c,
uid' ^. _UserId,
eventName e,
fromThyme $ e ^. eventTime,
m
)
pgEval (FindEvent (EventId eid)) = do
mode <- askNetworkMode
headMay
<$> pquery
(qdbLogEntryParser mode)
[sql| SELECT project_id, user_id,
credit_to_type,
credit_to_network, credit_to_address, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata FROM work_events
WHERE id = ? |]
(Only eid)
pgEval (FindEvents (ProjectId pid) (UserId uid) rquery limit) = do
mode <- askNetworkMode
case rquery of
(Before e) ->
pquery
(logEntryParser mode)
[sql| SELECT credit_to_type,
credit_to_network, credit_to_address, credit_to_user_id, credit_to_project_id,
event_type, event_time,
event_metadata
FROM work_events
WHERE project_id = ? AND user_id = ? AND event_time <= ?
ORDER BY event_time DESC
LIMIT ?
|]
(pid, uid, fromThyme e, limit)
(During s e) ->
pquery
(logEntryParser mode)
[sql| SELECT credit_to_type,
credit_to_network, credit_to_address, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata
FROM work_events
WHERE project_id = ? AND user_id = ?
AND event_time >= ? AND event_time <= ?
ORDER BY event_time DESC
LIMIT ?
|]
(pid, uid, fromThyme s, fromThyme e, limit)
(After s) ->
pquery
(logEntryParser mode)
[sql| SELECT credit_to_type,
credit_to_network, credit_to_address, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata
FROM work_events
WHERE project_id = ? AND user_id = ? AND event_time >= ?
ORDER BY event_time DESC
LIMIT ?
|]
(pid, uid, fromThyme s, limit)
(Always) ->
pquery
(logEntryParser mode)
[sql| SELECT credit_to_type,
credit_to_network, credit_to_address, credit_to_user_id, credit_to_project_id,
event_type, event_time,
event_metadata
FROM work_events
WHERE project_id = ? AND user_id = ?
ORDER BY event_time DESC
LIMIT ?
|]
(pid, uid, limit)
pgEval (AmendEvent (EventId eid) (TimeChange mt t)) =
pinsert
AmendmentId
[sql| INSERT INTO event_time_amendments
(event_id, amended_at, event_time)
VALUES (?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, fromThyme t)
pgEval (AmendEvent (EventId eid) (CreditToChange mt c)) = do
mode <- askNetworkMode
case c of
CreditToCurrency (nid, addr) -> do
let network = toNetwork mode nid
pinsert
AmendmentId
[sql| INSERT INTO event_credit_to_amendments
(event_id, amended_at, credit_to_type, credit_to_network, credit_to_address)
VALUES (?, ?, ?, ?) RETURNING id |]
( eid,
fromThyme $ mt ^. _ModTime,
creditToName c,
renderNetworkId nid,
addrToText network addr
)
CreditToProject pid ->
pinsert
AmendmentId
[sql| INSERT INTO event_credit_to_amendments
(event_id, amended_at, credit_to_type, credit_to_project_id)
VALUES (?, ?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. _ProjectId)
CreditToUser uid ->
pinsert
AmendmentId
[sql| INSERT INTO event_credit_to_amendments
(event_id, amended_at, credit_to_type, credit_to_user_id)
VALUES (?, ?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId)
pgEval (AmendEvent (EventId eid) (MetadataChange mt v)) =
pinsert
AmendmentId
[sql| INSERT INTO event_metadata_amendments
(event_id, amended_at, event_metadata)
VALUES (?, ?, ?) RETURNING id |]
(eid, fromThyme $ mt ^. _ModTime, v)
pgEval (ReadWorkIndex (ProjectId pid)) = do
mode <- askNetworkMode
logEntries <-
pquery
(logEntryParser mode)
[sql| SELECT credit_to_type,
credit_to_network, credit_to_address, credit_to_user_id, credit_to_project_id,
event_type, event_time, event_metadata
FROM work_events
WHERE project_id = ? |]
(Only pid)
pure $ workIndex logEntries
pgEval (CreateAuction auc) =
pinsert
A.AuctionId
[sql| INSERT INTO auctions (project_id, initiator_id, raise_amount, end_time)
VALUES (?, ?, ?, ?) RETURNING id |]
( auc ^. (A.projectId . _ProjectId),
auc ^. (A.initiator . _UserId),
auc ^. (A.raiseAmount . satoshi),
auc ^. (A.auctionEnd . to fromThyme)
)
pgEval (FindAuction aucId) =
headMay
<$> pquery
auctionParser
[sql| SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time
FROM auctions
WHERE id = ? |]
(Only (aucId ^. A._AuctionId))
pgEval (CreateBid (A.AuctionId aucId) bid) =
pinsert
A.BidId
[sql| INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time)
VALUES (?, ?, ?, ?, ?) RETURNING id |]
( aucId,
bid ^. (A.bidUser . _UserId),
case bid ^. A.bidSeconds of
(Seconds i) -> i,
bid ^. (A.bidAmount . satoshi),
bid ^. (A.bidTime . to fromThyme)
)
pgEval (FindBids aucId) =
pquery
((,) <$> idParser A.BidId <*> bidParser)
[sql| SELECT id, bidder_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ? |]
(Only (aucId ^. A._AuctionId))
pgEval (CreateUser user') = do
pinsert
UserId
[sql| INSERT INTO users (handle, recovery_email, recovery_zaddr)
VALUES (?, ?, ?) RETURNING id |]
( user' ^. (username . _UserName),
user' ^? userAccountRecovery . _RecoverByEmail . _Email,
user' ^? userAccountRecovery . _RecoverByZAddr . _ZAddr
)
pgEval (FindUser (UserId uid)) = do
headMay
<$> pquery
userParser
[sql| SELECT handle, recovery_email, recovery_zaddr FROM users WHERE id = ? |]
(Only uid)
pgEval (FindUserByName (UserName h)) = do
headMay
<$> pquery
((,) <$> idParser UserId <*> userParser)
[sql| SELECT id, handle, recovery_email, recovery_zaddr FROM users WHERE handle = ? |]
(Only h)
pgEval (FindUserPaymentAddress (UserId uid)) = do
mode <- askNetworkMode
headMay
<$> pquery
(btcAddressParser mode)
[sql| SELECT default_payment_network, default_payment_addr FROM users WHERE id = ? |]
(Only uid)
pgEval (CreateInvitation (ProjectId pid) (UserId uid) (Email e) t) = do
invCode <- liftIO P.randomInvCode
void $
pexec
[sql| INSERT INTO invitations (project_id, invitor_id, invitee_email, invitation_key, invitation_time)
VALUES (?, ?, ?, ?, ?) |]
(pid, uid, e, P.renderInvCode invCode, fromThyme t)
pure invCode
pgEval (FindInvitation ic) =
headMay
<$> pquery
invitationParser
[sql| SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time
FROM invitations WHERE invitation_key = ? |]
(Only $ P.renderInvCode ic)
pgEval (AcceptInvitation (UserId uid) ic t) = transactQDBM $ do
void $
pexec
[sql| UPDATE invitations SET acceptance_time = ? WHERE invitation_key = ? |]
(fromThyme t, P.renderInvCode ic)
void $
pexec
[sql| INSERT INTO project_companions (project_id, user_id, invited_by, joined_at)
SELECT i.project_id, ?, i.invitor_id, ?
FROM invitations i
WHERE i.invitation_key = ? |]
(uid, fromThyme t, P.renderInvCode ic)
pgEval (CreateProject p) =
pinsert
ProjectId
[sql| INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn)
VALUES (?, ?, ?, ?) RETURNING id |]
( p ^. P.projectName,
p ^. (P.inceptionDate . to fromThyme),
p ^. (P.initiator . _UserId),
toJSON $ p ^. P.depf . to SerDepFunction
)
pgEval ListProjects =
pquery (idParser ProjectId) [sql| SELECT id FROM projects |] ()
pgEval (FindSubscribers pid) =
pquery
(idParser UserId)
[sql| SELECT s.user_id
FROM subscripions s
JOIN billables b ON s.billable_id = b.id
WHERE b.project_id = ? |]
(Only (pid ^. _ProjectId))
pgEval (FindProject (ProjectId pid)) =
headMay
<$> pquery
projectParser
[sql| SELECT project_name, inception_date, initiator_id, depreciation_fn FROM projects WHERE id = ? |]
(Only pid)
pgEval (FindUserProjects (UserId uid)) =
pquery
((,) <$> idParser ProjectId <*> projectParser)
[sql| SELECT DISTINCT ON (p.inception_date, p.id) p.id, p.project_name, p.inception_date, p.initiator_id, p.depreciation_fn
FROM projects p LEFT OUTER JOIN project_companions pc ON pc.project_id = p.id
WHERE pc.user_id = ?
OR p.initiator_id = ?
ORDER BY p.inception_date, p.id |]
(uid, uid)
pgEval (AddUserToProject pid current new) =
void $
pexec
[sql| INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?) |]
(pid ^. _ProjectId, new ^. _UserId, current ^. _UserId)
pgEval dbop@(CreateBillable _ b) = do
eventId <- requireEventId dbop
pinsert
B.BillableId
[sql| INSERT INTO billables
( project_id, event_id, name, description
, recurrence_type, recurrence_count
, billing_amount, grace_period_days
, payment_request_email_template
, payment_request_memo_template)
VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?) RETURNING id |]
( b ^. (B.project . _ProjectId),
eventId ^. _EventId,
b ^. B.name,
b ^. B.description,
b ^. (B.recurrence . to B.recurrenceName),
b ^. (B.recurrence . to B.recurrenceCount),
b ^. (B.amount . satoshi),
b ^. (B.gracePeriod),
b ^. (B.paymentRequestEmailTemplate),
b ^. (B.paymentRequestMemoTemplate)
)
pgEval (FindBillable bid) =
headMay
<$> pquery
billableParser
[sql| SELECT b.project_id, e.created_by, b.name, b.description,
b.recurrence_type, b.recurrence_count,
b.billing_amount, b.grace_period_days,
b.payment_request_email_template, b.payment_request_memo_template
FROM billables b JOIN aftok_events e ON e.id = b.event_id
WHERE b.id = ? |]
(Only (bid ^. B._BillableId))
pgEval (FindBillables pid) =
pquery
((,) <$> idParser B.BillableId <*> billableParser)
[sql| SELECT b.id, b.project_id, e.created_by, b.name, b.description,
b.recurrence_type, b.recurrence_count,
b.billing_amount, b.grace_period_days
b.payment_request_email_template, b.payment_request_memo_template
FROM billables b JOIN aftok_events e ON e.id = b.event_id
WHERE b.project_id = ? |]
(Only (pid ^. _ProjectId))
pgEval dbop@(CreateSubscription uid bid start_date) = do
eventId <- requireEventId dbop
pinsert
B.SubscriptionId
[sql| INSERT INTO subscriptions
(user_id, billable_id, event_id, start_date)
VALUES (?, ?, ?, ?) RETURNING id |]
( view _UserId uid,
view B._BillableId bid,
view _EventId eventId,
fromThyme start_date
)
pgEval (FindSubscription sid) =
headMay
<$> pquery
subscriptionParser
[sql| SELECT id, billable_id, contact_email, start_date, end_date
FROM subscriptions s
WHERE s.id = ? |]
(Only (sid ^. B._SubscriptionId))
pgEval (FindSubscriptions uid pid) =
pquery
((,) <$> idParser B.SubscriptionId <*> subscriptionParser)
[sql| SELECT s.id, user_id, billable_id, contact_email, start_date, end_date
FROM subscriptions s
JOIN billables b ON b.id = s.billable_id
WHERE s.user_id = ?
AND b.project_id = ? |]
(uid ^. _UserId, pid ^. _ProjectId)
pgEval dbop@(CreatePaymentRequest req) = do
eventId <- requireEventId dbop
pinsert
PaymentRequestId
[sql| INSERT INTO payment_requests
(subscription_id, event_id, request_data, url_key, request_time, billing_date)
VALUES (?, ?, ?, ?, ?, ?) RETURNING id |]
( req ^. (subscription . B._SubscriptionId),
eventId ^. _EventId,
req ^. (paymentRequest . to (runPut . encodeMessage)),
req ^. (paymentKey . _PaymentKey),
req ^. (paymentRequestTime . to fromThyme),
req ^. (billingDate . to fromThyme)
)
pgEval (FindPaymentRequest (PaymentKey k)) =
headMay
<$> pquery
((,) <$> idParser PaymentRequestId <*> paymentRequestParser)
[sql| SELECT id, subscription_id, request_data, url_key, request_time, billing_date
FROM payment_requests
WHERE url_key = ?
AND id NOT IN (SELECT payment_request_id FROM payments) |]
(Only k)
pgEval (FindPaymentRequestId (PaymentRequestId prid)) =
headMay
<$> pquery
paymentRequestParser
[sql| SELECT subscription_id, request_data, url_key, request_time, billing_date
FROM payment_requests
WHERE id = ? |]
(Only prid)
pgEval (FindPaymentRequests sid) =
pquery
((,) <$> idParser PaymentRequestId <*> paymentRequestParser)
[sql| SELECT id, subscription_id, request_data, url_key, request_time, billing_date
FROM payment_requests
WHERE subscription_id = ? |]
(Only (sid ^. B._SubscriptionId))
pgEval (FindUnpaidRequests sid) =
let rowp :: RowParser (PaymentKey, PaymentRequest, B.Subscription, B.Billable)
rowp =
(,,,)
<$> (PaymentKey <$> field)
<*> paymentRequestParser
<*> subscriptionParser
<*> billableParser
in pquery
rowp
[sql| SELECT r.url_key,
r.subscription_id, r.request_data, r.url_key, r.request_time, r.billing_date,
s.user_id, s.billable_id, s.contact_email, s.start_date, s.end_date,
b.project_id, e.created_by, b.name, b.description, b.recurrence_type,
b.recurrence_count, b.billing_amount, b.grace_period_days,
b.payment_request_email_template, b.payment_request_memo_template
FROM payment_requests r
JOIN subscriptions s on s.id = r.subscription_id
JOIN billables b on b.id = s.billable_id
JOIN aftok_events e on e.id = b.event_id
WHERE subscription_id = ?
AND r.id NOT IN (SELECT payment_request_id FROM payments) |]
(Only (sid ^. B._SubscriptionId))
pgEval dbop@(CreatePayment p) = do
eventId <- requireEventId dbop
pinsert
PaymentId
[sql| INSERT INTO payments
(payment_request_id, event_id, payment_data, payment_date, exchange_rates)
VALUES (?, ?, ?, ?, ?) RETURNING id |]
( p ^. (request . _PaymentRequestId),
eventId ^. _EventId,
p ^. (payment . to (runPut . encodeMessage)),
p ^. (paymentDate . to fromThyme),
p ^. exchangeRates
)
pgEval (FindPayments rid) =
pquery
((,) <$> idParser PaymentId <*> paymentParser)
[sql| SELECT id, payment_request_id, payment_data, payment_date
FROM payments
WHERE payment_request_id = ? |]
(Only (rid ^. _PaymentRequestId))
pgEval (RaiseDBError err _) = raiseError err
requireEventId :: DBOp a -> QDBM EventId
requireEventId = maybe (raiseError EventStorageFailed) id . storeEvent
raiseError :: DBError -> QDBM a
raiseError = QDBM . lift . throwE
pgEval =
QDBM . \case
(CreateEvent pid uid lentry) -> Q.createEvent pid uid lentry
(FindEvent eid) -> Q.findEvent eid
(FindEvents pid uid rquery limit) -> Q.findEvents pid uid rquery limit
(AmendEvent eid amendment) -> Q.amendEvent eid amendment
(ReadWorkIndex pid) -> Q.readWorkIndex pid
(CreateAuction auc) -> Q.createAuction auc
(FindAuction aucId) -> Q.findAuction aucId
(CreateBid aucId bid) -> Q.createBid aucId bid
(FindBids aucId) -> Q.findBids aucId
(CreateUser user') -> Q.createUser user'
(FindUser uid) -> Q.findUser uid
(FindUserByName n) -> Q.findUserByName n
(FindUserPaymentAddress uid currency) -> Q.findUserPaymentAddress uid currency
(FindAccountPaymentAddress aid currency) -> Q.findAccountPaymentAddress aid currency
(FindAccountZcashIVK aid) -> Q.findAccountZcashIVK aid
(CreateProject p) -> Q.createProject p
ListProjects -> Q.listProjects
(FindProject pid) -> Q.findProject pid
(FindUserProjects uid) -> Q.findUserProjects uid
(AddUserToProject pid current new) -> Q.addUserToProject pid current new
(CreateInvitation pid uid e t) -> Q.createInvitation pid uid e t
(FindInvitation ic) -> Q.findInvitation ic
(AcceptInvitation uid ic t) -> Q.acceptInvitation uid ic t
dbop@(CreateBillable uid b) -> do
eventId <- Q.storeEvent' dbop
Q.createBillable eventId uid b
(FindBillable bid) -> Q.findBillable bid
(FindBillables pid) -> Q.findBillables pid
dbop@(CreateSubscription uid bid start_date) -> do
eventId <- Q.storeEvent' dbop
Q.createSubscription eventId uid bid start_date
(FindSubscription sid) -> Q.findSubscription sid
(FindSubscriptions uid pid) -> Q.findSubscriptions uid pid
(FindSubscribers pid) -> Q.findSubscribers pid
dbop@(StorePaymentRequest req) -> do
eventId <- Q.storeEvent' dbop
Q.storePaymentRequest eventId Nothing req
(FindPaymentRequestByKey k) -> Q.findPaymentRequestByKey k
(FindPaymentRequestById prid) -> Q.findPaymentRequestById prid
(FindSubscriptionPaymentRequests sid) -> Q.findSubscriptionPaymentRequests sid
(FindSubscriptionUnpaidRequests sid) -> Q.findSubscriptionUnpaidRequests sid
dbop@(CreatePayment p) -> do
eventId <- Q.storeEvent' dbop
Q.createPayment eventId p
(FindPayments ccy rid) -> Q.findPayments ccy rid
(RaiseDBError err _) -> lift . throwE $ err
FindUserPaymentAddress :: UserId -> DBOp (Maybe (BTCNet))
FindUserPaymentAddress :: UserId -> Currency a c -> DBOp (Maybe a)
FindAccountPaymentAddress :: AccountId -> Currency a c -> DBOp (Maybe a)
FindAccountZcashIVK :: AccountId -> DBOp (Maybe Zcash.IVK)
CreateEvent :: ProjectId -> UserId -> LogEntry BTCNet -> DBOp EventId
AmendEvent :: EventId -> EventAmendment BTCNet -> DBOp AmendmentId
FindEvent :: EventId -> DBOp (Maybe (KeyedLogEntry BTCNet))
FindEvents :: ProjectId -> UserId -> RangeQuery -> Word32 -> DBOp [LogEntry BTCNet]
ReadWorkIndex :: ProjectId -> DBOp (WorkIndex BTCNet)
CreateAuction :: Auction -> DBOp AuctionId
FindAuction :: AuctionId -> DBOp (Maybe Auction)
CreateBid :: AuctionId -> Bid -> DBOp BidId
FindBids :: AuctionId -> DBOp [(BidId, Bid)]
CreateBillable :: UserId -> Billable -> DBOp BillableId
FindBillable :: BillableId -> DBOp (Maybe Billable)
FindBillables :: ProjectId -> DBOp [(BillableId, Billable)]
CreateEvent :: ProjectId -> UserId -> LogEntry -> DBOp EventId
AmendEvent :: EventId -> EventAmendment -> DBOp AmendmentId
FindEvent :: EventId -> DBOp (Maybe KeyedLogEntry)
FindEvents :: ProjectId -> UserId -> RangeQuery -> Word32 -> DBOp [LogEntry]
ReadWorkIndex :: ProjectId -> DBOp WorkIndex
CreateAuction :: A.Auction -> DBOp A.AuctionId
FindAuction :: A.AuctionId -> DBOp (Maybe A.Auction)
CreateBid :: A.AuctionId -> A.Bid -> DBOp A.BidId
FindBids :: A.AuctionId -> DBOp [(A.BidId, A.Bid)]
CreateBillable :: UserId -> Billable Amount -> DBOp BillableId
FindBillable :: BillableId -> DBOp (Maybe (Billable Amount))
FindBillables :: ProjectId -> DBOp [(BillableId, Billable Amount)]
FindSubscriptions :: UserId -> ProjectId -> DBOp [(SubscriptionId, Subscription)]
CreatePaymentRequest :: PaymentRequest -> DBOp PaymentRequestId
FindPaymentRequests :: SubscriptionId -> DBOp [(PaymentRequestId, PaymentRequest)]
FindUnpaidRequests :: SubscriptionId -> DBOp [BillDetail]
FindPaymentRequest :: PaymentKey -> DBOp (Maybe (PaymentRequestId, PaymentRequest))
FindPaymentRequestId :: PaymentRequestId -> DBOp (Maybe PaymentRequest)
CreatePayment :: Payment -> DBOp PaymentId
FindPayments :: PaymentRequestId -> DBOp [(PaymentId, Payment)]
FindSubscriptions :: ProjectId -> UserId -> DBOp [(SubscriptionId, Subscription)]
FindSubscribers :: ProjectId -> DBOp [UserId]
StorePaymentRequest :: PaymentRequest c -> DBOp PaymentRequestId
FindPaymentRequestByKey :: PaymentKey -> DBOp (Maybe (PaymentRequestId, SomePaymentRequestDetail))
FindPaymentRequestById :: PaymentRequestId -> DBOp (Maybe SomePaymentRequestDetail)
FindSubscriptionPaymentRequests :: SubscriptionId -> DBOp [(PaymentRequestId, SomePaymentRequestDetail)]
FindSubscriptionUnpaidRequests :: SubscriptionId -> DBOp [(PaymentRequestId, SomePaymentRequestDetail)]
CreatePayment :: Payment c -> DBOp PaymentId
FindPayments :: Currency a c -> PaymentRequestId -> DBOp [(PaymentId, Payment c)]
findUserPaymentAddress :: (MonadDB m) => UserId -> MaybeT m (BTCNet)
findUserPaymentAddress = MaybeT . liftdb . FindUserPaymentAddress
findUserPaymentAddress :: (MonadDB m) => UserId -> Currency a c -> MaybeT m a
findUserPaymentAddress uid n = MaybeT . liftdb $ FindUserPaymentAddress uid n
findAccountPaymentAddress :: (MonadDB m) => AccountId -> Currency a c -> MaybeT m a
findAccountPaymentAddress uid n = MaybeT . liftdb $ FindAccountPaymentAddress uid n
(MonadDB m) => UserId -> ProjectId -> m [(SubscriptionId, Subscription)]
findSubscriptions uid pid = liftdb $ FindSubscriptions uid pid
(MonadDB m) => ProjectId -> UserId -> m [(SubscriptionId, Subscription)]
findSubscriptions pid uid = liftdb $ FindSubscriptions pid uid
findPaymentRequests ::
(MonadDB m) => SubscriptionId -> m [(PaymentRequestId, PaymentRequest)]
findPaymentRequests = liftdb . FindPaymentRequests
storePaymentRequest ::
(MonadDB m) => PaymentRequest c -> m PaymentRequestId
storePaymentRequest = liftdb . StorePaymentRequest
findPaymentRequestByKey ::
(MonadDB m) => PaymentKey -> MaybeT m (PaymentRequestId, SomePaymentRequestDetail)
findPaymentRequestByKey = MaybeT . liftdb . FindPaymentRequestByKey
findPaymentRequest ::
(MonadDB m) => PaymentKey -> MaybeT m (PaymentRequestId, PaymentRequest)
findPaymentRequest = MaybeT . liftdb . FindPaymentRequest
findPaymentRequestById ::
(MonadDB m) => PaymentRequestId -> MaybeT m SomePaymentRequestDetail
findPaymentRequestById = MaybeT . liftdb . FindPaymentRequestById
findPaymentRequestId ::
(MonadDB m) => PaymentRequestId -> MaybeT m PaymentRequest
findPaymentRequestId = MaybeT . liftdb . FindPaymentRequestId
findSubscriptionPaymentRequests ::
(MonadDB m) => SubscriptionId -> m [(PaymentRequestId, SomePaymentRequestDetail)]
findSubscriptionPaymentRequests = liftdb . FindSubscriptionPaymentRequests
findUnpaidRequests :: (MonadDB m) => SubscriptionId -> m [BillDetail]
findUnpaidRequests = liftdb . FindUnpaidRequests
findSubscriptionUnpaidRequests :: (MonadDB m) => SubscriptionId -> m [(PaymentRequestId, SomePaymentRequestDetail)]
findSubscriptionUnpaidRequests = liftdb . FindSubscriptionUnpaidRequests
findPayment :: (MonadDB m) => PaymentRequestId -> MaybeT m Payment
findPayment prid = MaybeT $ (fmap snd . headMay) <$> liftdb (FindPayments prid)
findPayment :: (MonadDB m) => Currency a c -> PaymentRequestId -> MaybeT m (Payment c)
findPayment currency prid = MaybeT $ (fmap snd . headMay) <$> liftdb (FindPayments currency prid)
creditToJSON :: NetworkMode -> CreditTo (NetworkId, Address) -> Value
creditToJSON nmode (CreditToCurrency (netId, addr)) =
v2 $
obj
[ "creditToAddress" .= addrToJSON (toNetwork nmode netId) addr,
"creditToNetwork" .= renderNetworkId netId
]
creditToJSON _ (CreditToUser uid) =
creditToJSON :: CreditTo -> Value
creditToJSON (CreditToAccount accountId) =
v2 $ obj ["creditToAccount" .= idValue _AccountId accountId]
creditToJSON (CreditToUser uid) =
parseCreditTo :: NetworkMode -> Value -> Parser (CreditTo (NetworkId, Address))
parseCreditTo nmode = unversion "CreditTo" $ \case
(Version 1 0) -> parseCreditToV1 nmode
(Version 2 0) -> parseCreditToV2 nmode
parseCreditTo :: Value -> Parser CreditTo
parseCreditTo = unversion "CreditTo" $ \case
(Version 2 0) -> parseCreditToV2
( fail
. T.unpack
$ "Address "
<> addrText
<> " cannot be parsed as a BTC network address."
)
(pure . CreditToCurrency . (net,))
(textToAddr (toNetwork nmode net) addrText)
(fail . T.unpack $ "Address " <> addrText <> " cannot be parsed as a BTC network address.")
pure
(textToAddr (getNetwork nmode) addrText)
parseCreditToV1 ::
NetworkMode -> Object -> Parser (CreditTo (NetworkId, Address))
parseCreditToV1 nmode x = do
parseBtcAddr nmode BTC =<< x .: "btcAddr"
parseCreditToV2 ::
NetworkMode -> Object -> Parser (CreditTo (NetworkId, Address))
parseCreditToV2 nmode o =
let parseCreditToAddr = do
netName <- o .: "creditToNetwork"
net <-
fromMaybeM
(fail . T.unpack $ "Currency network " <> netName <> " not recognized.")
(parseNetworkId netName)
addrValue <- o .: "creditToAddress"
CreditToCurrency
. (net,)
<$> addrFromJSON (toNetwork nmode net) addrValue
parseCreditToV2 :: Object -> Parser CreditTo
parseCreditToV2 o =
let parseCreditToAcct = do
fmap CreditToAccount . parseId _AccountId =<< o .: "creditToAccount"
logEntryFields :: NetworkMode -> LogEntry (NetworkId, Address) -> [Pair]
logEntryFields nmode (LogEntry c ev m) =
[ "creditTo" .= creditToJSON nmode c,
logEntryFields :: LogEntry -> [Pair]
logEntryFields (LogEntry c ev m) =
[ "creditTo" .= creditToJSON c,
paymentRequestJSON :: PaymentRequest -> Value
paymentRequestJSON = v1 . obj . paymentRequestKV
paymentRequestKV :: (KeyValue kv) => PaymentRequest -> [kv]
paymentRequestKV r =
[ "subscription_id" .= idValue (subscription . B._SubscriptionId) r,
"payment_request_protobuf_64" .= view prBytes r,
"url_key" .= view (paymentKey . _PaymentKey) r,
"payment_request_time" .= view paymentRequestTime r,
"billing_date" .= view (billingDate . to showGregorian) r
]
where
prBytes =
paymentRequest . to (T.decodeUtf8 . B64.encode . runPut . encodeMessage)
billDetailsJSON :: [BillDetail] -> Value
billDetailsJSON r = v1 $ obj ["payment_requests" .= fmap billDetailJSON r]
billDetailJSON :: BillDetail -> Object
billDetailJSON r =
obj $
concat
[ ["payment_request_id" .= view (_1 . _PaymentKey) r],
paymentRequestKV $ view _2 r,
subscriptionKV $ view _3 r,
billableKV $ view _4 r
]
-- paymentRequestDetailsJSON :: [PaymentRequestDetail Amount] -> Value
-- paymentRequestDetailsJSON r = v1 $ obj ["payment_requests" .= fmap paymentRequestDetailJSON r]
--
-- paymentRequestDetailJSON :: PaymentRequestDetail Amount -> Object
-- paymentRequestDetailJSON r = obj $ concat
-- [ ["payment_request_id" .= view () r]
-- , paymentRequestKV $ view _2 r
-- , subscriptionKV $ view _3 r
-- , billableKV $ view _4 r
-- ]
paymentJSON :: Payment -> Value
paymentJSON r =
v1 $
obj
[ "payment_request_id" .= idValue (request . _PaymentRequestId) r,
"payment_protobuf_64" .= view paymentBytes r,
"payment_date" .= (r ^. paymentDate)
]
where
paymentBytes =
payment . to (T.decodeUtf8 . B64.encode . runPut . encodeMessage)
parseEventAmendmentV1 ::
NetworkMode ->
ModTime ->
Object ->
Parser (EventAmendment (NetworkId, Address))
parseEventAmendmentV1 nmode t o =
let parseA :: Text -> Parser (EventAmendment (NetworkId, Address))
parseA "timeChange" = TimeChange t <$> o .: "eventTime"
parseA "addrChange" = CreditToChange t <$> parseCreditToV1 nmode o
parseA "metadataChange" = MetadataChange t <$> o .: "eventMeta"
parseA tid =
fail . T.unpack $ "Amendment type " <> tid <> " not recognized."
in o .: "amendment" >>= parseA
Parser (EventAmendment (NetworkId, Address))
parseEventAmendmentV2 nmode t o =
let parseA :: Text -> Parser (EventAmendment (NetworkId, Address))
Parser EventAmendment
parseEventAmendmentV2 t o =
let parseA :: Text -> Parser EventAmendment
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Aftok.Payments.Bitcoin where
import Aftok.Billing
( Billable,
amount,
project,
requestExpiryPeriod,
)
import Aftok.Currency (Currency (BTC))
import Aftok.Currency.Bitcoin
( NetworkMode,
_Satoshi,
getNetwork,
)
import Aftok.Currency.Bitcoin.Payments (PaymentKey (..), PaymentRequest (..))
import Aftok.Database (MonadDB)
import Aftok.Payments.Types
( NativeRequest (Bip70Request),
PaymentOps (..),
PaymentRequestError,
)
import Aftok.Payments.Util (MinPayout (..), getPayouts, getProjectPayoutFractions)
import qualified Bippy as B
import qualified Bippy.Proto as P
import Bippy.Types
( Expiry (Expiry),
Output (Output),
PKIData,
Satoshi (Satoshi),
expiryTime,
getExpires,
getPaymentDetails,
)
import Control.Lens
( (^.),
makeLenses,
)
import Control.Monad.Except (throwError)
import Control.Monad.Trans.Except (except, withExceptT)
import qualified Crypto.PubKey.RSA.Types as RSA
( Error (..),
PrivateKey,
)
import Crypto.Random.Types
( MonadRandom,
getRandomBytes,
)
import Data.AffineSpace ((.+^))
import Data.Map.Strict (assocs)
import qualified Data.Text as T
import Data.Thyme.Clock as C
import Data.Thyme.Time as C
import Haskoin.Address (Address (..), encodeBase58Check)
import Haskoin.Script (ScriptOutput (..))
import Network.URI (URI)
data BillingOps (m :: * -> *)
= BillingOps
{ -- | generator for user memo
memoGen ::
Billable Satoshi -> -- template for the bill
C.Day -> -- billing date
C.UTCTime -> -- payment request generation time
m (Maybe Text),
-- | generator for payment response URL
uriGen ::
PaymentKey -> -- payment key to be included in the URL
m (Maybe URI),
-- | generator for merchant payload
payloadGen ::
Billable Satoshi -> -- template for the bill
C.Day -> -- billing date
C.UTCTime -> -- payment request generation time
m (Maybe ByteString)
}
data PaymentsConfig
= PaymentsConfig
{ _networkMode :: !NetworkMode,
_signingKey :: !RSA.PrivateKey,
_pkiData :: !PKIData,
_minPayment :: !Satoshi
}
makeLenses ''PaymentsConfig
data PaymentError
= RequestError !PaymentRequestError
| SigningError !RSA.Error
| IllegalAddress !Address
{- Check whether the specified payment request has expired (whether wallet software
- will still consider the payment request valid)
-}
isExpired :: C.UTCTime -> P.PaymentRequest -> Bool
isExpired now req =
let check = any ((now >) . C.toThyme . expiryTime)
in -- using error here is reasonable since it would indicate
-- a serialization problem
either (error . T.pack) (check . getExpires) $
getPaymentDetails req
paymentOps ::
( MonadRandom m,
MonadDB m
) =>
BillingOps m ->
PaymentsConfig ->
PaymentOps Satoshi (ExceptT PaymentError m)
paymentOps ops cfg =
PaymentOps
{ newPaymentRequest = (((fmap Bip70Request) .) .) . bip70PaymentRequest ops cfg
}
bip70PaymentRequest ::
( MonadRandom m,
MonadDB m
) =>
BillingOps m ->
PaymentsConfig ->
-- | bill denominated in satoshi
Billable Satoshi ->
-- | billing base date
C.Day ->
-- | time at which the bill is being issued
UTCTime ->
ExceptT PaymentError m PaymentRequest
bip70PaymentRequest ops cfg billable billingDay billingTime = do
let billTotal = billable ^. amount
payoutTime = C.mkUTCTime billingDay (fromInteger 0)
payoutFractions <- lift $ getProjectPayoutFractions payoutTime (billable ^. project)
payouts <- withExceptT RequestError $ getPayouts payoutTime BTC (MinPayout $ cfg ^. minPayment) billTotal payoutFractions
outputs <- except $ traverse toOutput (assocs payouts)
pkey <- PaymentKey . encodeBase58Check <$> lift (getRandomBytes 32)
memo <- lift $ memoGen ops billable billingDay billingTime
uri <- lift $ uriGen ops pkey
payload <- lift $ payloadGen ops billable billingDay billingTime
let expiry = Expiry . C.fromThyme $ billingTime .+^ (billable ^. requestExpiryPeriod)
let details =
B.createPaymentDetails
(getNetwork (cfg ^. networkMode))
outputs
(C.fromThyme billingTime)
(Just expiry)
memo
uri
payload
resp <- lift $ B.createPaymentRequest (cfg ^. signingKey) (cfg ^. pkiData) details
either (throwError . SigningError) (pure . PaymentRequest pkey) resp
toOutput :: (Address, Satoshi) -> Either PaymentError Output
toOutput (addr, amt) = case addr of
(PubKeyAddress a) -> Right (Output amt (PayPKHash a))
other -> Left $ IllegalAddress other
outputAmount :: Satoshi -> Rational -> Satoshi
outputAmount i r = Satoshi . round $ toRational (i ^. _Satoshi) * r
import qualified Bippy.Proto as P
import Bippy.Types
( Satoshi (..),
expiryTime,
getExpires,
getPaymentDetails,
)
import Aftok.Currency (Currency (..), Currency' (..))
import Aftok.Currency.Bitcoin (Satoshi)
import qualified Aftok.Currency.Bitcoin.Payments as B
import Aftok.Currency.Zcash (Zatoshi)
import qualified Aftok.Currency.Zcash.Payments as Z
import qualified Aftok.Currency.Zcash.Zip321 as Z
import Aftok.Types (ProjectId, UserId)
-- A unique identifier for the payment request, suitable
-- for URL embedding.
newtype PaymentKey = PaymentKey Text deriving (Eq)
data NativeRequest currency where
Bip70Request :: B.PaymentRequest -> NativeRequest Satoshi
Zip321Request :: Z.PaymentRequest -> NativeRequest Zatoshi
bip70Request :: NativeRequest currency -> Maybe B.PaymentRequest
bip70Request = \case
Bip70Request r -> Just r
_ -> Nothing
zip321Request :: NativeRequest currency -> Maybe Z.PaymentRequest
zip321Request = \case
Zip321Request r -> Just r
_ -> Nothing
data NativePayment currency where
BitcoinPayment :: B.Payment -> NativePayment Satoshi
ZcashPayment :: Z.Payment -> NativePayment Zatoshi
makePrisms ''PaymentKey
data PaymentOps currency m
= PaymentOps
{ newPaymentRequest ::
Billable currency -> -- billing information
C.Day -> -- payout date (billing date)
C.UTCTime -> -- timestamp of payment request creation
m (NativeRequest currency)
}
{ _subscription :: s,
_paymentRequest :: P.PaymentRequest,
_paymentKey :: PaymentKey,
_paymentRequestTime :: C.UTCTime,
_billingDate :: C.Day
{ _billable :: billable currency,
_createdAt :: C.UTCTime,
_billingDate :: C.Day,
_nativeRequest :: NativeRequest currency
data Payment' r
data SomePaymentRequest (b :: * -> *) = forall c. SomePaymentRequest (PaymentRequest' b c)
type SomePaymentRequestDetail = SomePaymentRequest (Billable' ProjectId UserId)
paymentRequestCurrency :: PaymentRequest' b c -> Currency' c
paymentRequestCurrency pr = case _nativeRequest pr of
Bip70Request _ -> Currency' BTC
Zip321Request _ -> Currency' ZEC
isExpired :: forall c. UTCTime -> PaymentRequestDetail c -> Bool
isExpired now req =
let expiresAt = (req ^. createdAt) .+^ (req ^. (billable . requestExpiryPeriod))
in now >= expiresAt
data Payment' (paymentRequest :: * -> *) currency
{- Check whether the specified payment request has expired (whether wallet software
- will still consider the payment request valid)
-}
isExpired :: forall s. C.UTCTime -> PaymentRequest' s -> Bool
isExpired now req =
let check = any ((now >) . C.toThyme . expiryTime)
in -- using error here is reasonable since it would indicate
-- a serialization problem
either (error . T.pack) (check . getExpires) $
getPaymentDetails (view paymentRequest req)
parsePaymentKey :: ByteString -> Maybe PaymentKey
parsePaymentKey bs =
(PaymentKey . decodeUtf8) <$> decodeBase58Check (decodeUtf8 bs)
paymentRequestTotal :: P.PaymentRequest -> Satoshi
paymentRequestTotal _ = error "Not yet implemented"
type PaymentDetail currency = Payment' (PaymentRequest' (Billable' ProjectId UserId)) currency
{-# LANGUAGE TupleSections #-}
module Aftok.Payments.Util where
import Aftok.Currency (Currency, scaleCurrency)
import Aftok.Database
( DBOp
( FindProject,
ReadWorkIndex
),
MonadDB,
findAccountPaymentAddress,
findUserPaymentAddress,
liftdb,
raiseSubjectNotFound,
)
import Aftok.Payments.Types (PaymentRequestError (..))
import Aftok.Project (depf)
import qualified Aftok.TimeLog as TL
import Aftok.Types (ProjectId)
import Control.Error.Util (note)
import Control.Lens ((^.))
import Control.Monad.Trans.Except (except)
import Data.Map.Strict (assocs, fromListWith)
import Data.Thyme.Clock as C
getProjectPayoutFractions ::
(MonadDB m) =>
C.UTCTime ->
ProjectId ->
m TL.FractionalPayouts
getProjectPayoutFractions ptime pid = do
project' <-
let projectOp = FindProject pid
in maybe (raiseSubjectNotFound projectOp) pure =<< liftdb projectOp
widx <- liftdb $ ReadWorkIndex pid
pure $ TL.payouts (TL.toDepF $ project' ^. depf) ptime widx
newtype MinPayout c = MinPayout c
getPayouts ::
(MonadDB m, Ord a, Semigroup c, Ord c) =>
-- | time used in computation of payouts when `creditTo` is another project
C.UTCTime ->
-- | the currency with which the payment will be made
Currency a c ->
-- | the minimum payout amount, below which values are disregarded (avoids dust)
MinPayout c ->
-- | the amount to pay in total
c ->
-- | the fractions of the total payout to pay to each recipient
TL.FractionalPayouts ->
ExceptT PaymentRequestError m (Map a c)
getPayouts t currency mp@(MinPayout minAmt) amt payouts =
if amt <= minAmt
then pure mempty
else do
-- Multiply the total by each payout fraction. This may fail, so traverse.
let scaled frac = note AmountInvalid $ scaleCurrency currency amt frac
payoutFractions <- except $ traverse scaled (payouts ^. TL._Payouts)
fromListWith (<>) . join <$> traverse (uncurry (getPayoutAmounts t currency mp)) (assocs payoutFractions)
getPayoutAmounts ::
(MonadDB m, Ord a, Semigroup c, Ord c) =>
-- | time used in computation of payouts when `creditTo` is another project
C.UTCTime ->
-- | the network on which the payment will be made
Currency a c ->
-- | the minimum payout amount, below which amounts will be disregarded (avoids dust)
MinPayout c ->
-- | the recipient of the payment
TL.CreditTo ->
-- | the amount to pay to the recipient
c ->
ExceptT PaymentRequestError m [(a, c)]
getPayoutAmounts t network mp creditTo amt = case creditTo of
(TL.CreditToAccount aid) ->
fmap (,amt) . maybeToList <$> (lift . runMaybeT $ findAccountPaymentAddress aid network)
(TL.CreditToUser uid) ->
fmap (,amt) . maybeToList <$> (lift . runMaybeT $ findUserPaymentAddress uid network)
(TL.CreditToProject pid) -> do
payouts <- lift $ getProjectPayoutFractions t pid
assocs <$> getPayouts t network mp amt payouts
{-# LANGUAGE TemplateHaskell #-}
module Aftok.Payments.Zcash where
import Aftok.Billing
( Billable,
amount,
messageText,
project,
)
import Aftok.Currency (Currency (ZEC))
import Aftok.Currency.Zcash (Address, Zatoshi)
import Aftok.Currency.Zcash.Zip321 (PaymentItem (..), PaymentRequest (..))
import Aftok.Database (MonadDB)
import qualified Aftok.Payments.Types as PT
import Aftok.Payments.Util (MinPayout (..), getPayouts, getProjectPayoutFractions)
import Control.Error.Safe (tryJust)
import Control.Lens ((^.), makeLenses)
import Data.Map.Strict (assocs)
import Data.Thyme.Clock as C
import Data.Thyme.Time as C
data PaymentsConfig
= PaymentsConfig
{ _minAmt :: Zatoshi
}
makeLenses ''PaymentsConfig
paymentOps ::
(MonadDB m) =>
PaymentsConfig ->
PT.PaymentOps Zatoshi (ExceptT PT.PaymentRequestError m)
paymentOps cfg =
PT.PaymentOps
{ PT.newPaymentRequest = ((fmap PT.Zip321Request .) .) . zip321PaymentRequest cfg
}
zip321PaymentRequest ::
(MonadDB m) =>
PaymentsConfig ->
-- | billing information
Billable Zatoshi ->
-- | payout date (billing date)
C.Day ->
-- | timestamp for payment request creation
C.UTCTime ->
ExceptT PT.PaymentRequestError m PaymentRequest
zip321PaymentRequest cfg billable billingDay _ = do
let payoutTime = C.mkUTCTime billingDay (fromInteger 0)
billTotal = billable ^. amount
payoutFractions <- lift $ getProjectPayoutFractions payoutTime (billable ^. project)
payouts <- getPayouts payoutTime ZEC (MinPayout $ cfg ^. minAmt) billTotal payoutFractions
PaymentRequest <$> (tryJust PT.NoRecipients $ nonEmpty (toPaymentItem <$> assocs payouts))
where
toPaymentItem :: (Address, Zatoshi) -> PaymentItem
toPaymentItem (a, z) =
PaymentItem
{ _address = a,
_label = Nothing,
_message = billable ^. messageText,
_amount = z,
_memo = Nothing, -- Just . Memo $ toASCIIBytes (reqid ^. PT._PaymentRequestId),
_other = []
}
( DBOp
( FindBillable,
FindSubscription
),
MonadDB,
OpForbiddenReason (UserNotSubscriber),
findBillable,
findPayment,
findSubscriptionPaymentRequests,
findSubscriptionUnpaidRequests,
liftdb,
raiseOpForbidden,
raiseSubjectNotFound,
storePaymentRequest,
)
import qualified Aftok.Payments.Bitcoin as BTC
import Aftok.Project (depf)
import qualified Aftok.TimeLog as TL
( NativeRequest (..),
Payment,
PaymentOps (..),
PaymentRequest,
PaymentRequest' (..),
PaymentRequestDetail,
PaymentRequestId,
SomePaymentRequest (..),
SomePaymentRequestDetail,
billingDate,
isExpired,
paymentRequestCurrency,
)
import qualified Aftok.Payments.Types as PT
import qualified Aftok.Payments.Zcash as Zcash
data BillingOps (m :: * -> *)
= BillingOps
{ -- | generator for user memo
memoGen ::
Subscription' UserId Billable -> -- subscription being billed
T.Day -> -- billing date
C.UTCTime -> -- payment request generation time
m (Maybe Text),
-- | generator for payment response URL
uriGen ::
PaymentKey -> -- payment key to be included in the URL
m (Maybe URI),
-- | generator for merchant payload
payloadGen ::
Subscription' UserId Billable -> -- subscription being billed
T.Day -> -- billing date
C.UTCTime -> -- payment request generation time
m (Maybe ByteString)
}
data PaymentRequestStatus
data PaymentRequestStatus c
= Overdue !SubscriptionId
| SigningError !RSA.Error
| IllegalAddress !Address
= RequestError PT.PaymentRequestError
| Overdue !PaymentRequestId
| BTCPaymentError !BTC.PaymentError
| BillableIdMismatch !BillableId !BillableId
{--
- Find all the subscriptions for the specified customer, and
- determine which if any are up for renewal. Create a payment
- request for each such subscription.
--}
createPaymentRequests ::
( MonadRandom m,
MonadReader r m,
HasPaymentsConfig r,
MonadError e m,
AsPaymentError e,
MonadDB m
) =>
-- | generators for payment request components
BillingOps m ->
-- | timestamp for payment request creation
C.UTCTime ->
-- | customer responsible for payment
UserId ->
-- | project whose worklog is to be paid
ProjectId ->
m [PaymentRequestId]
createPaymentRequests ops now custId pid = do
subscriptions <- findSubscriptions custId pid
join <$> traverse (createSubscriptionPaymentRequests ops now) subscriptions
m [PaymentRequestId]
createSubscriptionPaymentRequests ops now (sid, sub) = do
billableSub <-
maybeT (raiseSubjectNotFound . FindBillable $ sub ^. billable) pure $
traverseOf billable findBillable sub
paymentRequests <- findPaymentRequests sid
ExceptT PaymentError m [(PaymentRequestId, SomePaymentRequestDetail)]
createSubscriptionPaymentRequests cfg now (sid, sub) = do
-- fill in the billable for the subscription
sub' <-
lift . maybeT (raiseSubjectNotFound . FindBillable $ billableId) pure $
traverseOf B.billable findBillable sub
-- get previous payment requests & augment with billable information
paymentRequests <- lift $ findSubscriptionPaymentRequests sid
-- find dates for which no bill has yet been issued
findUnbilledDates now (view billable billableSub) paymentRequests
$ takeWhile (< view _utctDay now)
$ billingSchedule billableSub
traverse (createPaymentRequest ops now sid billableSub) billableDates
findUnbilledDates now paymentRequests
. takeWhile (< now ^. _utctDay)
$ B.billingSchedule sub'
traverse (createPaymentRequest' sub') billableDates
where
billableId = sub ^. B.billable
-- create a payment request for the specified unbilled date
createPaymentRequest' ::
Subscription' UserId (Billable Amount) ->
T.Day ->
ExceptT PaymentError m (PaymentRequestId, SomePaymentRequestDetail)
createPaymentRequest' sub' day =
let bill = sub' ^. B.billable
in case bill ^. amount of
Amount BTC sats -> withExceptT BTCPaymentError $ do
let ops = BTC.paymentOps (cfg ^. bitcoinBillingOps) (cfg ^. bitcoinPaymentsConfig)
bill' = bill & amount .~ sats
second SomePaymentRequest <$> createPaymentRequest ops now billableId bill' day
Amount ZEC zats -> withExceptT RequestError $ do
let ops = Zcash.paymentOps (cfg ^. zcashPaymentsConfig)
bill' = bill & amount .~ zats
second SomePaymentRequest <$> createPaymentRequest ops now billableId bill' day
m PaymentRequestId
createPaymentRequest ops now sid sub bday = do
cfg <- ask
-- TODO: maybe make pkey a function of subscription, billable, bday
pkey <- PaymentKey . encodeBase58Check <$> getRandomBytes 32
memo <- memoGen ops sub bday now
uri <- uriGen ops pkey
payload <- payloadGen ops sub bday now
details <- createPaymentDetails bday now memo uri payload (sub ^. billable)
reqErr <- B.createPaymentRequest (cfg ^. signingKey) (cfg ^. pkiData) details
req <- either (throwError . review _SigningError) pure reqErr
liftdb $ CreatePaymentRequest (PaymentRequest sid req pkey now bday)
m (PaymentRequestId, PaymentRequestDetail currency)
createPaymentRequest ops now billId bill bday = do
nativeReq <- newPaymentRequest ops bill bday now
let req =
PaymentRequest
{ _billable = (Const billId),
_createdAt = now,
_billingDate = bday,
_nativeRequest = nativeReq
}
reqId <- storePaymentRequest req
pure (reqId, req & PT.billable .~ bill)
m [T.Day]
findUnbilledDates now b (px@(p : ps)) (dx@(d : ds)) =
case compare (view (_2 . billingDate) p) d of
EQ ->
getRequestStatus now p >>= \s -> case s of
Expired r ->
if view _utctDay now > addDays (view gracePeriod b) (view billingDate r)
then throwError (review _Overdue (r ^. subscription))
else fmap (d :) $ findUnbilledDates now b px dx -- d will be rebilled
_ -> findUnbilledDates now b ps ds -- if paid or unpaid, nothing to do
GT -> fmap (d :) $ findUnbilledDates now b px ds
LT -> findUnbilledDates now b ps dx
findUnbilledDates _ _ _ ds = pure ds
ExceptT PaymentError m [T.Day]
findUnbilledDates now (px@((reqId, SomePaymentRequest req) : ps)) (dx@(d : ds)) =
let rec = findUnbilledDates now
gracePeriod = req ^. PT.billable . B.gracePeriod
in case compare (req ^. billingDate) d of
EQ ->
lift (getRequestStatus now reqId req) >>= \case
Expired r ->
if (now ^. _utctDay) > addDays gracePeriod (r ^. billingDate)
then throwError (review _Overdue reqId)
else fmap (d :) $ rec px dx -- d will be rebilled
_ ->
rec ps ds -- if paid or unpaid, nothing to do, keep looking
GT ->
fmap (d :) $ rec px ds
LT ->
rec ps dx
findUnbilledDates _ _ ds = pure ds
(PaymentRequestId, PaymentRequest) ->
m PaymentRequestStatus
getRequestStatus now (reqid, req) =
let ifUnpaid = (if isExpired now req then Expired else Unpaid) req
in maybe ifUnpaid Paid <$> runMaybeT (findPayment reqid)
PaymentRequestDetail c ->
m (PaymentRequestStatus c)
getRequestStatus now reqid req =
let ifUnpaid = if isExpired now req then Expired req else Unpaid req
findPayment' = case paymentRequestCurrency req of
(Currency' BTC) -> findPayment BTC reqid
(Currency' ZEC) -> findPayment ZEC reqid
in maybe ifUnpaid Paid <$> runMaybeT findPayment'
{- Create the PaymentDetails section of the payment request.
-}
createPaymentDetails ::
( MonadRandom m,
MonadReader r m,
HasPaymentsConfig r,
MonadError e m,
AsPaymentError e,
MonadDB m
) =>
-- | payout date (billing date)
T.Day ->
-- | timestamp of payment request creation
C.UTCTime ->
-- | user memo
Maybe Text ->
-- | payment response URL
Maybe URI ->
-- | merchant payload
Maybe ByteString ->
-- | billing information
Billable ->
m P.PaymentDetails
createPaymentDetails payoutDate billingTime memo uri payload b = do
payouts <- getProjectPayouts payoutTime (b ^. project)
outputs <- createPayoutsOutputs payoutTime (b ^. amount) payouts
let expiry =
(BT.Expiry . T.fromThyme . (billingTime .+^))
<$> (b ^. requestExpiryPeriod)
cfg <- ask
pure $
B.createPaymentDetails
(toNetwork (cfg ^. networkMode) BTC)
outputs
(T.fromThyme billingTime)
expiry
memo
uri
payload
where
payoutTime = T.mkUTCTime payoutDate (fromInteger 0)
getProjectPayouts ::
(MonadDB m, MonadError e m, AsPaymentError e) =>
C.UTCTime ->
ProjectId ->
m (TL.Payouts (NetworkId, Address))
getProjectPayouts ptime pid = do
project' <-
let projectOp = FindProject pid
in maybe (raiseSubjectNotFound projectOp) pure =<< liftdb projectOp
widx <- liftdb $ ReadWorkIndex pid
pure $ TL.payouts (TL.toDepF $ project' ^. depf) ptime widx
createPayoutsOutputs ::
(MonadDB m, MonadError e m, AsPaymentError e) =>
C.UTCTime ->
BT.Satoshi ->
TL.Payouts (NetworkId, Address) ->
m [BT.Output]
createPayoutsOutputs t amt p =
let payoutFractions :: [(TL.CreditTo (NetworkId, Address), BT.Satoshi)]
payoutFractions = (_2 %~ outputAmount amt) <$> assocs (p ^. TL._Payouts)
in join <$> traverse (uncurry (createOutputs t)) payoutFractions
createOutputs ::
(MonadDB m, MonadError e m, AsPaymentError e) =>
C.UTCTime ->
TL.CreditTo (NetworkId, Address) ->
BT.Satoshi ->
m [BT.Output]
createOutputs _ (TL.CreditToCurrency (BTC, (PubKeyAddress addr))) amt =
pure $ [BT.Output amt (PayPKHash addr)]
createOutputs _ (TL.CreditToCurrency (_, other)) _ =
throwError $ review _IllegalAddress other
createOutputs _ (TL.CreditToUser uid) amt = (fmap maybeToList) . runMaybeT $ do
(_, addr) <- findUserPaymentAddress uid
case addr of
PubKeyAddress a -> pure $ BT.Output amt (PayPKHash a)
other -> throwError $ review _IllegalAddress other
createOutputs t (TL.CreditToProject pid) amt = do
payouts <- getProjectPayouts t pid
createPayoutsOutputs t amt payouts
outputAmount :: BT.Satoshi -> Rational -> BT.Satoshi
outputAmount i r = BT.Satoshi . round $ toRational (i ^. satoshi) * r
(MonadDB m) => UserId -> SubscriptionId -> C.UTCTime -> m [BillDetail]
findPayableRequests uid sid now = do
requests <- liftdb findOp
join
<$> (traverse checkAccess $ filter (not . isExpired now . view _2) requests)
where
findOp = FindUnpaidRequests sid
checkAccess d =
if view (_3 . customer) d == uid
then pure [d]
else raiseOpForbidden uid (UserNotSubscriber sid) findOp
(MonadDB m) => UserId -> SubscriptionId -> m [(PaymentRequestId, PT.SomePaymentRequestDetail)]
findPayableRequests uid sid = do
subMay <- liftdb (FindSubscription sid)
when (maybe True (\s -> s ^. B.customer /= uid) subMay) $
void (raiseOpForbidden uid (UserNotSubscriber sid) (FindSubscription sid))
findSubscriptionUnpaidRequests sid
-- - work allocated to each address.
payouts :: Ord a => DepF -> C.UTCTime -> WorkIndex a -> Payouts a
-- - work allocated to each unique CreditTo.
payouts :: DepF -> C.UTCTime -> WorkIndex -> FractionalPayouts
data CreditTo a
-- Identifier for a cryptocurrency account. An account
-- is a mapping from cryptocurrency network to address;
-- this abstraction permits users to accept payment
-- in multiple currencies, or to direct payments in a
-- fashion that can change over time.
newtype AccountId = AccountId UUID deriving (Show, Eq, Ord)
makePrisms ''AccountId
data CreditTo
creditToName :: CreditTo a -> Text
creditToName (CreditToCurrency _) = "credit_via_net"
creditToName (CreditToUser _) = "credit_to_user"
creditToName (CreditToProject _) = "credit_to_project"
Description: (Describe migration here.)
Created: 2020-11-25 04:24:09.873312342 UTC
Depends: 2020-06-06_03-53-54_add-payment-networks 2017-09-24_22-06-01_billing-templates 2017-06-08_04-37-31_event-metadata-ids 2016-12-31_03-45-17_create-payments 2016-10-14_02-49-36_event-amendments 2016-10-14_02-14-09_create_invitations 2016-10-14_02-11-24_project_companions_invitations 2016-10-13_05-36-55_user-event-log
Apply: |
CREATE TYPE currency_t AS ENUM ('ZEC', 'BTC');
ALTER TABLE work_events ALTER COLUMN credit_to_type DROP DEFAULT;
ALTER TABLE work_events ALTER COLUMN credit_to_type TYPE VARCHAR(255);
ALTER TABLE event_credit_to_amendments ALTER COLUMN credit_to_type TYPE VARCHAR(255);
UPDATE work_events SET credit_to_type = 'credit_to_account' WHERE credit_to_type = 'credit_to_address';
UPDATE event_credit_to_amendments SET credit_to_type = 'credit_to_account' WHERE credit_to_type = 'credit_to_address';
DROP TYPE IF EXISTS credit_to_t;
CREATE TYPE credit_to_t AS ENUM ('credit_to_account', 'credit_to_user', 'credit_to_project');
ALTER TABLE work_events ALTER COLUMN credit_to_type TYPE credit_to_t USING (credit_to_type::credit_to_t);
ALTER TABLE event_credit_to_amendments ALTER COLUMN credit_to_type TYPE credit_to_t USING (credit_to_type::credit_to_t);
CREATE TABLE IF NOT EXISTS cryptocurrency_accounts (
id uuid primary key default uuid_generate_v4(),
user_id uuid references users(id) not null,
currency currency_t not null,
is_primary bool,
zcash_ivk text,
zcash_addr text,
btc_addr text,
UNIQUE (user_id, currency, is_primary),
CHECK ((currency = 'BTC' AND btc_addr IS NOT NULL) OR (currency = 'ZEC' AND zcash_ivk IS NOT NULL))
);
INSERT INTO cryptocurrency_accounts
(user_id, currency, btc_addr, is_primary)
SELECT DISTINCT id, 'BTC'::currency_t, default_payment_addr, true FROM users
WHERE default_payment_addr IS NOT NULL;
INSERT INTO cryptocurrency_accounts
(user_id, currency, btc_addr)
SELECT DISTINCT user_id, 'BTC'::currency_t, credit_to_address FROM work_events
WHERE credit_to_address IS NOT NULL;
ALTER TABLE work_events ADD COLUMN credit_to_account uuid REFERENCES cryptocurrency_accounts(id);
UPDATE work_events
SET credit_to_account = ca.id, credit_to_type = 'credit_to_account'
FROM cryptocurrency_accounts ca
WHERE ca.user_id = work_events.user_id
AND credit_to_address = ca.btc_addr;
ALTER TABLE work_events DROP COLUMN credit_to_address;
ALTER TABLE event_credit_to_amendments ADD COLUMN credit_to_account uuid REFERENCES cryptocurrency_accounts(id);
UPDATE event_credit_to_amendments
SET credit_to_account = ca.id, credit_to_type = 'credit_to_account'
FROM cryptocurrency_accounts ca
JOIN work_events w
ON ca.user_id = w.user_id
WHERE w.id = event_credit_to_amendments.event_id
AND event_credit_to_amendments.credit_to_address = ca.btc_addr;
ALTER TABLE event_credit_to_amendments DROP COLUMN credit_to_address;
ALTER TABLE billables ADD COLUMN billing_currency currency_t NOT NULL;
ALTER TABLE billables ADD COLUMN message text;
ALTER TABLE billables ADD COLUMN request_expiry_seconds integer NOT NULL DEFAULT 259200;
ALTER TABLE billables ALTER COLUMN billing_amount TYPE bigint;
ALTER TABLE payment_requests ALTER COLUMN subscription_id DROP NOT NULL;
ALTER TABLE payment_requests ALTER COLUMN url_key DROP NOT NULL;
ALTER TABLE payment_requests ADD COLUMN request_json json NOT NULL;
ALTER TABLE payment_requests DROP COLUMN request_data;
ALTER TABLE payments ADD COLUMN payment_json json NOT NULL;
ALTER TABLE payments DROP COLUMN payment_data;
#!/bin/bash
if [ -f ".env" ]; then
source .env
fi
if [ -z "${AFTOK_HOST}" ]; then
AFTOK_HOST="aftok.com"
fi
read -p "Zcash Address: " ZADDR
curl --verbose \
${ALLOW_INSECURE} \
"https://$AFTOK_HOST/api/validate_zaddr?zaddr=${ZADDR}"
#!/bin/bash
if [ -f ".env" ]; then
source .env
fi
if [ -z "${AFTOK_HOST}" ]; then
AFTOK_HOST="aftok.com"
fi
if [ -z "${USER}" ]; then
read -p "Username: " USER
echo
fi
if [ -z "${PID}" ]; then
read -p "Project UUID: " PID
echo
fi
read -p "Billable Name: " BNAME
read -p "Description: " BDESC
while [ -z "${RECUR}" ]
do
read -p "Recurrence Period [A|M|W|O] ((A)nnual, (M)onthly, (W)eekly, (O)ne-time): " RECUR
case $RECUR in
"A")
RECUR="annually"
read -p "Recur every ? years: " RECUR_COUNT
;;
"M")
RECUR="monthly"
read -p "Recur every ? months: " RECUR_COUNT
;;
"W")
RECUR="weekly"
read -p "Recur every ? weeks: " RECUR_COUNT
;;
"O")
RECUR="one-time"
;;
*)
echo "$RECUR is not a supported recurrence. Please choose \"A\" \"M\", \"W\" or \"O\""
RECUR=""
;;
esac
done
while [ -z "${CURRENCY}" ]
do
read -p "Currency [BTC|ZEC]: " CURRENCY
case $CURRENCY in
"BTC")
read -p "Bill Total (in Satoshis): " AMOUNT
break
;;
"ZEC")
read -p "Bill Total (in Zatoshis): " AMOUNT
break
;;
*)
echo "$CURRENCY is not a supported currency. Please choose \"BTC\" or \"ZEC\""
CURRENCY=""
;;
esac
done
read -p "Grace Period (days): " GRACE_PERIOD
read -p "Request Expiry Period (seconds): " REQUEST_EXPIRY
BODY=$(cat <<END_BODY
{
"schemaVersion": "1.0",
"name": "$BNAME",
"description": "$BDESC",
"message": "Thank you for your patronage.",
"recurrence": { "$RECUR": $RECUR_COUNT },
"currency": "$CURRENCY",
"amount": $AMOUNT,
"gracePeriod": $GRACE_PERIOD,
"requestExpiryPeriod": $REQUEST_EXPIRY
}
END_BODY
)
curl --verbose \
${ALLOW_INSECURE} \
--user $USER \
--header "Content-Type: application/json" \
--data "$BODY" \
"https://$AFTOK_HOST/api/projects/${PID}/billables"
curl --verbose --insecure \
--request POST --header 'Content-Type: application/json' \
--data "{\"username\":\"$USER\", \"password\":\"$PASS\", \"email\":\"$EMAIL\", \"btcAddr\":\"$BTC_ADDR\"}" \
curl --verbose \
${ALLOW_INSECURE} \
--header 'Content-Type: application/json' \
--data "{\"username\":\"$USER\", \"password\":\"$PASS\", \"recoveryType\": \"email\", \"recoveryEmail\": \"$EMAIL\", \"captchaToken\":\"FAKE\"}" \
#!/bin/bash
if [ -f ".env" ]; then
source .env
fi
if [ -z "${AFTOK_HOST}" ]; then
AFTOK_HOST="aftok.com"
fi
if [ -z "${USER}" ]; then
read -p "Username: " USER
echo
fi
if [ -z "${PID}" ]; then
read -p "Project UUID: " PID
echo
fi
curl --verbose \
${ALLOW_INSECURE} \
--user $USER \
"https://$AFTOK_HOST/api/projects/$PID/payouts"
curl --verbose --insecure --user $USER \
--request GET \
"https://$AFTOK_HOST/api/projects/$PID/logEntries?after=${after}"
curl --verbose \
${ALLOW_INSECURE} \
--user $USER \
"https://$AFTOK_HOST/api/user/projects/$PID/events?after=${after}&limit=100"
#!/bin/bash
if [ -f ".env" ]; then
source .env
fi
if [ -z "${AFTOK_HOST}" ]; then
AFTOK_HOST="aftok.com"
fi
if [ -z "${USER}" ]; then
read -p "Username: " USER
echo
fi
if [ -z "${PID}" ]; then
read -p "Project UUID: " PID
echo
fi
curl --verbose \
${ALLOW_INSECURE} \
--user $USER \
"https://$AFTOK_HOST/api/user/projects/$PID/workIndex?limit=100&before=$(date -Iseconds)"
#!/bin/bash
if [ -f ".env" ]; then
source .env
fi
if [ -z "${AFTOK_HOST}" ]; then
AFTOK_HOST="aftok.com"
fi
curl --verbose \
${ALLOW_INSECURE} \
"https://$AFTOK_HOST/api/logout"
<*> (Satoshi <$> o .: "amount")
<*> o
.: "gracePeriod"
<*> (fmap toThyme <$> o .: "requestExpiryPeriod")
<*> o
.:? "paymentRequestEmailTemplate"
<*> o
.:? "paymentRequestMemoTemplate"
<*> ((o .: "currency" >>= amountParser) <*> o .: "amount")
<*> (o .: "gracePeriod")
<*> (toThyme <$> o .: "requestExpiryPeriod")
<*> (o .:? "paymentRequestEmailTemplate")
<*> (o .:? "paymentRequestMemoTemplate")
import Network.HTTP.Client
( HttpException,
defaultManagerSettings,
managerResponseTimeout,
responseTimeoutMicro,
)
import Network.HTTP.Client.OpenSSL
import Network.Wreq
( asValue,
defaults,
getWith,
manager,
responseBody,
)
import OpenSSL.Session (context)
-- import Network.HTTP.Client
-- ( defaultManagerSettings,
-- managerResponseTimeout,
-- responseTimeoutMicro,
-- )
-- import Network.HTTP.Client.OpenSSL
-- import Network.Wreq
-- ( defaults,
-- manager,
-- )
-- import OpenSSL.Session (context)
now <- liftIO $ C.getCurrentTime
snapEval $ findPayableRequests uid sid now
getPaymentRequestHandler :: S.Handler App App P.PaymentRequest
getPaymentRequestHandler =
view (_2 . paymentRequest) <$> getPaymentRequestHandler'
snapEval $ findPayableRequests uid sid
paymentResponseHandler :: AC.BillingConfig -> S.Handler App App PaymentId
paymentResponseHandler cfg = do
bip70PaymentResponseHandler :: AC.BillingConfig -> S.Handler App App PaymentId
bip70PaymentResponseHandler _ = do
let opts =
defaults
& manager
.~ Left (opensslManagerSettings context)
& manager
.~ Left
( defaultManagerSettings
{ managerResponseTimeout = responseTimeoutMicro 10000
}
)
exchResp <-
liftIO
. try @HttpException
$ asValue
=<< (withOpenSSL $ getWith opts (cfg ^. exchangeRateServiceURI))
_ <- traverse (logError . T.encodeUtf8 . show) (preview _Left exchResp)
let newPayment =
Payment
(view _1 preq)
pmnt
now
(preview (_Right . responseBody) exchResp)
-- let opts =
-- defaults
-- & manager
-- .~ Left (opensslManagerSettings context)
-- & manager
-- .~ Left
-- ( defaultManagerSettings
-- { managerResponseTimeout = responseTimeoutMicro 10000
-- }
-- )
-- exchResp <-
-- liftIO
-- . try @HttpException
-- $ asValue
-- =<< (withOpenSSL $ getWith opts (cfg ^. exchangeRateServiceURI))
-- _ <- traverse (logError . T.encodeUtf8 . show) (preview _Left exchResp)
-- (preview (_Right . responseBody) exchResp)
let newPayment = Payment (Const prid) now (BitcoinPayment pmnt)