find lib test server daemon -name \*.hs -exec brittany --write-mode=inplace {} \;

	ormolu --mode inplace $(find lib server daemon test -name '*.hs')

                      Aftok.Currency.Bitcoin.Payments
                      Aftok.Currency.Bitcoin.Bip70

                      Aftok.Currency.Zcash.Types
                      Aftok.Currency.Zcash.Payments
                      Aftok.Currency.Zcash.Zip321

                      Aftok.Database.PostgreSQL.Json

                      Aftok.Database.PostgreSQL.Auctions
                      Aftok.Database.PostgreSQL.Billing
                      Aftok.Database.PostgreSQL.Events
                      Aftok.Database.PostgreSQL.Projects
                      Aftok.Database.PostgreSQL.Users

                      Aftok.Payments.Bitcoin
                      Aftok.Payments.Zcash
                      Aftok.Payments.Util

    , basement

    , base64-bytestring 

    , base64

    , MonadRandom

    , scientific

    , thyme         

    , thyme

    , uri-encode

{-# LANGUAGE TupleSections #-}

import qualified Aftok.Billing as B

    billable,

    name,

import Aftok.Currency.Bitcoin (satoshi)

import Aftok.Currency.Bitcoin (Satoshi, _Satoshi)
import qualified Aftok.Currency.Bitcoin.Payments as Bitcoin
import Aftok.Currency.Zcash (Zatoshi (..))

import Aftok.Payments.Types
  ( PaymentKey (..),
    paymentKey,
    paymentRequestTotal,
    subscription,
  )

import Aftok.Payments.Bitcoin (BillingOps (..), PaymentsConfig)
import qualified Aftok.Payments.Types as P
import qualified Aftok.Payments.Zcash as Zcash

import Bippy.Types (Satoshi)
import Control.Error.Util (maybeT)

import Control.Error.Util (exceptT, maybeT)

  ( (^.),

  ( (.~),
    Iso',
    (^.),
    from,
    iso,

    over,
    set,

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

        _pcfg :: !P.PaymentsConfig

        _pcfg :: !PaymentsConfig

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

  traverse_ createProjectPaymentRequests projects

  traverse_ createProjectSubscriptionPaymentRequests projects

createProjectPaymentRequests :: ProjectId -> AftokM ()
createProjectPaymentRequests pid = do

createProjectSubscriptionPaymentRequests :: ProjectId -> AftokM ()
createProjectSubscriptionPaymentRequests pid = do

  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

  subscriptions <- join <$> traverse (DB.findSubscriptions pid) subscribers

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

  P.PaymentRequest' (Subscription' User (Billable' Project UserId Satoshi)) ->

  P.PaymentRequest' (Compose (Subscription' User) (Billable' Project UserId)) Satoshi ->

buildPaymentRequestEmail cfg req paymentUrl = do

buildBip70PaymentRequestEmail cfg req paymentUrl = do

          <$> req
          ^. (subscription . billable . paymentRequestEmailTemplate)

          <$> (req ^. P.billable . to getCompose . B.billable . paymentRequestEmailTemplate)

      toEmail <- case req ^. (subscription . contactChannel) of

      toEmail <- case req ^. (P.billable . to getCompose . contactChannel) of

          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

                ("amount_due", show $ total ^. satoshi),

                ("amount_due", show $ total ^. _Satoshi),

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

          <$> (sub ^. (billable . paymentRequestMemoTemplate))

          <$> (bill ^. paymentRequestMemoTemplate)

          [ ("project_name", req ^. (billable . project . projectName)),
            ("subscription", req ^. (billable . name)),

          [ ("project_name", req ^. B.project . projectName),
            ("subscription", req ^. B.name),

paymentURL :: PaymentKey -> AftokM URI
paymentURL (PaymentKey k) = do

bip70PaymentURL :: Bitcoin.PaymentKey -> AftokM URI
bip70PaymentURL (Bitcoin.PaymentKey k) = do

payloadGen ::

_payloadGen ::

  Subscription' UserId Billable ->

  Billable Satoshi ->

payloadGen _ _ _ = pure Nothing

_payloadGen _ _ _ = pure Nothing

  ( satoshi,

  ( _Satoshi,

    btc bid = toRational $ bid ^. bidAmount . satoshi

    btc bid = toRational $ bid ^. bidAmount . _Satoshi

          let winFraction r = r % (bid ^. bidAmount . satoshi)

          let winFraction r = r % (bid ^. bidAmount . _Satoshi)

        let winFraction r = r % (bid ^. bidAmount . satoshi)

        let winFraction r = r % (bid ^. bidAmount . _Satoshi)

{-# LANGUAGE ExplicitForAll #-}

import Bippy.Types (Satoshi)

newtype BillableId = BillableId UUID deriving (Show, Eq)
makePrisms ''BillableId

data Billable' p u c

-- | A potentially recurring billable amount.
data Billable' p u currency

        _description :: Text,

        _description :: Maybe Text,
        _messageText :: Maybe Text,

        _amount :: c,

        _amount :: currency,

        _requestExpiryPeriod :: Maybe C.NominalDiffTime,

        _requestExpiryPeriod :: NominalDiffTime,

type Billable = Billable' ProjectId UserId Satoshi

type Billable amt = Billable' ProjectId UserId amt

newtype SubscriptionId = SubscriptionId UUID deriving (Show, Eq)

newtype BillableId = BillableId UUID deriving (Show, Eq)

makePrisms ''SubscriptionId

makePrisms ''BillableId

-- | An association between a customer and a (potentially recurring) billable amount.
--
-- For one-time billing events, the end date should be the same as the start date.

        _startTime :: C.UTCTime,
        _endTime :: Maybe C.UTCTime

        _startTime :: UTCTime,
        _endTime :: Maybe UTCTime

newtype SubscriptionId = SubscriptionId UUID deriving (Show, Eq)
makePrisms ''SubscriptionId

billingSchedule :: forall u. Subscription' u Billable -> [T.Day]

billingSchedule :: forall u a. Subscription' u (Billable a) -> [T.Day]

import Aftok.Currency.Bitcoin (NetworkMode)
import Aftok.Payments (PaymentsConfig (..))

import Aftok.Currency.Bitcoin (NetworkMode, Satoshi (..))
import qualified Aftok.Payments.Bitcoin as Bitcoin

        _exchangeRateServiceURI :: String

        _exchangeRateServiceURI :: String,
        _minPayment :: Satoshi

    <*> (Satoshi <$> C.lookupDefault 100 cfg "minPayment")

toPaymentsConfig :: BillingConfig -> IO PaymentsConfig

toPaymentsConfig :: BillingConfig -> IO Bitcoin.PaymentsConfig

  pure $ PaymentsConfig (c ^. networkMode) privKey pkiData

  pure $ Bitcoin.PaymentsConfig (c ^. networkMode) privKey pkiData (_minPayment c)

{-# 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

module Aftok.Currency.Bitcoin where

module Aftok.Currency.Bitcoin
  ( Satoshi (..),
    _Satoshi,
    ssub,
    NetworkMode (..),
    renderNetworkMode,
    parseNetworkMode,
    getNetwork,
  )
where

satoshi :: Lens' Satoshi Word64
satoshi inj (Satoshi value) = Satoshi <$> inj value

_Satoshi :: Lens' Satoshi Word64
_Satoshi inj (Satoshi value) = Satoshi <$> inj value

data NetworkId
  = BTC
  | BCH
  deriving (Eq, Show, Ord)
renderNetworkId :: NetworkId -> Text
renderNetworkId = \case
  BTC -> "btc"
  BCH -> "bch"

parseNetworkId :: Text -> Maybe NetworkId
parseNetworkId = \case
  "btc" -> Just BTC
  "bch" -> Just BCH
  _ -> Nothing

renderNetworkMode :: NetworkMode -> Text
renderNetworkMode = \case
  LiveMode -> "live"
  TestMode -> "test"

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

  ( ZAddr (..),
    _ZAddr,

  ( Z.Address (..),
    Z._Address,
    Z.IVK (..),
    Z._IVK,

    Zatoshi,
    ToZatoshi (..),

    Z.Zatoshi (..),
    Z._Zatoshi,
    Z.ToZatoshi (..),

    getUserDiversifiedAddress,

import Aftok.Currency.Zcash.Types as Z
import Aftok.Types (UserId)

import Control.Lens (makePrisms)

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

        vzrAddrType :: Maybe ZAddrType

        vzrAddrType :: Maybe Z.ZAddrType

decodeAddrType :: Text -> Maybe ZAddrType
decodeAddrType = \case
  "sprout" -> Just Sprout
  "sapling" -> Just Sapling
  _ -> Nothing

parseAddrType :: A.Object -> Parser (Maybe ZAddrType)

parseAddrType :: A.Object -> Parser (Maybe Z.ZAddrType)

  let typeMay = decodeAddrType <$> typeStr

  let typeMay = Z.decodeAddrType <$> typeStr

rpcValidateZAddr :: Manager -> ZcashdConfig -> Text -> IO (Either (RPCError ZValidateAddressErr) ZAddr)

rpcValidateZAddr :: Manager -> ZcashdConfig -> Text -> IO (Either (RPCError ZValidateAddressErr) Z.Address)

        Just Sprout -> Left (RPCError SproutAddress)
        Just Sapling -> Right (ZAddr addr)

        Just Z.Sprout -> Left (RPCError SproutAddress)
        Just Z.Sapling -> Right (Z.Address addr)

      { addressType :: ZAddrType
        -- , address :: ZAddr

      { addressType :: Z.ZAddrType
        -- , address :: Z.Address

  -- <*> (ZAddr <$> v .: "address")

  -- <*> (Z.Address <$> v .: "address")

    Sprout -> Left . RPCError $ SproutViewingKey
    Sapling -> Right ()

    Z.Sprout -> Left . RPCError $ SproutViewingKey
    Z.Sapling -> Right ()
getUserDiversifiedAddress :: UserId -> IVK -> Address
getUserDiversifiedAddress = error "Not Yet Implemented."

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

import qualified Aftok.Currency.Zcash as Zcash
import qualified Bippy.Types as Bitcoin
import Control.Lens (view)
import qualified Haskoin.Address as Bitcoin

import Data.Aeson (Value)
import Data.Aeson.Types (Parser)

data Currency a c where
  BTC :: Currency Bitcoin.Address Bitcoin.Satoshi
  ZEC :: Currency Zcash.Address Zcash.Zatoshi
data Currency' c = forall a. Currency' (Currency a c)

data Network a
  = Network
      { addressFromJSON :: Parser a,
        addressToJSON :: a -> Value

data Amount
  = forall a c.
    Amount
      { currency :: !(Currency a c),
        value :: !c

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 Aftok.Types (DepreciationFunction)

import Aftok.Types
  ( AccountId (..),
    CreditTo (..),
    DepreciationFunction,
    ProjectId (..),
    UserId (..),
  )
import Control.Lens ((^.))

  )
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,

import Database.PostgreSQL.Simple.FromRow (RowParser, field, fieldWith)
import Database.PostgreSQL.Simple.Types (Null)
import qualified Haskoin.Address as Bitcoin
import qualified Haskoin.Constants as Bitcoin

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 qualified Aftok.Auction as A
import qualified Aftok.Billing as B
import Aftok.Currency.Bitcoin
import Aftok.Currency.Zcash (ZAddr (..), _ZAddr)

import qualified Aftok.Currency.Bitcoin as Bitcoin

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)

newtype QDBM a = QDBM (ReaderT (NetworkMode, Connection) (ExceptT DBError IO) a)

newtype QDBM a = QDBM (ReaderT (Bitcoin.NetworkMode, Connection) (ExceptT DBError IO) a)

runQDBM :: NetworkMode -> Connection -> QDBM a -> ExceptT DBError IO a

runQDBM :: Bitcoin.NetworkMode -> Connection -> QDBM a -> ExceptT DBError IO a

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