, HStringTemplate          

  other-modules: Aftok.QConfig

  other-modules: Aftok.ServerConfig

    , vector-space

  network = "test"
  # Signing key for BIP-70 payment requests
  signingKeyFile = "/etc/aftok/aftok.bip70.key.pem"
  certsFile = "/etc/aftok/aftok.bip70-chain.cert.pem"
  exchangeRateServiceURI = "https://blockchain.info/ticker"

  bitcoin {
    networkMode = "test"
    # Signing key for BIP-70 payment requests
    signingKeyFile = "/etc/aftok/aftok.bip70.key.pem"
    certsFile = "/etc/aftok/aftok.bip70-chain.cert.pem"
    exchangeRateServiceURI = "https://blockchain.info/ticker"
    bip70Host = "localhost:8443"
  }
  zcash {
    minPayment = 100
  }

{-# LANGUAGE TypeApplications #-}

  ( Billable,
    Billable',

  ( Billable',

    paymentRequestMemoTemplate,

import Aftok.Currency.Zcash (Zatoshi (..))

import Aftok.Payments.Bitcoin (BillingOps (..), PaymentsConfig)

import qualified Aftok.Payments.Zcash as Zcash

import qualified Aftok.Payments.Bitcoin as Bitcoin

import Data.Thyme.Time as C

import Network.URI
  ( URI,
    parseURI,
  )

import Network.URI (URI)

  | MailGenError

        _pcfg :: !PaymentsConfig

        _pcfg :: !(P.PaymentsConfig AftokM)

makeLenses ''AftokMEnv

makeLenses ''AftokMEnv

  let f a = (a ^. dcfg . D.billingConfig . AC.networkMode, a ^. conn)

  let f a = (a ^. dcfg . D.billingConfig . AC.bitcoinConfig . AC.networkMode, a ^. conn)

  btcCfg <- asks _pcfg
  let btcOps = BillingOps _memoGen (fmap Just . bip70PaymentURL) _payloadGen
      zecCfg = Zcash.PaymentsConfig (Zatoshi 100)
      pcfg' = P.PaymentsConfig btcOps btcCfg zecCfg

  pcfg' <- asks _pcfg

  pcfg' <- liftIO $ AC.toPaymentsConfig @AftokM (cfg ^. dcfg . D.billingConfig)

      bip70URL <- bip70PaymentURL (nreq ^. Bitcoin.paymentRequestKey)
      mail <- buildBip70PaymentRequestEmail preqCfg req''' bip70URL

      let bip70URIGen = Bitcoin.uriGen (pcfg' ^. P.bitcoinBillingOps)
      bip70URL <- bip70URIGen (nreq ^. Bitcoin.paymentRequestKey)
      mail <- traverse (buildBip70PaymentRequestEmail preqCfg req''') bip70URL

      liftIO $ mailer _smtpUser _smtpPass mail

      case mail of
        Just email -> liftIO $ mailer _smtpUser _smtpPass email
        Nothing -> throwError MailGenError

_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
  let template =
        (newSTMP . T.unpack)
          <$> (bill ^. paymentRequestMemoTemplate)
      setAttrs =
        setManyAttrib
          [ ("project_name", req ^. B.project . projectName),
            ("subscription", req ^. B.name),
            ("billing_date", show billingDate),
            ("issue_time", show requestTime)
          ]
  pure $ fmap (render . setAttrs) template
-- The same URL is used for retrieving a BIP-70 payment request and for submitting
-- the response.
bip70PaymentURL :: Bitcoin.PaymentKey -> AftokM URI
bip70PaymentURL (Bitcoin.PaymentKey k) = do
  env <- ask
  let hostname = env ^. (dcfg . D.paymentRequestConfig . D.aftokHost)
      paymentRequestPath = "https://" <> hostname <> "/pay/" <> k
  maybe
    ( throwError
        . ConfigError
        $ "Could not parse path "
          <> paymentRequestPath
          <> " to a valid URI"
    )
    pure
    (parseURI $ show paymentRequestPath)
_payloadGen ::
  Monad m =>
  Billable Satoshi ->
  C.Day ->
  C.UTCTime ->
  m (Maybe ByteString)
_payloadGen _ _ _ = pure Nothing

import qualified Aftok.Billing as B
import Aftok.Project (projectName)

import qualified Aftok.Currency.Bitcoin.Payments as Bitcoin
import Aftok.Currency.Zcash (Zatoshi(..))
import Aftok.Database (MonadDB, findProjectOrError)
import Aftok.Payments (PaymentsConfig(..))

import qualified Aftok.Payments.Zcash as Zcash

    makeClassy,

    makeLenses,
    traverseOf,

import Data.Thyme.Clock (UTCTime)
import Data.Thyme.Time (Day)

import Network.URI (URI, parseURI)

import Text.StringTemplate
  ( newSTMP,
    render,
    setManyAttrib,
  )

readConnectInfo :: C.Config -> IO ConnectInfo
readConnectInfo cfg =
  ConnectInfo
    <$> C.require cfg "host"
    <*> C.require cfg "port"
    <*> C.require cfg "user"
    <*> C.require cfg "password"
    <*> C.require cfg "database"

makeLenses ''SmtpConfig

makeClassy ''SmtpConfig

readSmtpConfig :: C.Config -> IO SmtpConfig
readSmtpConfig cfg =
  SmtpConfig
    <$> C.require cfg "smtpHost"
    <*> ((fmap . fmap) fromInteger $ C.lookup cfg "smtpPort")
    <*> C.require cfg "smtpUser"
    <*> C.require cfg "smtpKey"

data BillingConfig
  = BillingConfig

data BitcoinConfig
  = BitcoinConfig

        _minPayment :: Satoshi

        _minPayment :: Satoshi,
        _bip70Host :: NS.HostName

makeLenses ''BitcoinConfig

makeClassy ''BillingConfig

data BillingConfig
  = BillingConfig
      { _bitcoinConfig :: BitcoinConfig
      , _zcashConfig :: Zcash.PaymentsConfig
      }

readSmtpConfig :: C.Config -> IO SmtpConfig
readSmtpConfig cfg =
  SmtpConfig
    <$> C.require cfg "smtpHost"
    <*> ((fmap . fmap) fromInteger $ C.lookup cfg "smtpPort")
    <*> C.require cfg "smtpUser"
    <*> C.require cfg "smtpKey"

makeLenses ''BillingConfig

    <$> (readBitcoinConfig $ C.subconfig "bitcoin" cfg)
    <*> (readZcashPaymentsConfig $ C.subconfig "zcash" cfg)
readBitcoinConfig :: C.Config -> IO BitcoinConfig
readBitcoinConfig cfg =
  BitcoinConfig

    <*> C.require cfg "bip70Host"

readConnectInfo :: C.Config -> IO ConnectInfo
readConnectInfo cfg =
  ConnectInfo
    <$> C.require cfg "host"
    <*> C.require cfg "port"
    <*> C.require cfg "user"
    <*> C.require cfg "password"
    <*> C.require cfg "database"

readZcashPaymentsConfig :: C.Config -> IO Zcash.PaymentsConfig
readZcashPaymentsConfig cfg =
  Zcash.PaymentsConfig
    <$> (Zatoshi <$> C.require cfg "minPayment")

toPaymentsConfig :: BillingConfig -> IO Bitcoin.PaymentsConfig
toPaymentsConfig c = do

toBitcoinPaymentsConfig :: BitcoinConfig -> IO Bitcoin.PaymentsConfig
toBitcoinPaymentsConfig c = do

toPaymentsConfig :: MonadDB m => BillingConfig -> IO (PaymentsConfig m)
toPaymentsConfig cfg = do
  btcCfg <- toBitcoinPaymentsConfig (cfg ^. bitcoinConfig)
  let btcOps = Bitcoin.BillingOps _memoGen (_uriGen $ cfg ^. bitcoinConfig . bip70Host) _payloadGen
  pure $ PaymentsConfig {
    _bitcoinBillingOps = btcOps,
    _bitcoinPaymentsConfig = btcCfg,
    _zcashPaymentsConfig = cfg ^. zcashConfig
  }
_memoGen ::
  MonadDB m =>
  B.Billable Satoshi ->
  Day ->
  UTCTime ->
  m (Maybe Text)
_memoGen bill billingDate requestTime = do
  req <- traverseOf B.project findProjectOrError bill
  let template =
        (newSTMP . toString)
          <$> (bill ^. B.paymentRequestMemoTemplate)
      setAttrs =
        setManyAttrib
          [ ("project_name", req ^. B.project . projectName),
            ("subscription", req ^. B.name),
            ("billing_date", show billingDate),
            ("issue_time", show requestTime)
          ]
  pure $ fmap (render . setAttrs) template
_payloadGen ::
  Monad m =>
  B.Billable Satoshi ->
  Day ->
  UTCTime ->
  m (Maybe ByteString)
_payloadGen _ _ _ = pure Nothing
-- The same URL is used for retrieving a BIP-70 payment request and for submitting
-- the response.
_uriGen ::
  Monad m =>
  NS.HostName ->
  Bitcoin.PaymentKey
  -> m (Maybe URI)
_uriGen hostname (Bitcoin.PaymentKey k) =
  let paymentRequestPath = "https://" <> fromString hostname <> "/pay/" <> k
   in pure . parseURI $ show paymentRequestPath

    protoBase64,
    fromBase64Proto,

import qualified Data.ByteString.Base64 as B64
import Data.ProtocolBuffers (Decode, Encode, decodeMessage, encodeMessage)
import Data.Serialize.Get (runGet)
import Data.Serialize.Put (runPut)
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

import qualified Aftok.Currency.Bitcoin.Bip70 as Bip70

import qualified Data.ByteString.Base64 as B64
import Data.ProtocolBuffers (Decode, Encode, decodeMessage, encodeMessage)
import Data.Serialize.Get (runGet)
import Data.Serialize.Put (runPut)

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

            "payment_request_protobuf_64" .= (r ^. Bitcoin.bip70Request . to protoBase64)

            "payment_request_protobuf_64" .= (r ^. Bitcoin.bip70Request . to Bip70.protoBase64)

      <*> ( either (fail . toString) pure . fromBase64Proto =<< (o .: "payment_request_protobuf_64")

      <*> ( either (fail . toString) pure . Bip70.fromBase64Proto =<< (o .: "payment_request_protobuf_64")

      "payment_protobuf_64" .= (bp ^. Bitcoin.bip70Payment . to protoBase64)

      "payment_protobuf_64" .= (bp ^. Bitcoin.bip70Payment . to Bip70.protoBase64)

      <*> ( either (fail . unpack) pure . fromBase64Proto =<< (o .: "payment_protobuf_64")

      <*> ( either (fail . unpack) pure . Bip70.fromBase64Proto =<< (o .: "payment_protobuf_64")

            AND currency = 'BTC'
            AND is_primary = true |]

            AND is_primary = true
            AND btc_addr IS NOT NULL |]

            AND currency = 'ZEC'
            AND is_primary = true |]

            AND is_primary = true
            AND zcash_addr IS NOT NULL |]

import Aftok.Currency.Bitcoin
import Aftok.Currency.Zcash (_Zatoshi)

import Aftok.Currency.Bitcoin (Address, NetworkMode, Satoshi, _Satoshi, getNetwork)
import Aftok.Currency.Zcash (Zatoshi, _Zatoshi)

  BTC -> object ["satoshi" .= (value ^. _Satoshi)]
  ZEC -> object ["zatoshi" .= (value ^. _Zatoshi)]

  BTC -> satsJSON value
  ZEC -> zatsJSON value
zatsJSON :: Zatoshi -> Value
zatsJSON value = object ["zatoshi" .= (value ^. _Zatoshi)]

satsJSON :: Satoshi -> Value
satsJSON value = object ["satoshi" .= (value ^. _Satoshi)]

Description: (Describe migration here.)
Created: 2021-02-07 02:43:18.803817984 UTC
Depends: 2020-11-25_04-22-24_zcash-support
Apply: |
  ALTER TABLE cryptocurrency_accounts ADD COLUMN name text;
  ALTER TABLE cryptocurrency_accounts ADD COLUMN description text;
  ALTER TABLE cryptocurrency_accounts DROP COLUMN currency;

#!/bin/bash
if [ -f ".env" ]; then
  source .env
fi
if [ -z "${AFTOK_HOST}" ]; then 
  AFTOK_HOST="aftok.com"
fi
if [ -z "${PID}" ]; then
  read -p "Project UUID: " PID
  echo
fi
if [ -z "${USER}" ]; then 
  read -p "Username: " USER
  echo
fi
read -p "Billable ID: " BID
curl --verbose \
  ${ALLOW_INSECURE} \
  --user $USER \
  --header "Content-Type: application/json" \
  --data "{}" \
  "https://$AFTOK_HOST/api/projects/$PID/billables/$BID/paymentRequests"

module Aftok.QConfig where

module Aftok.ServerConfig where

data QConfig
  = QConfig

data ServerConfig
  = ServerConfig

makeLenses ''QConfig

makeLenses ''ServerConfig

loadQConfig :: P.FilePath -> IO QConfig
loadQConfig cfgFile = do

loadServerConfig :: P.FilePath -> IO ServerConfig
loadServerConfig cfgFile = do

  readQConfig cfg dbEnvCfg

  readServerConfig cfg dbEnvCfg

readQConfig :: CT.Config -> Maybe PGSConfig -> IO QConfig
readQConfig cfg pc =
  QConfig

readServerConfig :: CT.Config -> Maybe PGSConfig -> IO ServerConfig
readServerConfig cfg pc =
  ServerConfig

baseSnapConfig :: QConfig -> SC.Config m a -> SC.Config m a

baseSnapConfig :: ServerConfig -> SC.Config m a -> SC.Config m a

snapConfig :: QConfig -> IO (SC.Config Snap a)

snapConfig :: ServerConfig -> IO (SC.Config Snap a)

    paymentRequestDetailJSON,

import Aftok.Currency.Bitcoin.Bip70 (protoBase64)
import qualified Aftok.Currency.Bitcoin.Payments as Bitcoin

import qualified Aftok.Currency.Zcash.Zip321 as Zip321

    MonadDB,

import Aftok.Json (Version (..), badVersion, unversion)

import Aftok.Json
  ( Version (..),
    badVersion,
    obj,
    satsJSON,
    unversion,
    v1,
    zatsJSON,
  )

  ( PaymentRequestId,

  ( PaymentRequest' (..),
    PaymentRequestId,

  ( PaymentRequestError (..),

  ( NativeRequest (..),
    PaymentRequestError (..),
    _PaymentRequestId,
    billable,
    nativeRequest,
    createdAt,

import Control.Lens ((.~), (^.))
-- import Data.Aeson ()

import Control.Lens ((.~), (^.), to)
import Data.Aeson

  ( (.:),
    (.:?),
    Object,

  ( Pair,

    Value (..),

    parseJSON,

import Data.AffineSpace ((.+^))

import Snap.Core (MonadSnap)

  MonadSnap m =>

  MonadDB m =>

  billable <- snapEval $ withProjectAuth pid uid (FindBillable bid)

  billableMay <- snapEval $ withProjectAuth pid uid (FindBillable bid)

  case billable of

  case billableMay of

--
-- 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
--   ]

paymentRequestDetailJSON :: (PaymentRequestId, SomePaymentRequestDetail) -> Object
paymentRequestDetailJSON (rid, (SomePaymentRequest req)) =
  obj $ ["payment_request_id" .= (rid ^. _PaymentRequestId)] <> fields req
  where
    fields :: PaymentRequest' (Billable' ProjectId UserId) c -> [Pair]
    fields r = case r ^. nativeRequest of
      (Zip321Request req') ->
        [ "total" .= (r ^. billable . B.amount . to zatsJSON),
          "expires_at" .= ((r ^. createdAt) .+^ (r ^. billable . B.requestExpiryPeriod)),
          "native_request" .= zip321PaymentRequestJSON req'
        ]
      (Bip70Request req') ->
        [ "total" .= (r ^. billable . B.amount . to satsJSON),
          "expires_at" .= ((r ^. createdAt) .+^ (r ^. billable . B.requestExpiryPeriod)),
          "native_request" .= bip70PaymentRequestJSON req'
        ]
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)
          ]
    ]

zip321PaymentRequestJSON :: Zip321.PaymentRequest -> Value
zip321PaymentRequestJSON r =
  v1 . obj $
    ["zip321_request" .= (toJSON . Zip321.toURI $ r)]

bip70PaymentResponseHandler :: AC.BillingConfig -> S.Handler App App PaymentId

bip70PaymentResponseHandler :: AC.BitcoinConfig -> S.Handler App App PaymentId

import Aftok.QConfig as QC

import Aftok.ServerConfig as QC

projectInviteHandler :: QConfig -> S.Handler App App ()

projectInviteHandler :: ServerConfig -> S.Handler App App ()

  QConfig ->

  ServerConfig ->

import Aftok.Database.PostgreSQL (QDBM)

import Aftok.QConfig as Q

import Aftok.ServerConfig

  cfg <- loadQConfig . decodeString $ fromRight "conf/aftok.cfg" cfgPath

  cfg <- loadServerConfig . decodeString $ fromRight "conf/aftok.cfg" cfgPath

registerOps :: Manager -> QConfig -> RegisterOps IO

registerOps :: Manager -> ServerConfig -> RegisterOps IO

appInit :: QConfig -> SnapletInit App App

appInit :: ServerConfig -> SnapletInit App App

  paymentsConfig <- liftIO $ C.toPaymentsConfig @QDBM (cfg ^. billingConfig)

  let nmode = cfg ^. billingConfig . C.networkMode

  let nmode = cfg ^. billingConfig . C.bitcoinConfig . C.networkMode

      -- Routes for billables

      paymentRequestCreateRoute =
        serveJSON paymentRequestDetailJSON $ method POST (createPaymentRequestHandler paymentsConfig)

          method POST (bip70PaymentResponseHandler $ cfg ^. billingConfig)

          method POST (bip70PaymentResponseHandler $ cfg ^. billingConfig . C.bitcoinConfig)

      ("projects/:projectId/billables/:billableId/paymentRequests", paymentRequestCreateRoute), -- create_billable.sh / list_project_billables.sh