import Control.Error.Util (maybeT)
import Control.Lens ((^.), makeLenses, makeClassyPrisms, traverseOf, to)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Except (ExceptT, withExceptT, runExceptT)
import Control.Monad.Trans.Reader (mapReaderT, withReaderT)

import           Control.Error.Util             ( maybeT )
import           Control.Lens                   ( (^.)
                                                , makeLenses
                                                , makeClassyPrisms
                                                , traverseOf
                                                , to
                                                )
import           Control.Monad.IO.Class         ( MonadIO(..) )
import           Control.Monad.Except           ( MonadError
                                                , throwError
                                                )
import           Control.Monad.Reader           ( MonadReader )
import           Control.Monad.Trans.Except     ( ExceptT
                                                , withExceptT
                                                , runExceptT
                                                )
import           Control.Monad.Trans.Reader     ( mapReaderT
                                                , withReaderT
                                                )

import           Crypto.Random.Types     (MonadRandom(..))

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 Network.Haskoin.Address (Address)
import Text.StringTemplate (directoryGroup, newSTMP, getStringTemplate, setManyAttrib, render)
import Filesystem.Path.CurrentOS (encodeString)

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           Network.Haskoin.Address        ( Address )
import           Text.StringTemplate            ( directoryGroup
                                                , newSTMP
                                                , getStringTemplate
                                                , setManyAttrib
                                                , render
                                                )
import           Filesystem.Path.CurrentOS      ( encodeString )

import Network.Bippy.Types (Satoshi)

import           Network.Bippy.Types            ( Satoshi )

