nnoremap <leader>h :!~/.nix-profile/bin/hasktags -o tags -c $(find lib server daemon test -name \*.hs) && ~/.nix-profile/bin/ctags --options-maybe=.ctags --options=$HOME/.ctags --append=yes .<CR><CR>
nnoremap <leader>o :!~/.nix-profile/bin/ormolu --mode inplace $(find lib server daemon test -name '*.hs')<CR><CR>

{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving       #-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE TemplateHaskell #-}

import           Control.Error.Util             ( maybeT )
import           Control.Lens                   ( (^.)
                                                , makeLenses
                                                , makeClassyPrisms
                                                , traverseOf
                                                , to
                                                )
import           Control.Monad.Except           ( MonadError
                                                , throwError
                                                )
import           Control.Monad.Trans.Except     ( withExceptT )
import           Control.Monad.Trans.Reader     ( mapReaderT )
import           Crypto.Random.Types            ( MonadRandom(..) )
import           Database.PostgreSQL.Simple     ( Connection
                                                , connect
                                                )
import           Data.Thyme.Clock              as C
import           Data.Thyme.Time               as C
import qualified Data.Text                     as T
import qualified Network.Mail.Mime             as Mime
import qualified Network.Mail.SMTP             as SMTP
import           Network.URI                    ( URI
                                                , parseURI
                                                )
import           Text.StringTemplate            ( directoryGroup
                                                , newSTMP
                                                , getStringTemplate
                                                , setManyAttrib
                                                , render
                                                )
import           Filesystem.Path.CurrentOS      ( encodeString )
import           Bippy.Types                    ( Satoshi )

import Aftok.Billing
  ( Billable,
    Billable',
    ContactChannel (..),
    Subscription',
    billable,
    contactChannel,
    customer,
    name,
    paymentRequestEmailTemplate,
    paymentRequestMemoTemplate,
    project,
  )
import qualified Aftok.Config as AC
import Aftok.Currency.Bitcoin (satoshi)
import qualified Aftok.Database as DB
import Aftok.Database.PostgreSQL (QDBM (..))
import qualified Aftok.Payments as P
import Aftok.Payments.Types
  ( PaymentKey (..),
    paymentKey,
    paymentRequestTotal,
    subscription,
  )
import Aftok.Project
  ( Project,
    projectName,
  )
import Aftok.Types
  ( ProjectId (..),
    User,
    UserId,
    _Email,
  )
import qualified AftokD as D
import Bippy.Types (Satoshi)
import Control.Error.Util (maybeT)
import Control.Lens
  ( (^.),
    makeClassyPrisms,
    makeLenses,
    to,
    traverseOf,
  )
import Control.Monad.Except
  ( MonadError,
    throwError,
  )
import Control.Monad.Trans.Except (withExceptT)
import Control.Monad.Trans.Reader (mapReaderT)
import Crypto.Random.Types (MonadRandom (..))
import qualified Data.Text as T
import Data.Thyme.Clock as C
import Data.Thyme.Time as C
import Database.PostgreSQL.Simple
  ( Connection,
    connect,
  )
import Filesystem.Path.CurrentOS (encodeString)
import qualified Network.Mail.Mime as Mime
import qualified Network.Mail.SMTP as SMTP
import Network.URI
  ( URI,
    parseURI,
  )
import Text.StringTemplate
  ( directoryGroup,
    getStringTemplate,
    newSTMP,
    render,
    setManyAttrib,
  )

import           Aftok.Types                    ( User
                                                , UserId
                                                , ProjectId(..)
                                                , _Email
                                                )
import           Aftok.Currency.Bitcoin         ( satoshi )
import qualified Aftok.Config                  as AC
import           Aftok.Billing                  ( Billable
                                                , Billable'
                                                , Subscription'
                                                , ContactChannel(..)
                                                , contactChannel
                                                , customer
                                                , name
                                                , billable
                                                , project
                                                , paymentRequestEmailTemplate
                                                , paymentRequestMemoTemplate
                                                )
import qualified Aftok.Database                as DB
import           Aftok.Database.PostgreSQL      ( QDBM(..) )
import qualified Aftok.Payments                as P
import           Aftok.Payments.Types           ( PaymentKey(..)
                                                , subscription
                                                , paymentRequestTotal
                                                , paymentKey
                                                )
import           Aftok.Project                  ( Project
                                                , projectName
                                                )
import qualified AftokD                        as D

  _Overdue      = _PaymentErr . P._Overdue

  _Overdue = _PaymentErr . P._Overdue

data AftokMEnv = AftokMEnv
  { _dcfg :: !D.Config
  , _conn :: !Connection
  , _pcfg :: !P.PaymentsConfig
  }

data AftokMEnv
  = AftokMEnv
      { _dcfg :: !D.Config,
        _conn :: !Connection,
        _pcfg :: !P.PaymentsConfig
      }

  networkMode    = pcfg . P.networkMode
  signingKey     = pcfg . P.signingKey
  pkiData        = pcfg . P.pkiData

  networkMode = pcfg . P.networkMode
  signingKey = pcfg . P.signingKey
  pkiData = pcfg . P.pkiData

newtype AftokM a = AftokM { runAftokM :: ReaderT AftokMEnv (ExceptT AftokDErr IO) a }

newtype AftokM a = AftokM {runAftokM :: ReaderT AftokMEnv (ExceptT AftokDErr IO) a}

  requests    <-

  requests <-

      preqCfg            = cfg ^. (dcfg . D.paymentRequestConfig)
      reqMay             = do
        preq   <- DB.findPaymentRequestId reqId
        preq'  <- traverseOf P.subscription DB.findSubscriptionBillable preq

      preqCfg = cfg ^. (dcfg . D.paymentRequestConfig)
      reqMay = do
        preq <- DB.findPaymentRequestId reqId
        preq' <- traverseOf P.subscription DB.findSubscriptionBillable preq

  req      <- maybeT (throwError $ DBErr DB.SubjectNotFound) pure reqMay

  req <- maybeT (throwError $ DBErr DB.SubjectNotFound) pure reqMay

  mail     <- buildPaymentRequestEmail preqCfg req bip70URL
  let mailer = maybe (SMTP.sendMailWithLogin _smtpHost)
                     (SMTP.sendMailWithLogin' _smtpHost)
                     _smtpPort

  mail <- buildPaymentRequestEmail preqCfg req bip70URL
  let mailer =
        maybe
          (SMTP.sendMailWithLogin _smtpHost)
          (SMTP.sendMailWithLogin' _smtpHost)
          _smtpPort

buildPaymentRequestEmail
  :: (MonadIO m, MonadError AftokDErr m)
  => D.PaymentRequestConfig
  -> P.PaymentRequest' (Subscription' User (Billable' Project UserId Satoshi))
  -> URI
  -> m Mime.Mail

buildPaymentRequestEmail ::
  (MonadIO m, MonadError AftokDErr m) =>
  D.PaymentRequestConfig ->
  P.PaymentRequest' (Subscription' User (Billable' Project UserId Satoshi)) ->
  URI ->
  m Mime.Mail

          ^.  (subscription . billable . paymentRequestEmailTemplate)

          ^. (subscription . billable . paymentRequestEmailTemplate)

        -- TODO: other channels

      -- TODO: other channels

          pname     = req ^. (subscription . billable . project . projectName)
          total     = req ^. (P.paymentRequest . to paymentRequestTotal)
          setAttrs  = setManyAttrib
            [ ("from_email"  , fromEmail ^. _Email)
            , ("project_name", pname)
            , ("to_email"    , toEmail ^. _Email)
            , ("amount_due"  , show $ total ^. satoshi)
            , ("payment_url" , show paymentUrl)
            ]

          pname = req ^. (subscription . billable . project . projectName)
          total = req ^. (P.paymentRequest . to paymentRequestTotal)
          setAttrs =
            setManyAttrib
              [ ("from_email", fromEmail ^. _Email),
                ("project_name", pname),
                ("to_email", toEmail ^. _Email),
                ("amount_due", show $ total ^. satoshi),
                ("payment_url", show paymentUrl)
              ]

          toAddr   = Mime.Address Nothing (toEmail ^. _Email)
          subject  = "Payment is due for your " <> pname <> " subscription!"
          body     = Mime.plainPart . render $ setAttrs template

          toAddr = Mime.Address Nothing (toEmail ^. _Email)
          subject = "Payment is due for your " <> pname <> " subscription!"
          body = Mime.plainPart . render $ setAttrs template

memoGen
  :: Subscription' UserId Billable -> C.Day -> C.UTCTime -> AftokM (Maybe Text)

memoGen ::
  Subscription' UserId Billable -> C.Day -> C.UTCTime -> AftokM (Maybe Text)

      setAttrs = setManyAttrib
        [ ("project_name", req ^. (billable . project . projectName))
        , ("subscription", req ^. (billable . name))
        , ("billing_date", show billingDate)
        , ("issue_time"  , show requestTime)
        ]

      setAttrs =
        setManyAttrib
          [ ("project_name", req ^. (billable . project . projectName)),
            ("subscription", req ^. (billable . name)),
            ("billing_date", show billingDate),
            ("issue_time", show requestTime)
          ]

  let hostname           = env ^. (dcfg . D.paymentRequestConfig . D.aftokHost)

  let hostname = env ^. (dcfg . D.paymentRequestConfig . D.aftokHost)

    (  throwError
    .  ConfigError
    $  "Could not parse path "
    <> paymentRequestPath
    <> " to a valid URI"

    ( throwError
        . ConfigError
        $ "Could not parse path "
          <> paymentRequestPath
          <> " to a valid URI"

payloadGen
  :: Monad m
  => Subscription' UserId Billable
  -> C.Day
  -> C.UTCTime
  -> m (Maybe ByteString)

payloadGen ::
  Monad m =>
  Subscription' UserId Billable ->
  C.Day ->
  C.UTCTime ->
  m (Maybe ByteString)

import           Control.Lens

import qualified Aftok.Config as AC
import Aftok.Types (Email (..))
import Control.Lens
import qualified Data.Configurator as C
import qualified Data.Configurator.Types as CT
import Database.PostgreSQL.Simple (ConnectInfo)
import Filesystem.Path.CurrentOS
  ( encodeString,
    fromText,
  )
import qualified Filesystem.Path.CurrentOS as P

import qualified Data.Configurator             as C
import qualified Data.Configurator.Types       as CT
import           Database.PostgreSQL.Simple     ( ConnectInfo )
import           Filesystem.Path.CurrentOS      ( fromText
                                                , encodeString
                                                )
import qualified Filesystem.Path.CurrentOS     as P

data PaymentRequestConfig
  = PaymentRequestConfig
      { _aftokHost :: Text,
        _templatePath :: P.FilePath,
        _billingFromEmail :: Email
      }

import           Aftok.Types                    ( Email(..) )
import qualified Aftok.Config                  as AC

makeLenses ''PaymentRequestConfig

data PaymentRequestConfig = PaymentRequestConfig
  { _aftokHost :: Text
  , _templatePath :: P.FilePath
  , _billingFromEmail :: Email
  }
makeLenses ''PaymentRequestConfig

data Config
  = Config
      { _smtpConfig :: AC.SmtpConfig,
        _billingConfig :: AC.BillingConfig,
        _dbConfig :: ConnectInfo,
        _paymentRequestConfig :: PaymentRequestConfig
      }

data Config = Config
  { _smtpConfig     :: AC.SmtpConfig
  , _billingConfig  :: AC.BillingConfig
  , _dbConfig       :: ConnectInfo
  , _paymentRequestConfig :: PaymentRequestConfig
  }

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

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

  ( main

  ( main,

import qualified AftokD as D
import AftokD.AftokM (createAllPaymentRequests)
import Control.Exception (try)
import Filesystem.Path.CurrentOS (decodeString)
import System.Environment (getEnv)
import System.IO.Error (IOError)

import           Control.Exception              ( try )
import           System.Environment             ( getEnv )
import           System.IO.Error                ( IOError )
import           Filesystem.Path.CurrentOS      ( decodeString )
import qualified AftokD                        as D
import           AftokD.AftokM                  ( createAllPaymentRequests )

  cfg     <- D.loadConfig . decodeString $ either (const "conf/aftok.cfg")
                                                  id
                                                  cfgPath

  cfg <-
    D.loadConfig . decodeString $
      either
        (const "conf/aftok.cfg")
        id
        cfgPath

import           Control.Lens
import           Data.Hourglass                 ( Seconds(..) )
import           Data.Ratio                     ( (%) )
import           Data.Traversable               ( for )
import           Data.Thyme.Clock              as C
import           Data.Thyme.Format              ( )
import           Data.UUID

import Aftok.Currency.Bitcoin
  ( satoshi,
    ssub,
  )
import Aftok.Types
  ( ProjectId,
    UserId,
  )
import Bippy.Types (Satoshi (..))
import Control.Lens
import Data.Hourglass (Seconds (..))
import Data.Ratio ((%))
import Data.Thyme.Clock as C
import Data.Thyme.Format ()
import Data.Traversable (for)
import Data.UUID

import           Aftok.Types                    ( UserId
                                                , ProjectId
                                                )
import           Aftok.Currency.Bitcoin         ( satoshi
                                                , ssub
                                                )
import           Bippy.Types                    ( Satoshi(..) )

newtype AuctionId = AuctionId UUID deriving (Show, Eq)

newtype AuctionId = AuctionId UUID deriving (Show, Eq)

data Auction = Auction
  { _projectId    :: ProjectId
  , _initiator    :: UserId
  , _createdAt    :: C.UTCTime
  , _raiseAmount  :: Satoshi
  , _auctionStart :: C.UTCTime
  , _auctionEnd   :: C.UTCTime
  }

data Auction
  = Auction
      { _projectId :: ProjectId,
        _initiator :: UserId,
        _createdAt :: C.UTCTime,
        _raiseAmount :: Satoshi,
        _auctionStart :: C.UTCTime,
        _auctionEnd :: C.UTCTime
      }

data Bid = Bid
  { _bidUser    :: UserId
  , _bidSeconds :: Seconds
  , _bidAmount  :: Satoshi
  , _bidTime    :: C.UTCTime
  } deriving (Eq, Show)

data Bid
  = Bid
      { _bidUser :: UserId,
        _bidSeconds :: Seconds,
        _bidAmount :: Satoshi,
        _bidTime :: C.UTCTime
      }
  deriving (Eq, Show)

data Commitment = Commitment
  { _baseBid           :: Bid
  , _commitmentSeconds :: Seconds
  , _commitmentAmount  :: Satoshi
  }

data Commitment
  = Commitment
      { _baseBid :: Bid,
        _commitmentSeconds :: Seconds,
        _commitmentAmount :: Satoshi
      }

 where
  secs bid = toRational $ bid ^. bidSeconds
  btc bid = toRational $ bid ^. bidAmount . satoshi
  costRatio bid = secs bid / btc bid

  where
    secs bid = toRational $ bid ^. bidSeconds
    btc bid = toRational $ bid ^. bidAmount . satoshi
    costRatio bid = secs bid / btc bid

  let
    takeWinningBids :: Satoshi -> [Bid] -> [Bid]
    takeWinningBids total (bid : xs)
      |
      -- if the total is fully within the raise amount
        total <> (bid ^. bidAmount) < raiseAmount'
      = bid : takeWinningBids (total <> (bid ^. bidAmount)) xs
      |
      -- if the last bid will exceed the raise amount, reduce it to fit
        total < raiseAmount'
      = let
          winFraction r = r % (bid ^. bidAmount . satoshi)
          remainderSeconds (Satoshi r) =
            Seconds . round $ winFraction r * fromIntegral (bid ^. bidSeconds)
          adjustBid r = bid & bidSeconds .~ remainderSeconds r & bidAmount .~ r
        in
          toList $ adjustBid <$> raiseAmount' `ssub` total
      | otherwise
      = []
    takeWinningBids _ [] = []
    submittedTotal = bidsTotal bids
  in
    maybe (WinningBids $ takeWinningBids (Satoshi 0) $ sortBy bidOrder bids)
          InsufficientBids
          (raiseAmount' `ssub` submittedTotal)

  let takeWinningBids :: Satoshi -> [Bid] -> [Bid]
      takeWinningBids total (bid : xs)
        | -- if the total is fully within the raise amount
          total <> (bid ^. bidAmount) < raiseAmount' =
          bid : takeWinningBids (total <> (bid ^. bidAmount)) xs
        | -- if the last bid will exceed the raise amount, reduce it to fit
          total < raiseAmount' =
          let winFraction r = r % (bid ^. bidAmount . satoshi)
              remainderSeconds (Satoshi r) =
                Seconds . round $ winFraction r * fromIntegral (bid ^. bidSeconds)
              adjustBid r = bid & bidSeconds .~ remainderSeconds r & bidAmount .~ r
           in toList $ adjustBid <$> raiseAmount' `ssub` total
        | otherwise =
          []
      takeWinningBids _ [] = []
      submittedTotal = bidsTotal bids
   in maybe
        (WinningBids $ takeWinningBids (Satoshi 0) $ sortBy bidOrder bids)
        InsufficientBids
        (raiseAmount' `ssub` submittedTotal)

    x | x <> (bid ^. bidAmount) < raiseAmount' ->
      put (x <> bid ^. bidAmount)
        >> (pure . Just $ Commitment bid (bid ^. bidSeconds) (bid ^. bidAmount))

    x
      | x <> (bid ^. bidAmount) < raiseAmount' ->
        put (x <> bid ^. bidAmount)
          >> (pure . Just $ Commitment bid (bid ^. bidSeconds) (bid ^. bidAmount))

    x | x < raiseAmount' ->
      let winFraction r = r % (bid ^. bidAmount . satoshi)
          remainderSeconds (Satoshi r) =

    x
      | x < raiseAmount' ->
        let winFraction r = r % (bid ^. bidAmount . satoshi)
            remainderSeconds (Satoshi r) =

      in  for (raiseAmount' `ssub` x) $ \remainder ->
            put (x <> remainder)
              *> (pure $ Commitment bid (remainderSeconds remainder) remainder)

         in for (raiseAmount' `ssub` x) $ \remainder ->
              put (x <> remainder)
                *> (pure $ Commitment bid (remainderSeconds remainder) remainder)

{-# LANGUAGE DeriveFoldable    #-}
{-# LANGUAGE DeriveFunctor     #-}

{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE ExplicitForAll    #-}
{-# LANGUAGE TemplateHaskell   #-}

{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE TemplateHaskell #-}

import           Control.Lens     (makeLenses, makePrisms, preview, view, _Just)
import           Data.Thyme.Clock as C
import           Data.Thyme.Time  as T
import           Data.UUID

import           Aftok.Types      (UserId, ProjectId, Email)
import           Bippy.Types      (Satoshi)

import Aftok.Types (Email, ProjectId, UserId)
import Bippy.Types (Satoshi)
import Control.Lens (_Just, makeLenses, makePrisms, preview, view)
import Data.Thyme.Clock as C
import Data.Thyme.Time as T
import Data.UUID

--  | SemiMonthly
  | Weekly Int

  | --  | SemiMonthly
    Weekly Int

recurrenceName Annually    = "annually"

recurrenceName Annually = "annually"

recurrenceName (Weekly _)  = "weekly"
recurrenceName OneTime     = "onetime"

recurrenceName (Weekly _) = "weekly"
recurrenceName OneTime = "onetime"

recurrenceCount Annually    = Nothing

recurrenceCount Annually = Nothing

recurrenceCount (Weekly i)  = Just i
recurrenceCount OneTime     = Nothing

recurrenceCount (Weekly i) = Just i
recurrenceCount OneTime = Nothing

data Billable' p u c = Billable
  { _project             :: p
  , _creator             :: u
  , _name                :: Text
  , _description         :: Text
  , _recurrence          :: Recurrence
  , _amount              :: c
  , _gracePeriod         :: Days
  , _requestExpiryPeriod :: Maybe C.NominalDiffTime
  , _paymentRequestEmailTemplate :: Maybe Text
  , _paymentRequestMemoTemplate :: Maybe Text
  }

data Billable' p u c
  = Billable
      { _project :: p,
        _creator :: u,
        _name :: Text,
        _description :: Text,
        _recurrence :: Recurrence,
        _amount :: c,
        _gracePeriod :: Days,
        _requestExpiryPeriod :: Maybe C.NominalDiffTime,
        _paymentRequestEmailTemplate :: Maybe Text,
        _paymentRequestMemoTemplate :: Maybe Text
      }

data Subscription' u b = Subscription
  { _customer       :: u
  , _billable       :: b
  , _contactChannel :: ContactChannel
  , _startTime      :: C.UTCTime
  , _endTime        :: Maybe C.UTCTime
  }

data Subscription' u b
  = Subscription
      { _customer :: u,
        _billable :: b,
        _contactChannel :: ContactChannel,
        _startTime :: C.UTCTime,
        _endTime :: Maybe C.UTCTime
      }

  Annually  -> Just . T.addGregorianYearsClip 1

  Annually -> Just . T.addGregorianYearsClip 1

  Weekly w  -> Just . T.addDays (w * 7)
  OneTime   -> const Nothing

  Weekly w -> Just . T.addDays (w * 7)
  OneTime -> const Nothing

import           Control.Lens                   ( makeClassy
                                                , (^.)
                                                )
import qualified Data.Configurator             as C
import qualified Data.Configurator.Types       as C
import           Data.X509
import           Data.X509.File                 ( readKeyFile
                                                , readSignedObject
                                                )
import           Database.PostgreSQL.Simple     ( ConnectInfo(..) )
import           Filesystem.Path.CurrentOS      ( fromText
                                                , encodeString
                                                )
import qualified Filesystem.Path.CurrentOS     as P
import           Safe                           ( headMay )

import Aftok.Currency.Bitcoin (NetworkMode)
import Aftok.Payments (PaymentsConfig (..))
import qualified Bippy.Types as BT
import Control.Lens
  ( (^.),
    makeClassy,
  )
import qualified Data.Configurator as C
import qualified Data.Configurator.Types as C
import Data.X509
import Data.X509.File
  ( readKeyFile,
    readSignedObject,
  )
import Database.PostgreSQL.Simple (ConnectInfo (..))
import Filesystem.Path.CurrentOS
  ( encodeString,
    fromText,
  )
import qualified Filesystem.Path.CurrentOS as P
import qualified Network.Mail.SMTP as SMTP
import qualified Network.Socket as NS
import Safe (headMay)

import qualified Bippy.Types                   as BT
import qualified Network.Mail.SMTP             as SMTP
import qualified Network.Socket                as NS
import           Aftok.Currency.Bitcoin         ( NetworkMode )
import           Aftok.Payments                 ( PaymentsConfig(..) )

data SmtpConfig
  = SmtpConfig
      { _smtpHost :: NS.HostName,
        _smtpPort :: Maybe NS.PortNumber,
        _smtpUser :: SMTP.UserName,
        _smtpPass :: SMTP.Password
      }

data SmtpConfig = SmtpConfig
  { _smtpHost :: NS.HostName
  , _smtpPort :: Maybe NS.PortNumber
  , _smtpUser :: SMTP.UserName
  , _smtpPass :: SMTP.Password
  }

data BillingConfig = BillingConfig
  { _networkMode            :: NetworkMode
  , _signingKeyFile         :: P.FilePath
  , _certsFile              :: P.FilePath
  , _exchangeRateServiceURI :: String
  }

data BillingConfig
  = BillingConfig
      { _networkMode :: NetworkMode,
        _signingKeyFile :: P.FilePath,
        _certsFile :: P.FilePath,
        _exchangeRateServiceURI :: String
      }

  privKeys   <- readKeyFile . encodeString $ c ^. signingKeyFile

  privKeys <- readKeyFile . encodeString $ c ^. signingKeyFile

  privKey    <- case headMay privKeys of

  privKey <- case headMay privKeys of

      fail
        $ "Only RSA keys are currently supported for payment request signing."
    Nothing -> fail $ "No keys found in private key file " <> encodeString
      (c ^. signingKeyFile)

      fail $
        "Only RSA keys are currently supported for payment request signing."
    Nothing ->
      fail $
        "No keys found in private key file "
          <> encodeString
            (c ^. signingKeyFile)

{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE TemplateHaskell            #-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}

import qualified Data.Configurator.Types       as C
import           Control.Lens
import           Bippy.Types                    ( Satoshi(..) )
import           Haskoin.Constants

import Bippy.Types (Satoshi (..))
import Control.Lens
import qualified Data.Configurator.Types as C
import Haskoin.Constants

ssub _ _                             = Nothing

ssub _ _ = Nothing

  _     -> Nothing

  _ -> Nothing

  _      -> Nothing

  _ -> Nothing

  convert _            = Nothing

  convert _ = Nothing

  "btc"     -> Just BTC

  "btc" -> Just BTC

  "bch"     -> Just BCH

  "bch" -> Just BCH

  _         -> Nothing

  _ -> Nothing

{-# LANGUAGE TemplateHaskell    #-}

{-# LANGUAGE TemplateHaskell #-}

  ( ZAddr(..)
  , _ZAddr
  , RPCError(..)
  , ZValidateAddressErr(..)
  , ZcashdConfig(..)
  , Zatoshi
  , ToZatoshi(..)
  , rpcAddViewingKey
  , rpcValidateZAddr
  ) where

  ( ZAddr (..),
    _ZAddr,
    RPCError (..),
    ZValidateAddressErr (..),
    ZcashdConfig (..),
    Zatoshi,
    ToZatoshi (..),
    rpcAddViewingKey,
    rpcValidateZAddr,
  )
where

import           Control.Exception              ( catch )
import           Control.Lens                   ( makePrisms )
import           Control.Monad.Trans.Except     ( except )
import qualified Data.Aeson                     as A
import           Data.Aeson                     ( Value, (.=), (.:), (.:?), object, encode )
import           Data.Aeson.Types               ( Parser )
import qualified Data.Text.Encoding            as T

import Control.Exception (catch)
import Control.Lens (makePrisms)
import Control.Monad.Trans.Except (except)
import Data.Aeson ((.:), (.:?), (.=), Value, encode, object)
import qualified Data.Aeson as A
import Data.Aeson.Types (Parser)
import qualified Data.Text.Encoding as T
import Network.HTTP.Client
  ( HttpException,
    Manager,
    RequestBody (..),
    applyBasicAuth,
    defaultRequest,
    host,
    httpLbs,
    method,
    port,
    requestBody,
    responseBody,
    responseStatus,
  )
import Network.HTTP.Types (Status, statusCode)

import           Network.HTTP.Client            ( Manager
                                                , RequestBody(..)
                                                , HttpException
                                                , defaultRequest
                                                , responseBody
                                                , responseStatus
                                                , httpLbs
                                                , host, port, method, requestBody
                                                , applyBasicAuth
                                                )
import           Network.HTTP.Types             ( Status, statusCode )

newtype ZAddr = ZAddr { zaddrText :: Text }

newtype ZAddr = ZAddr {zaddrText :: Text}

data ZcashdConfig = ZcashdConfig
  { zcashdHost :: Text
  , zcashdPort :: Int
  , rpcUser :: Text
  , rpcPassword :: Text
  }

data ZcashdConfig
  = ZcashdConfig
      { zcashdHost :: Text,
        zcashdPort :: Int,
        rpcUser :: Text,
        rpcPassword :: Text
      }

  ZValidateAddress  :: Text -> RPCCall ZValidateAddressResp

  ZValidateAddress :: Text -> RPCCall ZValidateAddressResp

  let req = applyBasicAuth (T.encodeUtf8 $ rpcUser cfg) (T.encodeUtf8 $ rpcPassword cfg) $
            defaultRequest { host = T.encodeUtf8 $ zcashdHost cfg
                           , port = zcashdPort cfg
                           , method = "POST"
                           , requestBody = RequestBodyLBS . encode $ toRequestBody call
                           }
  response <- ExceptT $ catch
    (Right <$> httpLbs req mgr)
    (pure . Left . HttpError)

  let req =
        applyBasicAuth (T.encodeUtf8 $ rpcUser cfg) (T.encodeUtf8 $ rpcPassword cfg) $
          defaultRequest
            { host = T.encodeUtf8 $ zcashdHost cfg,
              port = zcashdPort cfg,
              method = "POST",
              requestBody = RequestBodyLBS . encode $ toRequestBody call
            }
  response <-
    ExceptT $
      catch
        (Right <$> httpLbs req mgr)
        (pure . Left . HttpError)

    _   -> Left (ServiceError status)

    _ -> Left (ServiceError status)

data ZValidateAddressResp = ZValidateAddressResp
  { vzrIsValid  :: Bool
  --, vzrAddress  :: Maybe Text
  , vzrAddrType :: Maybe ZAddrType
  }

data ZValidateAddressResp
  = ZValidateAddressResp
      { vzrIsValid :: Bool,
        --, vzrAddress  :: Maybe Text
        vzrAddrType :: Maybe ZAddrType
      }

validateZAddrRequest addr = object
  [ "jsonrpc" .= ("1.0" :: Text)
  , "id"      .= ("aftok-z_validateaddress" :: Text)
  , "method"  .= ("z_validateaddress" :: Text)
  , "params"  .= [addr]
  ]

validateZAddrRequest addr =
  object
    [ "jsonrpc" .= ("1.0" :: Text),
      "id" .= ("aftok-z_validateaddress" :: Text),
      "method" .= ("z_validateaddress" :: Text),
      "params" .= [addr]
    ]

                         -- <*> res .:? "address"
                         <*> parseAddrType res

      -- <*> res .:? "address"
      <*> parseAddrType res

  except $ if vzrIsValid resp
    then
      case vzrAddrType resp of
        Nothing      -> Left (RPCError DataMissing)
        Just Sprout  -> Left (RPCError SproutAddress)

  except $
    if vzrIsValid resp
      then case vzrAddrType resp of
        Nothing -> Left (RPCError DataMissing)
        Just Sprout -> Left (RPCError SproutAddress)

    else
      Left $ RPCError ZAddrInvalid

      else Left $ RPCError ZAddrInvalid

data ZImportViewingKeyResp = ZImportViewingKeyResp
  { addressType :: ZAddrType
  -- , address :: ZAddr
  }

data ZImportViewingKeyResp
  = ZImportViewingKeyResp
      { addressType :: ZAddrType
        -- , address :: ZAddr
      }

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

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

importViewingKeyRequest vk = object
  [ "jsonrpc" .= ("1.0" :: Text)
  , "id"      .= ("aftok-z_importviewingkey" :: Text)
  , "method"  .= ("z_importviewingkey" :: Text)
  , "params"  .= [vk, "no"] -- no need to rescan, for our purposes
  ]

importViewingKeyRequest vk =
  object
    [ "jsonrpc" .= ("1.0" :: Text),
      "id" .= ("aftok-z_importviewingkey" :: Text),
      "method" .= ("z_importviewingkey" :: Text),
      "params" .= [vk, "no"] -- no need to rescan, for our purposes
    ]

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

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

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

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

import           Data.Aeson                     ( FromJSON(..)
                                                , ToJSON(..)
                                                )
import           Aftok.TimeLog.Serialization    ( depfFromJSON
                                                , depfToJSON
                                                )
import           Aftok.Types                    ( DepreciationFunction )

import Aftok.TimeLog.Serialization
  ( depfFromJSON,
    depfToJSON,
  )
import Aftok.Types (DepreciationFunction)
import Data.Aeson
  ( FromJSON (..),
    ToJSON (..),
  )

newtype SerDepFunction = SerDepFunction { unSerDepFunction :: DepreciationFunction }

newtype SerDepFunction = SerDepFunction {unSerDepFunction :: DepreciationFunction}

{-# LANGUAGE GADTs                      #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE QuasiQuotes                #-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}

  ( QDBM(..)
  , runQDBM

  ( QDBM (..),
    runQDBM,

import           Prelude                 hiding ( null )
import           Control.Lens
import           Control.Monad.Trans.Except     ( throwE )
import           Crypto.Random.Types            ( MonadRandom
                                                , getRandomBytes
                                                )
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
import           Database.PostgreSQL.Simple.FromField
import           Database.PostgreSQL.Simple.FromRow
import           Database.PostgreSQL.Simple.SqlQQ
                                                ( sql )
import           Database.PostgreSQL.Simple.Types
                                                ( Null )
import           Safe                           ( headMay )

import qualified Aftok.Auction as A
import qualified Aftok.Billing as B
import Aftok.Currency.Bitcoin
import Aftok.Currency.Zcash (ZAddr (..), _ZAddr)
import Aftok.Database
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 Control.Monad.Trans.Except (throwE)
import Crypto.Random.Types
  ( MonadRandom,
    getRandomBytes,
  )
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
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)
import Prelude hiding (null)

import qualified Aftok.Auction                 as A
import qualified Aftok.Billing                 as B
import           Aftok.Currency.Bitcoin
import           Aftok.Currency.Zcash           (ZAddr(..), _ZAddr)
import           Aftok.Database
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           Haskoin.Address                ( Address
                                                , textToAddr
                                                , addrToText
                                                )
import           Haskoin.Constants              ( Network )

    Just other -> returnError
      ConversionFailed
      f
      ("Network identifier " <> other <> " is not supported.")

    Just other ->
      returnError
        ConversionFailed
        f
        ("Network identifier " <> other <> " is not supported.")

  address   <- fieldWith $ addrFieldParser (toNetwork mode networkId)

  address <- fieldWith $ addrFieldParser (toNetwork mode networkId)

  let err = returnError
        ConversionFailed
        f
        (  "could not deserialize value "
        <> T.unpack fieldValue
        <> " to a valid BTC address for network "
        <> show n
        )

  let err =
        returnError
          ConversionFailed
          f
          ( "could not deserialize value "
              <> T.unpack fieldValue
              <> " to a valid BTC address for network "
              <> show n
          )

    else maybe
      (returnError UnexpectedNull f "event type may not be null")
      ( maybe (returnError Incompatible f "unrecognized event type value") pure
      . nameEvent
      . decodeUtf8
      )
      v

    else
      maybe
        (returnError UnexpectedNull f "event type may not be null")
        ( maybe (returnError Incompatible f "unrecognized event type value") pure
            . nameEvent
            . decodeUtf8
        )
        v

creditToParser'
  :: NetworkMode -> FieldParser (RowParser (CreditTo (NetworkId, Address)))

creditToParser' ::
  NetworkMode -> FieldParser (RowParser (CreditTo (NetworkId, Address)))

 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

  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

qdbLogEntryParser
  :: NetworkMode -> RowParser (KeyedLogEntry (NetworkId, Address))

qdbLogEntryParser ::
  NetworkMode -> RowParser (KeyedLogEntry (NetworkId, Address))

    <*> (
      (maybe empty pure =<< fmap (RecoverByEmail . Email) <$> field)
      <|>
      (maybe empty pure =<< fmap (RecoverByZAddr . ZAddr) <$> field)
    )

    <*> ( (maybe empty pure =<< fmap (RecoverByEmail . Email) <$> field)
            <|> (maybe empty pure =<< fmap (RecoverByZAddr . ZAddr) <$> field)
        )

        "monthly"  -> B.Monthly <$> field

        "monthly" -> B.Monthly <$> field

        "weekly"   -> B.Weekly <$> field
        "onetime"  -> nullField *> pure B.OneTime
        _          -> empty
  in  field >>= prec

        "weekly" -> B.Weekly <$> field
        "onetime" -> nullField *> pure B.OneTime
        _ -> empty
   in field >>= prec

    <*> fmap toThyme    field
    <*> fmap toThyme    field

    <*> fmap toThyme field
    <*> fmap toThyme field

  ids  <- lift . lift $ query conn q d

  ids <- lift . lift $ query conn q d

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

      ( pid
      , uid
      , creditToName c
      , renderNetworkId nid
      , addrToText network addr
      , eventName e
      , fromThyme $ e ^. eventTime
      , m

      ( pid,
        uid,
        creditToName c,
        renderNetworkId nid,
        addrToText network addr,
        eventName e,
        fromThyme $ e ^. eventTime,
        m

  CreditToProject pid' -> pinsert
    EventId
    [sql| INSERT INTO work_events

  CreditToProject pid' ->
    pinsert
      EventId
      [sql| INSERT INTO work_events

    ( pid
    , uid
    , creditToName c
    , pid' ^. _ProjectId
    , eventName e
    , fromThyme $ e ^. eventTime
    , m
    )
  CreditToUser uid' -> pinsert
    EventId
    [sql| INSERT INTO work_events

      ( pid,
        uid,
        creditToName c,
        pid' ^. _ProjectId,
        eventName e,
        fromThyme $ e ^. eventTime,
        m
      )
  CreditToUser uid' ->
    pinsert
      EventId
      [sql| INSERT INTO work_events

    ( pid
    , uid
    , creditToName c
    , uid' ^. _UserId
    , eventName e
    , fromThyme $ e ^. eventTime
    , m
    )

      ( pid,
        uid,
        creditToName c,
        uid' ^. _UserId,
        eventName e,
        fromThyme $ e ^. eventTime,
        m
      )

  headMay <$> pquery
    (qdbLogEntryParser mode)
    [sql| SELECT project_id, user_id,

  headMay
    <$> pquery
      (qdbLogEntryParser mode)
      [sql| SELECT project_id, user_id,

    (Only eid)

      (Only eid)

    (Before e) -> pquery
      (logEntryParser mode)
      [sql| SELECT credit_to_type,

    (Before e) ->
      pquery
        (logEntryParser mode)
        [sql| SELECT credit_to_type,

      (pid, uid, fromThyme e, limit)
    (During s e) -> pquery
      (logEntryParser mode)
      [sql| SELECT credit_to_type,

        (pid, uid, fromThyme e, limit)
    (During s e) ->
      pquery
        (logEntryParser mode)
        [sql| SELECT credit_to_type,

      (pid, uid, fromThyme s, fromThyme e, limit)
    (After s) -> pquery
      (logEntryParser mode)
      [sql| SELECT credit_to_type,

        (pid, uid, fromThyme s, fromThyme e, limit)
    (After s) ->
      pquery
        (logEntryParser mode)
        [sql| SELECT credit_to_type,

      (pid, uid, fromThyme s, limit)
    (Always) -> pquery
      (logEntryParser mode)
      [sql| SELECT credit_to_type,

        (pid, uid, fromThyme s, limit)
    (Always) ->
      pquery
        (logEntryParser mode)
        [sql| SELECT credit_to_type,

      (pid, uid, limit)
pgEval (AmendEvent (EventId eid) (TimeChange mt t)) = pinsert
  AmendmentId
  [sql| INSERT INTO event_time_amendments

        (pid, uid, limit)
pgEval (AmendEvent (EventId eid) (TimeChange mt t)) =
  pinsert
    AmendmentId
    [sql| INSERT INTO event_time_amendments

  (eid, fromThyme $ mt ^. _ModTime, fromThyme t)

    (eid, fromThyme $ mt ^. _ModTime, fromThyme t)

        ( eid
        , fromThyme $ mt ^. _ModTime
        , creditToName c
        , renderNetworkId nid
        , addrToText network addr

        ( eid,
          fromThyme $ mt ^. _ModTime,
          creditToName c,
          renderNetworkId nid,
          addrToText network addr

    CreditToProject pid -> pinsert
      AmendmentId
      [sql| INSERT INTO event_credit_to_amendments

    CreditToProject pid ->
      pinsert
        AmendmentId
        [sql| INSERT INTO event_credit_to_amendments

      (eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. _ProjectId)
    CreditToUser uid -> pinsert
      AmendmentId
      [sql| INSERT INTO event_credit_to_amendments

        (eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. _ProjectId)
    CreditToUser uid ->
      pinsert
        AmendmentId
        [sql| INSERT INTO event_credit_to_amendments

      (eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId)
pgEval (AmendEvent (EventId eid) (MetadataChange mt v)) = pinsert
  AmendmentId
  [sql| INSERT INTO event_metadata_amendments

        (eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId)
pgEval (AmendEvent (EventId eid) (MetadataChange mt v)) =
  pinsert
    AmendmentId
    [sql| INSERT INTO event_metadata_amendments

  (eid, fromThyme $ mt ^. _ModTime, v)

    (eid, fromThyme $ mt ^. _ModTime, v)

  mode       <- askNetworkMode
  logEntries <- pquery
    (logEntryParser mode)
    [sql| SELECT credit_to_type,

  mode <- askNetworkMode
  logEntries <-
    pquery
      (logEntryParser mode)
      [sql| SELECT credit_to_type,

    (Only pid)

      (Only pid)

pgEval (CreateAuction auc) = pinsert
  A.AuctionId
  [sql| INSERT INTO auctions (project_id, initiator_id, raise_amount, end_time)

pgEval (CreateAuction auc) =
  pinsert
    A.AuctionId
    [sql| INSERT INTO auctions (project_id, initiator_id, raise_amount, end_time)

  ( 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

    ( 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

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

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

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

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

    ( user' ^. (username . _UserName)
    , user' ^? userAccountRecovery . _RecoverByEmail . _Email
    , user' ^? userAccountRecovery . _RecoverByZAddr . _ZAddr

    ( user' ^. (username . _UserName),
      user' ^? userAccountRecovery . _RecoverByEmail . _Email,
      user' ^? userAccountRecovery . _RecoverByZAddr . _ZAddr

  headMay <$> pquery
    userParser
    [sql| SELECT handle, recovery_email, recovery_zaddr FROM users WHERE id = ? |]
    (Only uid)

  headMay
    <$> pquery
      userParser
      [sql| SELECT handle, recovery_email, recovery_zaddr FROM users WHERE id = ? |]
      (Only uid)

  headMay <$> pquery
    ((,) <$> idParser UserId <*> userParser)
    [sql| SELECT id, handle, recovery_email, recovery_zaddr FROM users WHERE handle = ? |]
    (Only h)

  headMay
    <$> pquery
      ((,) <$> idParser UserId <*> userParser)
      [sql| SELECT id, handle, recovery_email, recovery_zaddr FROM users WHERE handle = ? |]
      (Only h)

  headMay <$> pquery
    (btcAddressParser mode)
    [sql| SELECT default_payment_network, default_payment_addr FROM users WHERE id = ? |]
    (Only uid)

  headMay
    <$> pquery
      (btcAddressParser mode)
      [sql| SELECT default_payment_network, default_payment_addr FROM users WHERE id = ? |]
      (Only uid)

  void $ pexec
    [sql| INSERT INTO invitations (project_id, invitor_id, invitee_email, invitation_key, invitation_time)

  void $
    pexec
      [sql| INSERT INTO invitations (project_id, invitor_id, invitee_email, invitation_key, invitation_time)

    (pid, uid, e, P.renderInvCode invCode, fromThyme t)

      (pid, uid, e, P.renderInvCode invCode, fromThyme t)

pgEval (FindInvitation ic) = headMay <$> pquery
  invitationParser
  [sql| SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time

pgEval (FindInvitation ic) =
  headMay
    <$> pquery
      invitationParser
      [sql| SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time

  (Only $ P.renderInvCode ic)

      (Only $ P.renderInvCode ic)

  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)

  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)

    (uid, fromThyme t, P.renderInvCode ic)
pgEval (CreateProject p) = pinsert
  ProjectId
  [sql| INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn)

      (uid, fromThyme t, P.renderInvCode ic)
pgEval (CreateProject p) =
  pinsert
    ProjectId
    [sql| INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn)

  ( p ^. P.projectName
  , p ^. (P.inceptionDate . to fromThyme)
  , p ^. (P.initiator . _UserId)
  , toJSON $ p ^. P.depf . to SerDepFunction
  )

    ( p ^. P.projectName,
      p ^. (P.inceptionDate . to fromThyme),
      p ^. (P.initiator . _UserId),
      toJSON $ p ^. P.depf . to SerDepFunction
    )

pgEval (FindSubscribers pid) = pquery
  (idParser UserId)
  [sql| SELECT s.user_id

pgEval (FindSubscribers pid) =
  pquery
    (idParser UserId)
    [sql| SELECT s.user_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

    (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

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

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

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

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

pgEval (FindBillable bid) =
  headMay
    <$> pquery
      billableParser
      [sql| SELECT b.project_id, e.created_by, b.name, b.description,

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

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

  (Only (pid ^. _ProjectId))

    (Only (pid ^. _ProjectId))

    ( view _UserId       uid
    , view B._BillableId bid
    , view _EventId      eventId
    , fromThyme start_date

    ( 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

pgEval (FindSubscription sid) =
  headMay
    <$> pquery
      subscriptionParser
      [sql| SELECT id, billable_id, contact_email, start_date, end_date

  (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

      (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