import Aftok.Types            (User, UserId, ProjectId(..), userEmail, _Email)
import Aftok.Currency.Bitcoin (NetworkId, satoshi)
import qualified Aftok.Config as AC
import Aftok.Billables  (Billable, Billable', Subscription', 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

import           Aftok.Types                    ( User
                                                , UserId
                                                , ProjectId(..)
                                                , userEmail
                                                , _Email
                                                )
import           Aftok.Currency.Bitcoin         ( NetworkId
                                                , satoshi
                                                )
import qualified Aftok.Config                  as AC
import           Aftok.Billables                ( Billable
                                                , Billable'
                                                , Subscription'
                                                , 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

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

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

  void . runExceptT $ (runReaderT . runAftokM) createProjectsPaymentRequests $ env

  void
    . runExceptT
    $ (runReaderT . runAftokM) createProjectsPaymentRequests
    $ env

    now <- liftIO C.getCurrentTime
    let ops = P.BillingOps memoGen (fmap Just . paymentURL) payloadGen
    subscribers <- liftQDBM $ DB.findSubscribers pid
    requests <- traverse (\uid -> P.createPaymentRequests ops now uid pid) $ subscribers
    traverse_ sendPaymentRequestEmail (join requests)

  now <- liftIO C.getCurrentTime
  let ops = P.BillingOps memoGen (fmap Just . paymentURL) payloadGen
  subscribers <- liftQDBM $ DB.findSubscribers pid
  requests    <-
    traverse (\uid -> P.createPaymentRequests ops now uid pid) $ subscribers
  traverse_ sendPaymentRequestEmail (join requests)

  let AC.SmtpConfig{..} = cfg ^. (dcfg . D.smtpConfig)
      preqCfg = cfg ^. (dcfg . D.paymentRequestConfig)
      reqMay = do
        preq <- DB.findPaymentRequestId reqId
        preq' <- traverseOf P.subscription DB.findSubscriptionBillable preq

  let AC.SmtpConfig {..} = cfg ^. (dcfg . D.smtpConfig)
      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 (NetworkId, Address)) (Billable' Project UserId Satoshi))
                         -> URI
                         -> m Mime.Mail

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

  let billTemplate = (newSTMP . T.unpack) <$> req ^. (subscription . billable . paymentRequestEmailTemplate)

  let billTemplate =
        (newSTMP . T.unpack)
          <$> req
          ^.  (subscription . billable . paymentRequestEmailTemplate)

    Nothing -> throwError $ ConfigError "Could not find template for invitation email"

    Nothing ->
      throwError $ ConfigError "Could not find template for invitation email"

          toEmail = req ^. (subscription . customer . userEmail)
          pname = req ^. (subscription . billable . project . projectName)
          total = req ^. (P.paymentRequest . to paymentRequestTotal)
          setAttrs = setManyAttrib
            [ ("from_email", fromEmail ^. _Email)

          toEmail   = req ^. (subscription . customer . userEmail)
          pname     = req ^. (subscription . billable . project . projectName)
          total     = req ^. (P.paymentRequest . to paymentRequestTotal)
          setAttrs  = setManyAttrib
            [ ("from_email"  , fromEmail ^. _Email)

            , ("to_email", toEmail ^. _Email)
            , ("amount_due", show $ total ^. satoshi)
            , ("payment_url", show paymentUrl)

            , ("to_email"    , toEmail ^. _Email)
            , ("amount_due"  , show $ total ^. satoshi)
            , ("payment_url" , show paymentUrl)

          subject  = "Payment is due for your "<>pname<>" subscription!"

          subject  = "Payment is due for your " <> pname <> " subscription!"

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

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

  let template = (newSTMP . T.unpack) <$> (sub ^. (billable . paymentRequestMemoTemplate))

  let template =
        (newSTMP . T.unpack)
          <$> (sub ^. (billable . paymentRequestMemoTemplate))

        , ("issue_time", show requestTime)

        , ("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           Control.Lens

import Database.PostgreSQL.Simple    (ConnectInfo)
import Filesystem.Path.CurrentOS (fromText, encodeString)
import qualified Filesystem.Path.CurrentOS as P

import           Database.PostgreSQL.Simple     ( ConnectInfo )
import           Filesystem.Path.CurrentOS      ( fromText
                                                , encodeString
                                                )
import qualified Filesystem.Path.CurrentOS     as P

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

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

loadConfig cfgFile =
  readConfig =<< C.load [C.Required $ encodeString cfgFile]

loadConfig cfgFile = readConfig =<< C.load [C.Required $ encodeString cfgFile]

readConfig cfg = Config
  <$> (AC.readSmtpConfig $ C.subconfig "smtp" cfg)
  <*> (AC.readBillingConfig $ C.subconfig "billing" cfg)
  <*> (AC.readConnectInfo $ C.subconfig "db" cfg)
  <*> (readPaymentRequestConfig $ C.subconfig "payment_requests" cfg)

readConfig cfg =
  Config
    <$> (AC.readSmtpConfig $ C.subconfig "smtp" cfg)
    <*> (AC.readBillingConfig $ C.subconfig "billing" cfg)
    <*> (AC.readConnectInfo $ C.subconfig "db" cfg)
    <*> (readPaymentRequestConfig $ C.subconfig "payment_requests" cfg)

readPaymentRequestConfig cfg = PaymentRequestConfig
  <$> C.require cfg "aftok_host"
  <*> (fromText <$> C.require cfg "template_path")
  <*> (Email <$> C.require cfg "payment_from_email")

readPaymentRequestConfig cfg =
  PaymentRequestConfig
    <$> C.require cfg "aftok_host"
    <*> (fromText <$> C.require cfg "template_path")
    <*> (Email <$> C.require cfg "payment_from_email")

module Main (main) where

module Main
  ( main
  )
where

import Control.Exception (try)
import System.Environment            (getEnv)
import System.IO.Error            (IOError)
import Filesystem.Path.CurrentOS (decodeString)

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)

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           Data.Hourglass (Seconds(..))
import           Data.Ratio ((%))
import           Data.Traversable (for)
import           Data.Thyme.Clock    as C
import           Data.Thyme.Format   ()

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

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

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

bidsTotal bids =
  foldl' (\s b -> s <> (b^.bidAmount)) (Satoshi 0) bids

bidsTotal bids = foldl' (\s b -> s <> (b ^. bidAmount)) (Satoshi 0) bids

bidOrder =
  comparing costRatio `mappend` comparing (^. bidTime)
  where
    secs bid = toRational $ bid ^. bidSeconds
    btc  bid = toRational $ bid ^. bidAmount . satoshi
    costRatio bid = secs bid / btc bid

bidOrder = comparing costRatio `mappend` comparing (^. bidTime)
 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

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

      -- 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 _ [] = []

    takeWinningBids _ [] = []

      submittedTotal = bidsTotal bids
  in  maybe
        (WinningBids $ takeWinningBids (Satoshi 0) $ sortBy bidOrder bids)
        InsufficientBids
        (raiseAmount' `ssub` submittedTotal)

    submittedTotal = bidsTotal bids
  in
    maybe (WinningBids $ takeWinningBids (Satoshi 0) $ sortBy bidOrder bids)
          InsufficientBids
          (raiseAmount' `ssub` submittedTotal)

      put (x <> bid ^. bidAmount) >>
      (pure . Just $ Commitment bid (bid ^. bidSeconds) (bid ^. bidAmount))

      put (x <> bid ^. bidAmount)
        >> (pure . Just $ Commitment bid (bid ^. bidSeconds) (bid ^. bidAmount))

          remainderSeconds (Satoshi r) = Seconds . round $ winFraction r * fromIntegral (bid ^. bidSeconds)

          remainderSeconds (Satoshi r) =
              Seconds . round $ winFraction r * fromIntegral (bid ^. bidSeconds)

            put (x <> remainder) *>
            (pure $ Commitment bid (remainderSeconds remainder) remainder)

            put (x <> remainder)
              *> (pure $ Commitment bid (remainderSeconds remainder) remainder)

import Control.Lens (makeClassy, (^.))

import           Control.Lens                   ( makeClassy
                                                , (^.)
                                                )

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           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           Aftok.Currency.Bitcoin         ( NetworkMode )
import           Aftok.Payments                 ( PaymentsConfig(..) )

  SmtpConfig <$> C.require cfg "smtpHost"
             <*> ((fmap . fmap) fromInteger $ C.lookup cfg "smtpPort")
             <*> C.require cfg "smtpUser"
             <*> C.require cfg "smtpKey"

  SmtpConfig
    <$> C.require cfg "smtpHost"
    <*> ((fmap . fmap) fromInteger $ C.lookup cfg "smtpPort")
    <*> C.require cfg "smtpUser"
    <*> C.require cfg "smtpKey"

  BillingConfig <$> C.require cfg "networkMode"
                <*> (fromText <$> C.require cfg "signingKeyFile")
                <*> (fromText <$> C.require cfg "certsFile")
                <*> C.require cfg "exchangeRateServiceURI"

  BillingConfig
    <$> C.require cfg "networkMode"
    <*> (fromText <$> C.require cfg "signingKeyFile")
    <*> (fromText <$> C.require cfg "certsFile")
    <*> C.require cfg "exchangeRateServiceURI"

  ConnectInfo <$> C.require cfg "host"
              <*> C.require cfg "port"
              <*> C.require cfg "user"
              <*> C.require cfg "password"
              <*> C.require cfg "database"

  ConnectInfo
    <$> C.require cfg "host"
    <*> C.require cfg "port"
    <*> C.require cfg "user"
    <*> C.require cfg "password"
    <*> C.require cfg "database"

  privKey <- case headMay privKeys of

  privKey    <- case headMay privKeys of

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

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

import qualified Data.Configurator.Types as C

import qualified Data.Configurator.Types       as C

import           Network.Bippy.Types (Satoshi (..))

import           Network.Bippy.Types            ( Satoshi(..) )

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

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

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

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

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

module Aftok.Database.PostgreSQL (QDBM(..), runQDBM) where

module Aftok.Database.PostgreSQL
  ( QDBM(..)
  , runQDBM
  )
where

import           Prelude                              hiding (null)

import           Prelude                 hiding ( null )

import           Control.Monad.Trans.Except           (ExceptT(..), throwE, runExceptT)
import           Crypto.Random.Types                  (MonadRandom,
                                                       getRandomBytes)
import           Data.Aeson                           (Value, toJSON)

import           Control.Monad.Trans.Except     ( ExceptT(..)
                                                , throwE
                                                , runExceptT
                                                )
import           Crypto.Random.Types            ( MonadRandom
                                                , getRandomBytes
                                                )
import           Data.Aeson                     ( Value
                                                , toJSON
                                                )

import qualified Data.List                            as L
import           Data.ProtocolBuffers                 (decodeMessage,
                                                       encodeMessage)
import           Data.Serialize.Get                   (runGet)
import           Data.Serialize.Put                   (runPut)
import           Data.Thyme.Clock                     as C

import qualified Data.List                     as L
import           Data.ProtocolBuffers           ( decodeMessage
                                                , encodeMessage
                                                )
import           Data.Serialize.Get             ( runGet )
import           Data.Serialize.Put             ( runPut )
import           Data.Thyme.Clock              as C

import           Data.UUID                            (UUID)

import           Data.UUID                      ( UUID )

import           Database.PostgreSQL.Simple.SqlQQ     (sql)
import           Database.PostgreSQL.Simple.Types     (Null)
import           Safe                                 (headMay)

import           Database.PostgreSQL.Simple.SqlQQ
                                                ( sql )
import           Database.PostgreSQL.Simple.Types
                                                ( Null )
import           Safe                           ( headMay )

import qualified Aftok.Auction                        as A
import qualified Aftok.Billables                      as B

import qualified Aftok.Auction                 as A
import qualified Aftok.Billables               as B

import           Aftok.Database.PostgreSQL.Types      (SerDepFunction(..))

import           Aftok.Database.PostgreSQL.Types
                                                ( SerDepFunction(..) )

import           Aftok.Json                           (billableJSON,
                                                       createSubscriptionJSON,
                                                       paymentJSON,
                                                       paymentRequestJSON)

import           Aftok.Json                     ( billableJSON
                                                , createSubscriptionJSON
                                                , paymentJSON
                                                , paymentRequestJSON
                                                )

import qualified Aftok.Project                        as P

import qualified Aftok.Project                 as P

import           Network.Bippy.Types                  (Satoshi(..))
import           Network.Haskoin.Address              (Address, stringToAddr, addrToString)
import           Network.Haskoin.Constants            (Network)

import           Network.Bippy.Types            ( Satoshi(..) )
import           Network.Haskoin.Address        ( Address
                                                , stringToAddr
                                                , addrToString
                                                )
import           Network.Haskoin.Constants      ( Network )

null =  field

null = field

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

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

  address <- fieldWith $ addrFieldParser (toNetwork mode networkId)

  address   <- fieldWith $ addrFieldParser (toNetwork mode networkId)

  let err = returnError ConversionFailed f "could not deserialize value to a valid BTC address"

  let err = returnError ConversionFailed
                        f
                        "could not deserialize value to a valid BTC address"

    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

nominalDiffTimeParser f v =
  C.fromSeconds' <$> fromField f v

nominalDiffTimeParser f v = C.fromSeconds' <$> fromField f v

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

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

  let parser :: Text -> RowParser (CreditTo (NetworkId, Address))
      parser "credit_to_address"  =
        CreditToCurrency <$> (addressParser mode <* nullField <* nullField)
      parser "credit_to_user"     =
        CreditToUser    <$> (nullField *> nullField *> idParser UserId <* nullField)
      parser "credit_to_project"  =
        CreditToProject <$> (nullField *> nullField *> nullField *> idParser ProjectId)
      parser _ = empty
  in 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

  let
    parser :: Text -> RowParser (CreditTo (NetworkId, Address))
    parser "credit_to_address" =
      CreditToCurrency <$> (addressParser mode <* nullField <* nullField)
    parser "credit_to_user" =
      CreditToUser <$> (nullField *> nullField *> idParser UserId <* nullField)
    parser "credit_to_project" =
      CreditToProject
        <$> (nullField *> nullField *> nullField *> idParser ProjectId)
    parser _ = empty
  in
    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

  LogEntry <$> creditToParser mode
           <*> (fieldWith eventTypeParser <*> utcParser)
           <*> field

  LogEntry
    <$> creditToParser mode
    <*> (fieldWith eventTypeParser <*> utcParser)
    <*> field

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

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

  (,,) <$> idParser ProjectId
       <*> idParser UserId
       <*> logEntryParser mode

  (,,) <$> idParser ProjectId <*> idParser UserId <*> logEntryParser mode

  A.Auction <$> idParser ProjectId
            <*> idParser UserId
            <*> utcParser
            <*> btcParser
            <*> utcParser
            <*> utcParser

  A.Auction
    <$> idParser ProjectId
    <*> idParser UserId
    <*> utcParser
    <*> btcParser
    <*> utcParser
    <*> utcParser

  A.Bid <$> idParser UserId
        <*> (Seconds <$> field)
        <*> btcParser
        <*> utcParser

  A.Bid <$> idParser UserId <*> (Seconds <$> field) <*> btcParser <*> utcParser

  User <$> (UserName <$> field)
       <*> ((null *> null *> pure Nothing) <|> fmap Just (addressParser mode))
       <*> (Email <$> field)

  User
    <$> (UserName <$> field)
    <*> ((null *> null *> pure Nothing) <|> fmap Just (addressParser mode))
    <*> (Email <$> field)

  P.Project <$> field
            <*> utcParser
            <*> idParser UserId
            <*> (unSerDepFunction <$> fieldWith fromJSONField)

  P.Project
    <$> field
    <*> utcParser
    <*> idParser UserId
    <*> (unSerDepFunction <$> fieldWith fromJSONField)

  P.Invitation <$> idParser ProjectId
               <*> idParser UserId
               <*> fmap Email field
               <*> utcParser
               <*> fmap (fmap toThyme) field

  P.Invitation
    <$> idParser ProjectId
    <*> idParser UserId
    <*> fmap Email field
    <*> utcParser
    <*> fmap (fmap toThyme) field

  B.Billable <$> idParser ProjectId
             <*> idParser UserId
             <*> field
             <*> field
             <*> recurrenceParser
             <*> btcParser
             <*> field
             <*> fieldWith (optionalField nominalDiffTimeParser)
             <*> field
             <*> field

  B.Billable
    <$> idParser ProjectId
    <*> idParser UserId
    <*> field
    <*> field
    <*> recurrenceParser
    <*> btcParser
    <*> field
    <*> fieldWith (optionalField nominalDiffTimeParser)
    <*> field
    <*> field

  B.Subscription <$> idParser UserId
                 <*> idParser B.BillableId
                 <*> (toThyme <$> field)
                 <*> ((fmap toThyme) <$> field)

  B.Subscription
    <$> idParser UserId
    <*> idParser B.BillableId
    <*> (toThyme <$> field)
    <*> ((fmap toThyme) <$> field)

  PaymentRequest <$> fmap B.SubscriptionId field
                 <*> ((either (const empty) pure . runGet decodeMessage) =<< field)
                 <*> fmap PaymentKey field
                 <*> fmap toThyme field
                 <*> fmap toThyme field

  PaymentRequest
    <$> fmap B.SubscriptionId field
    <*> ((either (const empty) pure . runGet decodeMessage) =<< field)
    <*> fmap PaymentKey field
    <*> fmap toThyme    field
    <*> fmap toThyme    field

  Payment <$> (PaymentRequestId <$> field)
          <*> (field >>= (either (const empty) pure . runGet decodeMessage))
          <*> (toThyme <$> field)
          <*> field

  Payment
    <$> (PaymentRequestId <$> field)
    <*> (field >>= (either (const empty) pure . runGet decodeMessage))
    <*> (toThyme <$> field)
    <*> field

storeEvent (CreateSubscription uid bid t) =
  Just $ storeEventJSON (Just uid) "create_subscription" (createSubscriptionJSON uid bid t)

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 (CreatePaymentRequest req) = Just
  $ storeEventJSON Nothing "create_payment_request" (paymentRequestJSON req)

  pinsert EventId

  pinsert
    EventId

pgEval (CreateEvent (ProjectId pid) (UserId uid) (LogEntry c e m)) =
  case c of
    CreditToCurrency (nid, addr) -> do
      mode <- askNetworkMode
      let network = toNetwork mode nid
      pinsert EventId
        [sql| INSERT INTO work_events

pgEval (CreateEvent (ProjectId pid) (UserId uid) (LogEntry c e m)) = case c of
  CreditToCurrency (nid, addr) -> do
    mode <- askNetworkMode
    let network = toNetwork mode nid
    pinsert
      EventId
      [sql| INSERT INTO work_events

        ( pid
        , uid
        , creditToName c
        , addrToString network addr
        , eventName e
        , fromThyme $ e ^. eventTime
        , m
        )

      ( pid
      , uid
      , creditToName c
      , addrToString 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)

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

    CreditToUser uid' ->
      pinsert EventId
        [sql| INSERT INTO work_events

  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)

  headMay <$> pquery
    (qdbLogEntryParser mode)

  let q (Before e) = pquery (logEntryParser mode)
        [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id,

  let
    q (Before e) = pquery
      (logEntryParser mode)
      [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id,

        (pid, uid, fromThyme e)
      q (During s e) = pquery (logEntryParser mode)
        [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id,

      (pid, uid, fromThyme e)
    q (During s e) = pquery
      (logEntryParser mode)
      [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id,

        (pid, uid, fromThyme s, fromThyme e)
      q (After s) = pquery (logEntryParser mode)
        [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id,

      (pid, uid, fromThyme s, fromThyme e)
    q (After s) = pquery
      (logEntryParser mode)
      [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id,

        (pid, uid, fromThyme s)

      (pid, uid, fromThyme s)

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

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)

      pinsert AmendmentId

      pinsert
        AmendmentId

        ( eid, fromThyme $ mt ^. _ModTime, creditToName c, addrToString network addr )

        ( eid
        , fromThyme $ mt ^. _ModTime
        , creditToName c
        , addrToString 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 )

      (eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. _ProjectId)

    CreditToUser uid ->
      pinsert AmendmentId
        [sql| INSERT INTO event_credit_to_amendments

    CreditToUser uid -> pinsert
      AmendmentId
      [sql| INSERT INTO event_credit_to_amendments

        ( eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId )

      (eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId)

pgEval (AmendEvent (EventId eid) (MetadataChange mt v)) =
  pinsert AmendmentId
    [sql| INSERT INTO event_metadata_amendments

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)

  mode       <- askNetworkMode
  logEntries <- pquery
    (logEntryParser mode)

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

  ( 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

pgEval (FindAuction aucId) = headMay <$> pquery
  auctionParser
  [sql| SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time

    (Only (aucId ^. A._AuctionId))

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

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

  ( aucId
  , bid ^. (A.bidUser . _UserId)
  , case bid ^. A.bidSeconds of
    (Seconds i) -> i
  , bid ^. (A.bidAmount . satoshi)
  , bid ^. (A.bidTime . to fromThyme)
  )

pgEval (FindBids aucId) =
  pquery ((,) <$> idParser A.BidId <*> bidParser)
    [sql| SELECT id, bidder_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ? |]
    (Only (aucId ^. A._AuctionId))

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

  pinsert UserId

  pinsert
    UserId

    ( user' ^. (username._UserName)

    ( user' ^. (username . _UserName)

    , user' ^. userEmail._Email

    , user' ^. userEmail . _Email

  headMay <$> pquery (userParser mode)

  headMay <$> pquery
    (userParser mode)

  headMay <$> pquery ((,) <$> idParser UserId <*> userParser mode)

  headMay <$> pquery
    ((,) <$> idParser UserId <*> userParser mode)

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)

pgEval (CreateProject p) =
  pinsert ProjectId
    [sql| INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn)

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
  )

  pquery (idParser ProjectId)
    [sql| SELECT id FROM projects |]
    ()

  pquery (idParser ProjectId) [sql| SELECT id FROM projects |] ()

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

  (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 (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 p.id, p.project_name, p.inception_date, p.initiator_id, p.depreciation_fn

pgEval (FindUserProjects (UserId uid)) = pquery
  ((,) <$> idParser ProjectId <*> projectParser)
  [sql| SELECT p.id, p.project_name, p.inception_date, p.initiator_id, p.depreciation_fn

    (uid, uid)

  (uid, uid)

pgEval (AddUserToProject pid current new) = void $
  pexec
    [sql| INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?) |]
    (pid ^. _ProjectId, new ^. _UserId, current ^. _UserId)

pgEval (AddUserToProject pid current new) = void $ pexec
  [sql| INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?) |]
  (pid ^. _ProjectId, new ^. _UserId, current ^. _UserId)

  pinsert B.BillableId

  pinsert
    B.BillableId

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

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

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

  pinsert B.SubscriptionId

  pinsert
    B.SubscriptionId

    ( view _UserId uid

    ( view _UserId       uid

    , view _EventId eventId

    , view _EventId      eventId

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

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

    (Only (sid ^. B._SubscriptionId))

  (Only (sid ^. B._SubscriptionId))

pgEval (FindSubscriptions uid pid) =
  pquery ((,) <$> idParser B.SubscriptionId <*> subscriptionParser)
    [sql| SELECT s.id, user_id, billable_id, start_date, end_date

pgEval (FindSubscriptions uid pid) = pquery
  ((,) <$> idParser B.SubscriptionId <*> subscriptionParser)
  [sql| SELECT s.id, user_id, billable_id, start_date, end_date

    (uid ^. _UserId, pid ^. _ProjectId)

  (uid ^. _UserId, pid ^. _ProjectId)

  pinsert PaymentRequestId

  pinsert
    PaymentRequestId

pgEval (FindPaymentRequest (PaymentKey k)) =
  headMay <$> pquery ((,) <$> idParser PaymentRequestId <*> paymentRequestParser)

pgEval (FindPaymentRequest (PaymentKey k)) = headMay <$> pquery
  ((,) <$> idParser PaymentRequestId <*> paymentRequestParser)

pgEval (FindPaymentRequestId (PaymentRequestId prid)) =
  headMay <$> pquery paymentRequestParser

pgEval (FindPaymentRequestId (PaymentRequestId prid)) = headMay <$> pquery
  paymentRequestParser

pgEval (FindPaymentRequests sid) =
  pquery ((,) <$> idParser PaymentRequestId <*> paymentRequestParser)

pgEval (FindPaymentRequests sid) = pquery
  ((,) <$> idParser PaymentRequestId <*> paymentRequestParser)

      rowp = (,,,) <$> (PaymentKey <$> field)
                   <*> paymentRequestParser
                   <*> subscriptionParser
                   <*> billableParser
  in  pquery rowp
      [sql| SELECT r.url_key,

      rowp =
          (,,,)
            <$> (PaymentKey <$> field)
            <*> paymentRequestParser
            <*> subscriptionParser
            <*> billableParser
  in  pquery
        rowp
        [sql| SELECT r.url_key,

      (Only (sid ^. B._SubscriptionId))

        (Only (sid ^. B._SubscriptionId))

  pinsert PaymentId

  pinsert
    PaymentId

pgEval (FindPayments rid) =
  pquery ((,) <$> idParser PaymentId <*> paymentParser)

pgEval (FindPayments rid) = pquery
  ((,) <$> idParser PaymentId <*> paymentParser)

import           Control.Lens              (view, (^.), makeClassyPrisms, traverseOf)
import           Control.Monad.Trans.Maybe (MaybeT (..))

import           Control.Lens                   ( view
                                                , (^.)
                                                , makeClassyPrisms
                                                , traverseOf
                                                )
import           Control.Monad.Trans.Maybe      ( MaybeT(..) )

import           Data.Thyme.Clock          as C
import           Data.Thyme.Time           as T (Day)
import           Safe (headMay)

import           Data.Thyme.Clock              as C
import           Data.Thyme.Time               as T
                                                ( Day )
import           Safe                           ( headMay )

import           Aftok.Auction             as A
import           Aftok.Billables           as B
import           Aftok.Currency.Bitcoin    (NetworkId)

import           Aftok.Auction                 as A
import           Aftok.Billables               as B
import           Aftok.Currency.Bitcoin         ( NetworkId )

import           Aftok.Project             as P

import           Aftok.Project                 as P

import           Network.Haskoin.Address   (Address)

import           Network.Haskoin.Address        ( Address )

type InvitingUID     = UserId
type InvitedUID      = UserId

type InvitingUID = UserId
type InvitedUID = UserId

  CreateUser       :: BTCUser -> DBOp UserId
  FindUser         :: UserId -> DBOp (Maybe BTCUser)
  FindUserByName   :: UserName -> DBOp (Maybe (UserId, BTCUser))

  CreateUser       ::BTCUser -> DBOp UserId
  FindUser         ::UserId -> DBOp (Maybe BTCUser)
  FindUserByName   ::UserName -> DBOp (Maybe (UserId, BTCUser))

  CreateProject    :: Project -> DBOp ProjectId
  FindProject      :: ProjectId -> DBOp (Maybe Project)
  ListProjects     :: DBOp [ProjectId]
  FindSubscribers  :: ProjectId -> DBOp [UserId]
  FindUserProjects :: UserId -> DBOp [(ProjectId, Project)]
  AddUserToProject :: ProjectId -> InvitingUID -> InvitedUID -> DBOp ()
  CreateInvitation :: ProjectId -> InvitingUID -> Email -> C.UTCTime -> DBOp InvitationCode
  FindInvitation   :: InvitationCode -> DBOp (Maybe Invitation)
  AcceptInvitation :: UserId -> InvitationCode -> C.UTCTime -> DBOp ()

  CreateProject    ::Project -> DBOp ProjectId
  FindProject      ::ProjectId -> DBOp (Maybe Project)
  ListProjects     ::DBOp [ProjectId]
  FindSubscribers  ::ProjectId -> DBOp [UserId]
  FindUserProjects ::UserId -> DBOp [(ProjectId, Project)]
  AddUserToProject ::ProjectId -> InvitingUID -> InvitedUID -> DBOp ()
  CreateInvitation ::ProjectId -> InvitingUID -> Email -> C.UTCTime -> DBOp InvitationCode
  FindInvitation   ::InvitationCode -> DBOp (Maybe Invitation)
  AcceptInvitation ::UserId -> InvitationCode -> C.UTCTime -> DBOp ()

  CreateEvent      :: ProjectId -> UserId -> LogEntry BTCNet -> DBOp EventId
  AmendEvent       :: EventId -> EventAmendment BTCNet -> DBOp AmendmentId
  FindEvent        :: EventId -> DBOp (Maybe (KeyedLogEntry BTCNet))
  FindEvents       :: ProjectId -> UserId -> Interval' -> DBOp [LogEntry BTCNet]
  ReadWorkIndex    :: ProjectId -> DBOp (WorkIndex BTCNet)

  CreateEvent      ::ProjectId -> UserId -> LogEntry BTCNet -> DBOp EventId
  AmendEvent       ::EventId -> EventAmendment BTCNet -> DBOp AmendmentId
  FindEvent        ::EventId -> DBOp (Maybe (KeyedLogEntry BTCNet))
  FindEvents       ::ProjectId -> UserId -> Interval' -> DBOp [LogEntry BTCNet]
  ReadWorkIndex    ::ProjectId -> DBOp (WorkIndex BTCNet)

  CreateAuction    :: Auction -> DBOp AuctionId
  FindAuction      :: AuctionId -> DBOp (Maybe Auction)
  CreateBid        :: AuctionId -> Bid -> DBOp BidId
  FindBids         :: AuctionId -> DBOp [(BidId, Bid)]

  CreateAuction    ::Auction -> DBOp AuctionId
  FindAuction      ::AuctionId -> DBOp (Maybe Auction)
  CreateBid        ::AuctionId -> Bid -> DBOp BidId
  FindBids         ::AuctionId -> DBOp [(BidId, Bid)]

  CreateBillable   :: UserId -> Billable -> DBOp BillableId
  FindBillable     :: BillableId -> DBOp (Maybe Billable)
  FindBillables    :: ProjectId  -> DBOp [(BillableId, Billable)]

  CreateBillable   ::UserId -> Billable -> DBOp BillableId
  FindBillable     ::BillableId -> DBOp (Maybe Billable)
  FindBillables    ::ProjectId  -> DBOp [(BillableId, Billable)]

  CreateSubscription :: UserId -> BillableId -> T.Day -> DBOp SubscriptionId
  FindSubscription   :: SubscriptionId -> DBOp (Maybe Subscription)
  FindSubscriptions  :: UserId -> ProjectId -> DBOp [(SubscriptionId, Subscription)]

  CreateSubscription ::UserId -> BillableId -> T.Day -> DBOp SubscriptionId
  FindSubscription   ::SubscriptionId -> DBOp (Maybe Subscription)
  FindSubscriptions  ::UserId -> ProjectId -> DBOp [(SubscriptionId, Subscription)]

  CreatePaymentRequest  :: PaymentRequest -> DBOp PaymentRequestId
  FindPaymentRequests   :: SubscriptionId -> DBOp [(PaymentRequestId, PaymentRequest)]
  FindUnpaidRequests    :: SubscriptionId -> DBOp [BillDetail]
  FindPaymentRequest    :: PaymentKey -> DBOp (Maybe (PaymentRequestId, PaymentRequest))
  FindPaymentRequestId  :: PaymentRequestId -> DBOp (Maybe PaymentRequest)

  CreatePaymentRequest  ::PaymentRequest -> DBOp PaymentRequestId
  FindPaymentRequests   ::SubscriptionId -> DBOp [(PaymentRequestId, PaymentRequest)]
  FindUnpaidRequests    ::SubscriptionId -> DBOp [BillDetail]
  FindPaymentRequest    ::PaymentKey -> DBOp (Maybe (PaymentRequestId, PaymentRequest))
  FindPaymentRequestId  ::PaymentRequestId -> DBOp (Maybe PaymentRequest)

  CreatePayment  :: Payment -> DBOp PaymentId
  FindPayments   :: PaymentRequestId -> DBOp [(PaymentId, Payment)]

  CreatePayment  ::Payment -> DBOp PaymentId
  FindPayments   ::PaymentRequestId -> DBOp [(PaymentId, Payment)]

findProjectOrError pid = fromMaybeT
  (raiseSubjectNotFound $ FindProject pid)
  (findProject pid)

findProjectOrError pid =
  fromMaybeT (raiseSubjectNotFound $ FindProject pid) (findProject pid)

addUserToProject :: (MonadDB m) => ProjectId -> InvitingUID -> InvitedUID -> m ()

addUserToProject
  :: (MonadDB m) => ProjectId -> InvitingUID -> InvitedUID -> m ()

createInvitation :: (MonadDB m) => ProjectId -> InvitingUID -> Email -> C.UTCTime -> m InvitationCode

createInvitation
  :: (MonadDB m)
  => ProjectId
  -> InvitingUID
  -> Email
  -> C.UTCTime
  -> m InvitationCode

acceptInvitation :: (MonadDB m) => UserId -> C.UTCTime -> InvitationCode-> m ()

acceptInvitation :: (MonadDB m) => UserId -> C.UTCTime -> InvitationCode -> m ()

    Nothing ->
      raiseSubjectNotFound act

    Nothing -> raiseSubjectNotFound act

    Just i ->
      withProjectAuth (i ^. P.projectId) (i ^. P.invitingUser) act

    Just i -> withProjectAuth (i ^. P.projectId) (i ^. P.invitingUser) act

createEvent :: (MonadDB m) => ProjectId -> UserId -> LogEntry BTCNet -> m EventId

createEvent
  :: (MonadDB m) => ProjectId -> UserId -> LogEntry BTCNet -> m EventId

amendEvent :: (MonadDB m) => UserId -> EventId -> EventAmendment BTCNet -> m AmendmentId

amendEvent
  :: (MonadDB m) => UserId -> EventId -> EventAmendment BTCNet -> m AmendmentId

  let act = AmendEvent eid a

  let act       = AmendEvent eid a

  maybe missing (\(_, uid', _) -> if uid' == uid then liftdb act else forbidden) ev

  maybe missing
        (\(_, uid', _) -> if uid' == uid then liftdb act else forbidden)
        ev

findEvents :: (MonadDB m) => ProjectId -> UserId -> Interval' -> m [LogEntry BTCNet]

findEvents
  :: (MonadDB m) => ProjectId -> UserId -> Interval' -> m [LogEntry BTCNet]

findSubscriptions :: (MonadDB m) => UserId -> ProjectId -> m [(SubscriptionId, Subscription)]

findSubscriptions
  :: (MonadDB m) => UserId -> ProjectId -> m [(SubscriptionId, Subscription)]

findSubscriptionBillable :: (MonadDB m) => SubscriptionId -> MaybeT m (Subscription' UserId Billable)

findSubscriptionBillable
  :: (MonadDB m) => SubscriptionId -> MaybeT m (Subscription' UserId Billable)

findPaymentRequests :: (MonadDB m) => SubscriptionId -> m [(PaymentRequestId, PaymentRequest)]

findPaymentRequests
  :: (MonadDB m) => SubscriptionId -> m [(PaymentRequestId, PaymentRequest)]

findPaymentRequest :: (MonadDB m) => PaymentKey -> MaybeT m (PaymentRequestId, PaymentRequest)

findPaymentRequest
  :: (MonadDB m) => PaymentKey -> MaybeT m (PaymentRequestId, PaymentRequest)

findPaymentRequestId :: (MonadDB m) => PaymentRequestId -> MaybeT m PaymentRequest

findPaymentRequestId
  :: (MonadDB m) => PaymentRequestId -> MaybeT m PaymentRequest

    auc <- MaybeT $ liftdb findOp
    _ <- lift $ checkProjectAuth (auc ^. A.projectId) uid findOp
    pure auc

        auc <- MaybeT $ liftdb findOp
        _   <- lift $ checkProjectAuth (auc ^. A.projectId) uid findOp
        pure auc

    maybeAuc <- liftdb findOp
    _ <- traverse (\auc -> checkProjectAuth (auc ^. A.projectId) uid findOp) maybeAuc
    maybe (raiseSubjectNotFound findOp) pure maybeAuc

        maybeAuc <- liftdb findOp
        _        <- traverse
          (\auc -> checkProjectAuth (auc ^. A.projectId) uid findOp)
          maybeAuc
        maybe (raiseSubjectNotFound findOp) pure maybeAuc

    auc <- findAuction' aid uid
    if view bidTime bid > view auctionEnd auc
      then raiseOpForbidden uid AuctionEnded createOp
      else liftdb createOp

        auc <- findAuction' aid uid
        if view bidTime bid > view auctionEnd auc
          then raiseOpForbidden uid AuctionEnded createOp
          else liftdb createOp

  ( Interval(..), interval, start, end, ilen
  , Interval'(..), interval', start', end'
  , intervalJSON, parseIntervalJSON

  ( Interval(..)
  , interval
  , start
  , end
  , ilen
  , Interval'(..)
  , interval'
  , start'
  , end'
  , intervalJSON
  , parseIntervalJSON

  ) where

  )
where

import           Control.Lens            (makeLenses, (^.))

import           Control.Lens                   ( makeLenses
                                                , (^.)
                                                )

import           Data.Thyme.Clock        as C
import           Data.Thyme.Format.Aeson ()
import           Data.Thyme.LocalTime    ()

import           Data.Thyme.Clock              as C
import           Data.Thyme.Format.Aeson        ( )
import           Data.Thyme.LocalTime           ( )

import           Control.FromSum                  (fromMaybeM, fromEitherM)
import           Control.Lens                     hiding ((.=))
import           Control.Monad.Fail               (MonadFail(..))

import           Control.FromSum                ( fromMaybeM
                                                , fromEitherM
                                                )
import           Control.Lens            hiding ( (.=) )
import           Control.Monad.Fail             ( MonadFail(..) )

import qualified Data.Attoparsec.ByteString.Char8 as PC
import qualified Data.ByteString.Base64           as B64
import qualified Data.ByteString.Char8            as C

import qualified Data.Attoparsec.ByteString.Char8
                                               as PC
import qualified Data.ByteString.Base64        as B64
import qualified Data.ByteString.Char8         as C

import           Data.HashMap.Strict              as O
import           Data.List.NonEmpty               as L
import           Data.Map.Strict                  as MS
import           Data.ProtocolBuffers             (encodeMessage)
import           Data.Serialize.Put               (runPut)
import qualified Data.Text                        as T
import qualified Data.Text.Encoding               as T
import           Data.Thyme.Calendar              (showGregorian)
import           Data.Thyme.Clock                 as Clock
import           Data.Thyme.Time                  (Day)
import           Data.UUID                        as U

import           Data.HashMap.Strict           as O
import           Data.List.NonEmpty            as L
import           Data.Map.Strict               as MS
import           Data.ProtocolBuffers           ( encodeMessage )
import           Data.Serialize.Put             ( runPut )
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as T
import           Data.Thyme.Calendar            ( showGregorian )
import           Data.Thyme.Clock              as Clock
import           Data.Thyme.Time                ( Day )
import           Data.UUID                     as U

import           Network.Haskoin.Address          (Address, addrToJSON, addrFromJSON, stringToAddr)

import           Network.Haskoin.Address        ( Address
                                                , addrToJSON
                                                , addrFromJSON
                                                , stringToAddr
                                                )

import           Aftok.Auction                    as A
import qualified Aftok.Billables                  as B

import           Aftok.Auction                 as A
import qualified Aftok.Billables               as B

import           Aftok.Payments.Types             (BillDetail)
import           Aftok.Project                    as P

import           Aftok.Payments.Types           ( BillDetail )
import           Aftok.Project                 as P

import           Aftok.Util                       (traverseKeys)

import           Aftok.Util                     ( traverseKeys )

import qualified Language.Haskell.TH              as TH

import qualified Language.Haskell.TH           as TH

printVersion Version{..} = T.intercalate "." $ fmap (T.pack . show) [majorVersion, minorVersion]

printVersion Version {..} =
  T.intercalate "." $ fmap (T.pack . show) [majorVersion, minorVersion]

v = QuasiQuoter { quoteExp = quoteVersionExp
                , quotePat = error "Pattern quasiquotation of versions not supported."
                , quoteType = error "Type quasiquotation of versions not supported."
                , quoteDec = error "Dec quasiquotation of versions not supported."
                }

v = QuasiQuoter
  { quoteExp  = quoteVersionExp
  , quotePat  = error "Pattern quasiquotation of versions not supported."
  , quoteType = error "Type quasiquotation of versions not supported."
  , quoteDec  = error "Dec quasiquotation of versions not supported."
  }

versioned ver o = Object $ uncurry O.insert ("schemaVersion" .= printVersion ver) o

versioned ver o =
  Object $ uncurry O.insert ("schemaVersion" .= printVersion ver) o

badVersion :: forall v a. String -> Version -> v -> Parser a

badVersion :: forall v a . String -> Version -> v -> Parser a

  const . fail $ "Unrecognized " <> name <> " schema version: " <> T.unpack (printVersion ver)

  const . fail $ "Unrecognized " <> name <> " schema version: " <> T.unpack
    (printVersion ver)

idValue :: forall a. Lens' a UUID -> a -> Value

idValue :: forall a . Lens' a UUID -> a -> Value

idJSON :: forall a. Text -> Lens' a UUID -> a -> Value
idJSON t l a  = v1 $ obj [ t .=  idValue l a ]

idJSON :: forall a . Text -> Lens' a UUID -> a -> Value
idJSON t l a = v1 $ obj [t .= idValue l a]

qdbJSON name l f (xid, x) = v1 $
  obj [ (name <> "Id") .= idValue l xid
      , name .= f x
      ]

qdbJSON name l f (xid, x) =
  v1 $ obj [(name <> "Id") .= idValue l xid, name .= f x]

projectJSON p = v1 $
  obj [ "projectName"    .= (p ^. projectName)
      , "inceptionDate"  .= (p ^. inceptionDate)
      , "initiator"      .= (p ^. P.initiator . _UserId)
      ]

projectJSON p = v1 $ obj
  [ "projectName" .= (p ^. projectName)
  , "inceptionDate" .= (p ^. inceptionDate)
  , "initiator" .= (p ^. P.initiator . _UserId)
  ]

auctionJSON x = v1 $
  obj [ "projectId"    .= idValue (A.projectId._ProjectId) x
      , "initiator"    .= idValue (A.initiator._UserId) x
      , "raiseAmount"  .= (x ^. (raiseAmount . satoshi))
      ]

auctionJSON x = v1 $ obj
  [ "projectId" .= idValue (A.projectId . _ProjectId) x
  , "initiator" .= idValue (A.initiator . _UserId) x
  , "raiseAmount" .= (x ^. (raiseAmount . satoshi))
  ]

bidIdJSON pid = v1 $
  obj [ "bidId" .= (pid ^. _BidId) ]

bidIdJSON pid = v1 $ obj ["bidId" .= (pid ^. _BidId)]

creditToJSON nmode (CreditToCurrency (netId, addr)) =
  v2 $ obj [ "creditToAddress" .= addrToJSON (toNetwork nmode netId) addr
           , "creditToNetwork" .= renderNetworkId netId
           ]

creditToJSON nmode (CreditToCurrency (netId, addr)) = v2 $ obj
  [ "creditToAddress" .= addrToJSON (toNetwork nmode netId) addr
  , "creditToNetwork" .= renderNetworkId netId
  ]

  v2 $ obj [ "creditToUser"    .= idValue _UserId uid ]

  v2 $ obj ["creditToUser" .= idValue _UserId uid]

  v2 $ obj [ "creditToProject" .= projectIdJSON pid ]