ADD ./daemon      /opt/aftok/daemon

                      Aftok.Config

    , network                   

    , smtp-mail               
    , system-filepath

    , x509
    , x509-store

               , Aftok.Snaplet.Billing

    , system-filepath
    , text
    , thyme
    , transformers
    , uuid                
    , wreq        
    , x509
    , x509-store
Executable aftok-daemon
  default-language:   Haskell2010
  ghc-options:        -Wall -Werror
  hs-source-dirs:     daemon
  default-extensions: NoImplicitPrelude
                    , OverloadedStrings
                    , RecordWildCards
                    , ScopedTypeVariables
                    , KindSignatures
  main-is:            Main.hs
  other-modules:      AftokD
                    , AftokD.AftokM
  build-depends:      
      aftok
    , base
    , aeson
    , attoparsec
    , base64-bytestring
    , bytestring
    , bippy
    , cereal
    , classy-prelude            
    , containers
    , configurator              
    , cryptonite
    , either
    , errors
    , hourglass
    , HStringTemplate          
    , iso8601-time
    , HsOpenSSL
    , http-client
    , http-client-openssl
    , lens
    , mime-mail
    , mtl                     
    , network                   
    , network-uri
    , optparse-applicative      
    , postgresql-simple
    , protobuf
    , smtp-mail               
    , system-filepath

{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving       #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
module AftokD.AftokM where
import ClassyPrelude 
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 Database.PostgreSQL.Simple        (Connection, connect)
import           Data.Thyme.Clock     as C
import Data.Thyme.Time  as T
import           Network.Mail.Mime
import           Network.Mail.SMTP          as SMTP
import Network.URI (URI, parseURI)
import           Text.StringTemplate
import Filesystem.Path.CurrentOS (encodeString)
import Network.Bippy.Types (Satoshi)
import Aftok            (User, UserId, userEmail, _Email)
import Aftok.Types (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, ProjectId(..), projectName)
import qualified AftokD as D
data AftokDErr
  = ConfigError Text
  | DBErr DB.DBError
  | PaymentErr P.PaymentError
makeClassyPrisms ''AftokDErr
instance P.AsPaymentError AftokDErr where
  _PaymentError = _PaymentErr . P._PaymentError
  _Overdue = _PaymentErr . P._Overdue
  _SigningError = _PaymentErr . P._SigningError
data AftokMEnv = AftokMEnv 
  { _dcfg :: !D.Config
  , _conn :: !Connection
  , _pcfg :: !P.PaymentsConfig
  }
makeLenses ''AftokMEnv
instance P.HasPaymentsConfig AftokMEnv where
  network = pcfg . P.network
  signingKey = pcfg . P.signingKey
  pkiData = pcfg . P.pkiData
  paymentsConfig = pcfg
newtype AftokM a = AftokM { runAftokM :: ReaderT AftokMEnv (ExceptT AftokDErr IO) a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadError AftokDErr, MonadReader AftokMEnv)
instance MonadRandom AftokM where
  getRandomBytes = liftIO . getRandomBytes
instance DB.MonadDB AftokM where
  liftdb = liftQDBM . DB.liftdb
liftQDBM :: QDBM a -> AftokM a
liftQDBM (QDBM r) = 
  AftokM . mapReaderT (withExceptT DBErr) . withReaderT _conn $ r
createAllPaymentRequests :: D.Config -> IO ()
createAllPaymentRequests cfg = do
  conn' <- connect $ cfg ^. D.dbConfig
  pcfg' <- AC.toPaymentsConfig $ cfg ^. D.billingConfig
  let env = AftokMEnv cfg conn' pcfg'
  void . runExceptT $ (runReaderT . runAftokM) createProjectsPaymentRequests $ env
createProjectsPaymentRequests :: AftokM ()
createProjectsPaymentRequests = do
  projects <- liftQDBM $ DB.listProjects
  traverse_ createProjectPaymentRequests projects
createProjectPaymentRequests :: ProjectId -> AftokM ()
createProjectPaymentRequests pid = do
    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)
sendPaymentRequestEmail :: P.PaymentRequestId -> AftokM ()
sendPaymentRequestEmail reqId = do
  cfg <- ask
  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
        preq'' <- traverseOf (P.subscription . customer) DB.findUser preq'
        traverseOf (P.subscription . billable . project) DB.findProject preq''
  req <- maybeT (throwError $ DBErr DB.SubjectNotFound) pure reqMay
  bip70URL <- paymentURL (req ^. paymentKey)
  mail <- buildPaymentRequestEmail preqCfg req bip70URL
  let mailer = maybe (sendMailWithLogin _smtpHost) (sendMailWithLogin' _smtpHost) _smtpPort
  liftIO $ mailer _smtpUser _smtpPass mail
  
buildPaymentRequestEmail :: (MonadIO m, MonadError AftokDErr m)
                         => D.PaymentRequestConfig
                         -> P.PaymentRequest' (Subscription' User (Billable' Project UserId Satoshi))
                         -> URI
                         -> m Mail
buildPaymentRequestEmail cfg req paymentUrl = do
  templates <- liftIO . directoryGroup $ encodeString (cfg ^. D.templatePath)
  let billTemplate = (newSTMP . unpack) <$> req ^. (subscription . billable . paymentRequestEmailTemplate)
      defaultTemplate = getStringTemplate "payment_request" templates
  case billTemplate <|> defaultTemplate of
    Nothing -> throwError $ ConfigError "Could not find template for invitation email"
    Just template -> 
      let fromEmail = cfg ^. D.billingFromEmail
          toEmail = req ^. (subscription . customer . userEmail)
          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", tshow $ total ^. satoshi)
            , ("payment_url", tshow paymentUrl)
            ]
          fromAddr = Address Nothing ("billing@aftok.com")
          toAddr   = Address Nothing (toEmail ^. _Email)
          subject  = "Payment is due for your "<>pname<>" subscription!"
          body     = plainTextPart . render $ setAttrs template
      in  pure $ SMTP.simpleMail fromAddr [toAddr] [] [] subject [body]
memoGen :: Subscription' UserId Billable 
        -> T.Day 
        -> C.UTCTime 
        -> AftokM (Maybe Text)
memoGen sub billingDate requestTime = do
  req <- traverseOf (billable . project) DB.findProjectOrError sub
  let template = (newSTMP . unpack) <$> (sub ^. (billable . paymentRequestMemoTemplate))
      setAttrs = setManyAttrib 
        [ ("project_name", req ^. (billable . project . projectName))
        , ("subscription", req ^. (billable . name))
        , ("billing_date", tshow billingDate)
        , ("issue_time", tshow requestTime)
        ]
  pure $ fmap (render . setAttrs) template
-- The same URL is used for retrieving a BIP-70 payment request and for submitting
-- the response.
paymentURL :: PaymentKey -> AftokM URI
paymentURL (PaymentKey k) = do
  env <- ask
  let hostname = env ^. (dcfg . D.paymentRequestConfig . D.aftokHost)
      paymentRequestPath = "https://" <> hostname <> "/pay/" <> k
  maybe
    (throwError . ConfigError $ "Could not parse path " <> paymentRequestPath <> " to a valid URI")
    pure
    (parseURI $ show paymentRequestPath)
payloadGen :: Monad m => Subscription' UserId Billable -> T.Day -> C.UTCTime -> m (Maybe ByteString)
payloadGen _ _ _ = pure Nothing

{-# LANGUAGE TemplateHaskell #-}
module AftokD where
import ClassyPrelude hiding (FilePath)
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 (FilePath, fromText, encodeString)
import Aftok (Email(..))
import qualified Aftok.Config as AC
data PaymentRequestConfig = PaymentRequestConfig
  { _aftokHost :: Text
  , _templatePath :: FilePath
  , _billingFromEmail :: Email
  }
makeLenses ''PaymentRequestConfig
data Config = Config
  { _smtpConfig     :: AC.SmtpConfig
  , _billingConfig  :: AC.BillingConfig
  , _dbConfig       :: ConnectInfo
  , _paymentRequestConfig :: PaymentRequestConfig
  }
makeLenses ''Config
loadConfig :: FilePath -> IO Config
loadConfig cfgFile = 
  readConfig =<< C.load [C.Required $ encodeString cfgFile]
readConfig :: CT.Config -> IO Config
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 :: CT.Config -> IO PaymentRequestConfig
readPaymentRequestConfig cfg = PaymentRequestConfig
  <$> C.require cfg "aftok_host"
  <*> (fromText <$> C.require cfg "template_path")
  <*> (Email <$> C.require cfg "payment_from_email")

{-# LANGUAGE TemplateHaskell       #-}
module Main (main) where
import ClassyPrelude
import System.Environment            (getEnv)
import Filesystem.Path.CurrentOS (decodeString)
import qualified AftokD as D
import AftokD.AftokM (createAllPaymentRequests)
main :: IO () 
main = do
  cfgPath <- try $ getEnv "AFTOK_CFG" :: IO (Either IOError String)
  cfg <- D.loadConfig . decodeString $ either (const "conf/aftok.cfg") id cfgPath
  createAllPaymentRequests cfg

  , _paymentRequestEmailTemplate :: Maybe Text
  , _paymentRequestMemoTemplate :: Maybe Text

  } deriving (Functor, Foldable, Traversable)

  } 

{-# LANGUAGE TemplateHaskell #-}
module Aftok.Config where
import           ClassyPrelude hiding (FilePath)
import Control.Lens (makeClassy, (^.))
import qualified Data.Configurator             as C
import qualified Data.Configurator.Types       as CT
import           Data.X509
import           Data.X509.File                (readKeyFile, readSignedObject)
import Database.PostgreSQL.Simple              (ConnectInfo(..))
import Filesystem.Path.CurrentOS (FilePath, fromText, encodeString)
import qualified Network.Bippy.Types           as BT
import qualified Network.Mail.SMTP             as SMTP
import qualified Network.Socket                as NS
import Aftok.Payments (PaymentsConfig(..))
data SmtpConfig = SmtpConfig
  { _smtpHost :: NS.HostName
  , _smtpPort :: Maybe NS.PortNumber
  , _smtpUser :: SMTP.UserName
  , _smtpPass :: SMTP.Password
  }
makeClassy ''SmtpConfig
data BillingConfig = BillingConfig
  { _network                :: BT.Network
  , _signingKeyFile         :: FilePath
  , _certsFile              :: FilePath
  , _exchangeRateServiceURI :: String
  } 
makeClassy ''BillingConfig
readSmtpConfig :: CT.Config -> IO SmtpConfig
readSmtpConfig cfg =
  SmtpConfig <$> C.require cfg "smtpHost"
             <*> ((fmap . fmap) fromInteger $ C.lookup cfg "smtpPort")
             <*> C.require cfg "smtpUser"
             <*> C.require cfg "smtpKey"
readBillingConfig :: CT.Config -> IO BillingConfig
readBillingConfig cfg =
  BillingConfig <$> (parseNetwork <$> C.require cfg "network")
                <*> (fromText <$> C.require cfg "signingKeyFile")
                <*> (fromText <$> C.require cfg "certsFile")
                <*> C.require cfg "exchangeRateServiceURI"
  where parseNetwork :: String -> BT.Network
        parseNetwork "main" = BT.MainNet
        parseNetwork _      = BT.TestNet
readConnectInfo :: CT.Config -> IO ConnectInfo
readConnectInfo cfg =
  ConnectInfo <$> C.require cfg "host"
              <*> C.require cfg "port"
              <*> C.require cfg "user"
              <*> C.require cfg "password"
              <*> C.require cfg "database"
toPaymentsConfig :: BillingConfig -> IO PaymentsConfig
toPaymentsConfig c = do
  privKeys   <- readKeyFile . encodeString $ c ^. signingKeyFile
  pkiEntries <- readSignedObject . encodeString $ c ^. certsFile
  privKey <- case headMay privKeys of
    Just (PrivKeyRSA k) -> pure k
    Just (PrivKeyDSA _) -> fail "DSA keys not supported for payment request signing."
    Nothing             -> fail $ "No keys found in private key file " <> encodeString (c ^. signingKeyFile)
  let pkiData = BT.X509SHA256 . CertificateChain $ pkiEntries
  pure $ PaymentsConfig (c ^. network) privKey pkiData

{-# LANGUAGE QuasiQuotes                #-}

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

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

import           Control.Monad.Trans.Either

import           Control.Monad.Trans.Except           (ExceptT(..), throwE, runExceptT)

import           Database.PostgreSQL.Simple.SqlQQ     (sql)

newtype QDBM a = QDBM (ReaderT Connection (EitherT DBError IO) a)

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

instance MonadDB QDBM where
  liftdb = pgEval

runQDBM :: Connection -> QDBM a -> EitherT DBError IO a

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

      parser "credit_to_btc_addr" = CreditToAddress <$> (fieldWith btcAddrParser <* nullField <* nullField)

      parser "credit_to_address"  = CreditToAddress <$> (fieldWith btcAddrParser <* nullField <* nullField)

             <*> field
             <*> field

  lift . EitherT $ withTransaction conn (runEitherT $ runReaderT rt conn)

  lift . ExceptT $ withTransaction conn (runExceptT $ runReaderT rt conn)

  pinsert EventId
    "INSERT INTO aftok_events \
    \(event_time, created_by, event_type, event_json) \
    \VALUES (?, ?, ?, ?) RETURNING id"

  pinsert EventId 
    [sql| INSERT INTO aftok_events 
          (event_time, created_by, event_type, event_json) 
          VALUES (?, ?, ?, ?) RETURNING id |]

      pinsert EventId
        "INSERT INTO work_events \
        \(project_id, user_id, credit_to_type, credit_to_btc_addr, event_type, event_time, event_metadata) \
        \VALUES (?, ?, ?, ?, ?, ?, ?) \
        \RETURNING id"

      pinsert EventId 
        [sql| INSERT INTO work_events 
              ( project_id, user_id, credit_to_type, credit_to_address
              , event_type, event_time, event_metadata ) 
              VALUES (?, ?, ?, ?, ?, ?, ?) 
              RETURNING id |]

      pinsert EventId
        "INSERT INTO work_events \
        \(project_id, user_id, credit_to_type, credit_to_project_id, event_type, event_time, event_metadata) \
        \VALUES (?, ?, ?, ?, ?, ?, ?) \
        \RETURNING id"

      pinsert EventId 
        [sql| INSERT INTO work_events 
              ( project_id, user_id, credit_to_type, credit_to_project_id
              , event_type, event_time, event_metadata ) 
              VALUES (?, ?, ?, ?, ?, ?, ?) 
              RETURNING id |]

      pinsert EventId
        "INSERT INTO work_events \
        \(project_id, user_id, credit_to_type, credit_to_user_id, event_type, event_time, event_metadata) \
        \VALUES (?, ?, ?, ?, ?, ?, ?) \
        \RETURNING id"

      pinsert EventId 
        [sql| INSERT INTO work_events 
              (project_id, user_id, credit_to_type, credit_to_user_id, event_type, event_time, event_metadata) 
              VALUES (?, ?, ?, ?, ?, ?, ?) 
              RETURNING id |]

  headMay <$> pquery qdbLogEntryParser
    "SELECT project_id, user_id, \
    \credit_to_type, credit_to_btc_addr, credit_to_user_id, credit_to_project_id, \
    \event_type, event_time, event_metadata FROM work_events \
    \WHERE id = ?"

  headMay <$> pquery qdbLogEntryParser 
    [sql| SELECT project_id, user_id, 
                 credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id, 
                 event_type, event_time, event_metadata FROM work_events 
          WHERE id = ? |]

  let q (Before e) = pquery logEntryParser
        "SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
        \WHERE project_id = ? AND user_id = ? AND event_time <= ?"

  let q (Before e) = pquery logEntryParser 
        [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id, 
                     event_type, event_time, 
                     event_metadata 
              FROM work_events 
              WHERE project_id = ? AND user_id = ? AND event_time <= ? |]

      q (During s e) = pquery logEntryParser
        "SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
        \WHERE project_id = ? AND user_id = ? \
        \AND event_time >= ? AND event_time <= ?"

      q (During s e) = pquery logEntryParser 
        [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id, 
                     event_type, event_time, event_metadata 
              FROM work_events 
              WHERE project_id = ? AND user_id = ? 
              AND event_time >= ? AND event_time <= ? |]

      q (After s) = pquery logEntryParser
        "SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
        \WHERE project_id = ? AND user_id = ? AND event_time >= ?"

      q (After s) = pquery logEntryParser 
        [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id, 
                     event_type, event_time, event_metadata 
              FROM work_events 
              WHERE project_id = ? AND user_id = ? AND event_time >= ? |]

  pinsert AmendmentId
    "INSERT INTO event_time_amendments \
    \(event_id, amended_at, event_time) \
    \VALUES (?, ?, ?) RETURNING id"

  pinsert AmendmentId 
    [sql| INSERT INTO event_time_amendments 
          (event_id, amended_at, event_time) 
          VALUES (?, ?, ?) RETURNING id |]

      pinsert AmendmentId
        "INSERT INTO event_credit_to_amendments \
        \(event_id, amended_at, credit_to_type, credit_to_btc_addr) \
        \VALUES (?, ?, ?, ?) RETURNING id"

      pinsert AmendmentId 
        [sql| INSERT INTO event_credit_to_amendments 
              (event_id, amended_at, credit_to_type, credit_to_btc_addr) 
              VALUES (?, ?, ?, ?) RETURNING id |]

      pinsert AmendmentId
        "INSERT INTO event_credit_to_amendments \
        \(event_id, amended_at, credit_to_type, credit_to_project_id) \
        \VALUES (?, ?, ?, ?) RETURNING id"

      pinsert AmendmentId 
        [sql| INSERT INTO event_credit_to_amendments 
              (event_id, amended_at, credit_to_type, credit_to_project_id) 
              VALUES (?, ?, ?, ?) RETURNING id |]

      pinsert AmendmentId
        "INSERT INTO event_credit_to_amendments \
        \(event_id, amended_at, credit_to_type, credit_to_user_id) \
        \VALUES (?, ?, ?, ?) RETURNING id"

      pinsert AmendmentId 
        [sql| INSERT INTO event_credit_to_amendments 
              (event_id, amended_at, credit_to_type, credit_to_user_id) 
              VALUES (?, ?, ?, ?) RETURNING id |]

  pinsert AmendmentId
    "INSERT INTO event_metadata_amendments \
    \(event_id, amended_at, event_metadata) \
    \VALUES (?, ?, ?) RETURNING id"

  pinsert AmendmentId 
    [sql| INSERT INTO event_metadata_amendments 
          (event_id, amended_at, event_metadata) 
          VALUES (?, ?, ?) RETURNING id |]

  logEntries <- pquery logEntryParser
    "SELECT btc_addr, event_type, event_time, event_metadata FROM work_events WHERE project_id = ?"

  logEntries <- pquery logEntryParser 
    [sql| SELECT credit_to_type, credit_to_address, credit_to_user_id, credit_to_project_id, 
                 event_type, event_time, event_metadata 
          FROM work_events 
          WHERE project_id = ? |]

  pinsert A.AuctionId
    "INSERT INTO auctions (project_id, user_id, raise_amount, end_time) \
    \VALUES (?, ?, ?, ?) RETURNING id"

  pinsert A.AuctionId 
    [sql| INSERT INTO auctions (project_id, initiator_id, raise_amount, end_time) 
          VALUES (?, ?, ?, ?) RETURNING id |]

  headMay <$> pquery auctionParser
    "SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time FROM auctions WHERE id = ?"

  headMay <$> pquery auctionParser 
    [sql| SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time 
          FROM auctions 
          WHERE id = ? |]

  pinsert A.BidId
    "INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time) \
    \VALUES (?, ?, ?, ?, ?) RETURNING id"

  pinsert A.BidId 
    [sql| INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time) 
          VALUES (?, ?, ?, ?, ?) RETURNING id |]

  pquery ((,) <$> idParser A.BidId <*> bidParser)
    "SELECT id, user_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ?"

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

  in  pinsert UserId
    "INSERT INTO users (handle, btc_addr, email) VALUES (?, ?, ?) RETURNING id"

  in  pinsert UserId 
    [sql| INSERT INTO users (handle, btc_addr, email) VALUES (?, ?, ?) RETURNING id |]

  headMay <$> pquery userParser
    "SELECT handle, btc_addr, email FROM users WHERE id = ?"

  headMay <$> pquery userParser 
    [sql| SELECT handle, btc_addr, email FROM users WHERE id = ? |]

  headMay <$> pquery ((,) <$> idParser UserId <*> userParser)
    "SELECT id, handle, btc_addr, email FROM users WHERE handle = ?"

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

  void $ pexec
    "INSERT INTO invitations (project_id, invitor_id, invitee_email, invitation_key, invitation_time) \
    \VALUES (?, ?, ?, ?, ?)"

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

  headMay <$> pquery invitationParser
    "SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time \
    \FROM invitations WHERE invitation_key = ?"

  headMay <$> pquery invitationParser 
    [sql| SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time 
          FROM invitations WHERE invitation_key = ? |]

  void $ pexec
    "UPDATE invitations SET acceptance_time = ? WHERE invitation_key = ?"

  void $ pexec 
    [sql| UPDATE invitations SET acceptance_time = ? WHERE invitation_key = ? |]

  void $ pexec
    "INSERT INTO project_companions (project_id, user_id, invited_by, joined_at) \
    \SELECT i.project_id, ?, i.invitor_id, ? \
    \FROM invitations i \
    \WHERE i.invitation_key = ?"

  void $ pexec 
    [sql| INSERT INTO project_companions (project_id, user_id, invited_by, joined_at) 
          SELECT i.project_id, ?, i.invitor_id, ? 
          FROM invitations i 
          WHERE i.invitation_key = ? |]

  pinsert P.ProjectId
    "INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn) \
    \VALUES (?, ?, ?, ?) RETURNING id"

  pinsert P.ProjectId 
    [sql| INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn) 
          VALUES (?, ?, ?, ?) RETURNING id |]

pgEval ListProjects =
  pquery (idParser P.ProjectId)
    [sql| SELECT id FROM projects |]
    ()
pgEval (FindSubscribers pid) =
  pquery (idParser UserId)
    [sql| SELECT s.user_id 
          FROM subscripions s 
          JOIN billables b ON s.billable_id = b.id 
          WHERE b.project_id = ? |]
    (Only (pid ^. P._ProjectId))

  headMay <$> pquery projectParser
    "SELECT project_name, inception_date, initiator_id, depreciation_fn FROM projects WHERE id = ?"

  headMay <$> pquery projectParser 
    [sql| SELECT project_name, inception_date, initiator_id, depreciation_fn FROM projects WHERE id = ? |]

  pquery ((,) <$> idParser P.ProjectId <*> projectParser)
    "SELECT p.id, p.project_name, p.inception_date, p.initiator_id, p.depreciation_fn \
    \FROM projects p LEFT OUTER JOIN project_companions pc ON pc.project_id = p.id \
    \WHERE pc.user_id = ? \
    \OR p.initiator_id = ?"

  pquery ((,) <$> idParser P.ProjectId <*> projectParser) 
    [sql| SELECT p.id, p.project_name, p.inception_date, p.initiator_id, p.depreciation_fn 
          FROM projects p LEFT OUTER JOIN project_companions pc ON pc.project_id = p.id 
          WHERE pc.user_id = ? 
          OR p.initiator_id = ? |]

  pexec
    "INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?)"

  pexec 
    [sql| INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?) |]

  pinsert B.BillableId
    "INSERT INTO billables \
    \( project_id, event_id, name, description \
    \, recurrence_type, recurrence_count \
    \, billing_amount, grace_period_days) \
    \VALUES (?, ?, ?, ?, ?, ?, ?, ?) RETURNING id"

  pinsert B.BillableId 
    [sql| INSERT INTO billables 
          ( project_id, event_id, name, description 
          , recurrence_type, recurrence_count 
          , billing_amount, grace_period_days
          , payment_request_email_template
          , payment_request_memo_template) 
          VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?) RETURNING id |]

    , b ^. (B.paymentRequestEmailTemplate)
    , b ^. (B.paymentRequestMemoTemplate)

  headMay <$> pquery billableParser
    "SELECT b.project_id, e.created_by, b.name, b.description, b.recurrence_type, b.recurrence_count, \
    \       b.billing_amount, b.grace_period_days \
    \FROM billables b JOIN aftok_events e ON e.id = b.event_id \
    \WHERE b.id = ?"

  headMay <$> pquery billableParser 
    [sql| SELECT b.project_id, e.created_by, b.name, b.description, 
                 b.recurrence_type, b.recurrence_count, 
                 b.billing_amount, b.grace_period_days,
                 b.payment_request_email_template, b.payment_request_memo_template
          FROM billables b JOIN aftok_events e ON e.id = b.event_id 
          WHERE b.id = ? |]

pgEval (FindBillables pid) = 
  pquery ((,) <$> idParser B.BillableId <*> billableParser) 
    [sql| SELECT b.id, b.project_id, e.created_by, b.name, b.description, 
                 b.recurrence_type, b.recurrence_count, 
                 b.billing_amount, b.grace_period_days 
                 b.payment_request_email_template, b.payment_request_memo_template
          FROM billables b JOIN aftok_events e ON e.id = b.event_id 
          WHERE b.project_id = ? |]
    (Only (pid ^. P._ProjectId))

  pinsert B.SubscriptionId
    "INSERT INTO subscriptions \
    \(user_id, billable_id, event_id) \
    \VALUES (?, ?, ?, ?) RETURNING id"

  pinsert B.SubscriptionId 
    [sql| INSERT INTO subscriptions 
          (user_id, billable_id, event_id, start_date) 
          VALUES (?, ?, ?, ?) RETURNING id |]

  headMay <$> pquery subscriptionParser
    "SELECT id, billable_id, start_date, end_date \
    \FROM subscriptions s \
    \WHERE s.id = ?"

  headMay <$> pquery subscriptionParser 
    [sql| SELECT id, billable_id, start_date, end_date 
          FROM subscriptions s 
          WHERE s.id = ? |]

  pquery ((,) <$> idParser B.SubscriptionId <*> subscriptionParser)
    "SELECT id, user_id, billable_id, start_date, end_date \
    \FROM subscriptions s \
    \JOIN billables b ON b.id = s.billable_id \
    \WHERE s.user_id = ? \
    \AND b.project_id = ?"

  pquery ((,) <$> idParser B.SubscriptionId <*> subscriptionParser) 
    [sql| SELECT s.id, user_id, billable_id, start_date, end_date 
          FROM subscriptions s 
          JOIN billables b ON b.id = s.billable_id 
          WHERE s.user_id = ? 
          AND b.project_id = ? |]

  pinsert PaymentRequestId
    "INSERT INTO payment_requests \
    \(subscription_id, event_id, request_data, url_key, request_time, billing_date) \
    \VALUES (?, ?, ?, ?, ?, ?) RETURNING id"

  pinsert PaymentRequestId 
    [sql| INSERT INTO payment_requests 
          (subscription_id, event_id, request_data, url_key, request_time, billing_date) 
          VALUES (?, ?, ?, ?, ?, ?) RETURNING id |]

  headMay <$> pquery ((,) <$> idParser PaymentRequestId <*> paymentRequestParser)
  "SELECT id, subscription_id, request_data, url_key, request_time, billing_date \
  \FROM payment_requests \
  \WHERE url_key = ? \
  \AND id NOT IN (SELECT payment_request_id FROM payments)"

  headMay <$> pquery ((,) <$> idParser PaymentRequestId <*> paymentRequestParser) 
  [sql| SELECT id, subscription_id, request_data, url_key, request_time, billing_date 
        FROM payment_requests 
        WHERE url_key = ? 
        AND id NOT IN (SELECT payment_request_id FROM payments) |]

pgEval (FindPaymentRequestId (PaymentRequestId prid)) =
  headMay <$> pquery paymentRequestParser
  [sql| SELECT subscription_id, request_data, url_key, request_time, billing_date 
        FROM payment_requests 
        WHERE id = ? |]
  (Only prid)

  pquery ((,) <$> idParser PaymentRequestId <*> paymentRequestParser)
  "SELECT id, subscription_id, request_data, url_key, request_time, billing_date \
  \FROM payment_requests \
  \WHERE subscription_id = ?"

  pquery ((,) <$> idParser PaymentRequestId <*> paymentRequestParser) 
  [sql| SELECT id, subscription_id, request_data, url_key, request_time, billing_date 
        FROM payment_requests 
        WHERE subscription_id = ? |]

  in  pquery rowp
      "SELECT r.url_key, \
      \       r.subscription_id, r.request_data, r.url_key, r.request_time, r.billing_date, \
      \       s.user_id, s.billable_id, s.start_date, s.end_date, \
      \       b.project_id, e.created_by, b.name, b.description, b.recurrence_type, \
      \       b.recurrence_count, b.billing_amount, b.grace_period_days \
      \FROM payment_requests r \
      \JOIN subscriptions s on s.id = r.subscription_id \
      \JOIN billables b on b.id = s.billable_id \
      \WHERE subscription_id = ? \
      \AND r.id NOT IN (SELECT payment_request_id FROM payments)"

  in  pquery rowp 
      [sql| SELECT r.url_key, 
                   r.subscription_id, r.request_data, r.url_key, r.request_time, r.billing_date, 
                   s.user_id, s.billable_id, s.start_date, s.end_date, 
                   b.project_id, e.created_by, b.name, b.description, b.recurrence_type, 
                   b.recurrence_count, b.billing_amount, b.grace_period_days,
                   b.payment_request_email_template, b.payment_request_memo_template
            FROM payment_requests r 
            JOIN subscriptions s on s.id = r.subscription_id 
            JOIN billables b on b.id = s.billable_id 
            JOIN aftok_events e on e.id = b.event_id
            WHERE subscription_id = ? 
            AND r.id NOT IN (SELECT payment_request_id FROM payments) |]

  pinsert PaymentId
    "INSERT INTO payments \
    \(payment_request_id, event_id, payment_data, payment_date, exchange_rates) \
    \VALUES (?, ?, ?, ?) RETURNING id"

  pinsert PaymentId 
    [sql| INSERT INTO payments 
          (payment_request_id, event_id, payment_data, payment_date, exchange_rates) 
          VALUES (?, ?, ?, ?, ?) RETURNING id |]

  pquery ((,) <$> idParser PaymentId <*> paymentParser)
  "SELECT id, payment_request_id, payment_data, payment_date \
  \FROM payments \
  \WHERE payment_request_id = ?"

  pquery ((,) <$> idParser PaymentId <*> paymentParser) 
  [sql| SELECT id, payment_request_id, payment_data, payment_date 
        FROM payments 
        WHERE payment_request_id = ? |]

raiseError = QDBM . lift . left
instance MonadDB QDBM where
  liftdb = pgEval

raiseError = QDBM . lift . throwE

{-# LANGUAGE TemplateHaskell    #-}

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

import           Control.Lens              (view, (^.), makeClassyPrisms, traverseOf)

  ListProjects     :: DBOp [ProjectId]
  FindSubscribers  :: ProjectId -> DBOp [UserId]

  FindBillables    :: ProjectId  -> DBOp [(BillableId, Billable)]

  FindPaymentRequestId  :: PaymentRequestId -> DBOp (Maybe PaymentRequest)

makeClassyPrisms ''DBError

findUser :: (MonadDB m) => UserId -> m (Maybe User)
findUser = liftdb . FindUser

findUser :: (MonadDB m) => UserId -> MaybeT m User
findUser = MaybeT . liftdb . FindUser

findUserByName :: (MonadDB m) => UserName -> m (Maybe (UserId, User))
findUserByName = liftdb . FindUserByName

findUserByName :: (MonadDB m) => UserName -> MaybeT m (UserId, User)
findUserByName = MaybeT . liftdb . FindUserByName

listProjects :: (MonadDB m) => m [ProjectId]
listProjects = liftdb ListProjects
findSubscribers :: (MonadDB m) => ProjectId -> m [UserId]
findSubscribers = liftdb . FindSubscribers

findProject :: (MonadDB m) => ProjectId -> UserId -> m (Maybe Project)
findProject pid uid = do
  kps <- findUserProjects uid
  pure $ fmap snd (find (\(pid', _) -> pid' == pid) kps)

findProject :: (MonadDB m) => ProjectId -> MaybeT m Project
findProject = MaybeT . liftdb . FindProject
findProjectOrError :: (MonadDB m) => ProjectId -> m Project
findProjectOrError pid = fromMaybeT
  (raiseSubjectNotFound $ FindProject pid)
  (findProject pid)
findUserProject :: (MonadDB m) => UserId -> ProjectId -> MaybeT m Project
findUserProject uid pid = do
  kps <- lift $ findUserProjects uid
  MaybeT . pure $ fmap snd (find (\(pid', _) -> pid' == pid) kps)

  traverse findBillable sub

  traverseOf B.billable findBillable sub

findPaymentRequest :: (MonadDB m) => PaymentKey -> m (Maybe (PaymentRequestId, PaymentRequest))
findPaymentRequest = liftdb . FindPaymentRequest

findPaymentRequest :: (MonadDB m) => PaymentKey -> MaybeT m (PaymentRequestId, PaymentRequest)
findPaymentRequest = MaybeT . liftdb . FindPaymentRequest
findPaymentRequestId :: (MonadDB m) => PaymentRequestId -> MaybeT m PaymentRequest
findPaymentRequestId = MaybeT . liftdb . FindPaymentRequestId

findPayment :: (MonadDB m) => PaymentRequestId -> m (Maybe Payment)
findPayment prid = (fmap snd . headMay) <$> liftdb (FindPayments prid)

findPayment :: (MonadDB m) => PaymentRequestId -> MaybeT m Payment
findPayment prid = MaybeT $ (fmap snd . headMay) <$> liftdb (FindPayments prid)

findAuction :: (MonadDB m) => AuctionId -> UserId -> m (Maybe Auction)

findAuction :: (MonadDB m) => AuctionId -> UserId -> MaybeT m Auction

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

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

qdbProjectJSON :: (ProjectId, Project) -> Value
qdbProjectJSON (pid, project) = v1 $
  obj [ "projectId" .=  idValue _ProjectId pid
      , "project" .= projectJSON project

qdbJSON :: Text -> (Lens' a UUID) -> (b -> Value) -> (a, b) -> Value
qdbJSON name l f (xid, x) = v1 $
  obj [ (name <> "Id") .= idValue l xid
      , name .= f x

qdbProjectJSON :: (ProjectId, Project) -> Value
qdbProjectJSON = qdbJSON "project" _ProjectId projectJSON

billableIdJSON :: B.BillableId -> Value
billableIdJSON = idJSON "billableId" B._BillableId

qdbBillableJSON :: (B.BillableId, B.Billable) -> Value
qdbBillableJSON = qdbJSON "billable" B._BillableId billableJSON

subscriptionIdJSON :: B.SubscriptionId -> Value
subscriptionIdJSON = idJSON "subscriptionId" B._SubscriptionId

paymentIdJSON :: PaymentId -> Value
paymentIdJSON = idJSON "paymentId" _PaymentId

parseUUID :: Value -> Parser U.UUID
parseUUID v = do
  str <- parseJSON v
  maybe (fail $ "Value " <> str <> "Could not be parsed as a valid UUID.") pure $ U.fromString str
parseId :: forall a. Prism' a UUID -> Value -> Parser a
parseId p = fmap (review p) . parseUUID 

        fmap (CreditToUser . UserId) . parseUUID <$> O.lookup "creditToUser" o'

        fmap CreditToUser . parseId _UserId <$> O.lookup "creditToUser" o'

        fmap (CreditToProject . ProjectId) . parseUUID <$> O.lookup "creditToProject" o'

        fmap CreditToProject . parseId _ProjectId <$> O.lookup "creditToProject" o'

parseUUID :: Value -> Parser U.UUID
parseUUID v = do
  str <- parseJSON v
  maybe (fail $ "Value " <> str <> "Could not be parsed as a valid UUID.") pure $ U.fromString str

parseBillable :: Value -> Parser B.Billable
parseBillable = unversion "Billable" p where
  --p (Version 1 0) o = 

  p v o = badVersion "Billable" v o

parseRecurrence :: Object -> Parser B.Recurrence
parseRecurrence o = 
  let parseAnnually o' = const (pure B.Annually)    <$> O.lookup "annually" o'
      parseMonthly  o' = fmap B.Monthly . parseJSON <$> O.lookup "monthly" o'
      parseWeekly  o'  = fmap B.Weekly  . parseJSON <$> O.lookup "weekly" o'
      parseOneTime o'  = const (pure B.OneTime)     <$> O.lookup "one-time" o'

      notFound = fail $ "Value " <> show o <> " does not represent a Recurrence value."
      parseV v = parseAnnually v <|> parseMonthly v <|> parseWeekly v <|> parseOneTime v
  in  fromMaybe notFound $ parseV o

parseRecurrence' :: Value -> Parser B.Recurrence
parseRecurrence' (Object o) = parseRecurrence o
parseRecurrence' v = fail $ "Value " <> show v <> " is not a JSON object."

                                         getPaymentDetails)

                                         getPaymentDetails, Satoshi(..))

-- A unique identifier for the payment request, suitable
-- for URL embedding.

paymentRequestTotal :: P.PaymentRequest -> Satoshi
paymentRequestTotal _ = error "Not yet implemented"

                                          view, (%~), (^.))

                                          view, (%~), (^.), traverseOf)

import           Control.Monad.Trans.Maybe    (MaybeT(..), runMaybeT)

data BillingConfig = BillingConfig
  { _network    :: BT.Network
  , _signingKey :: RSA.PrivateKey
  , _pkiData    :: BT.PKIData

data PaymentsConfig = PaymentsConfig
  { _network    :: !BT.Network
  , _signingKey :: !RSA.PrivateKey
  , _pkiData    :: !BT.PKIData

makeClassy ''BillingConfig

makeClassy ''PaymentsConfig

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

    memoGen    :: Subscription' UserId Billable -- ^ subscription being billed
               -> T.Day                         -- ^ billing date
               -> C.UTCTime                     -- ^ payment request generation time
               -> m (Maybe Text)

  , uriGen     :: PaymentKey -> m (Maybe URI)

  , uriGen     :: PaymentKey                    -- ^ payment key to be included in the URL 
               -> m (Maybe URI)

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

  , payloadGen :: Subscription' UserId Billable -- ^ subscription being billed
               -> T.Day                         -- ^ billing date
               -> C.UTCTime                     -- ^ payment request generation time
               -> m (Maybe ByteString) 

  = Paid Payment           -- ^ the request was paid with the specified payment
  | Unpaid PaymentRequest  -- ^ the request has not been paid, but has not yet expired
  | Expired PaymentRequest -- ^ the request was not paid prior to the expiration date

  = Paid !Payment           -- ^ the request was paid with the specified payment
  | Unpaid !PaymentRequest  -- ^ the request has not been paid, but has not yet expired
  | Expired !PaymentRequest -- ^ the request was not paid prior to the expiration date

  = Overdue SubscriptionId
  | SigningError RSA.Error

  = Overdue !SubscriptionId
  | SigningError !RSA.Error

{--
 - Find all the subscriptions for the specified customer, and
 - determine which if any are up for renewal. Create a payment
 - request for each such subscription.
 --}

                         , MonadReader r m, HasBillingConfig r

                         , MonadReader r m, HasPaymentsConfig r

     , MonadReader r m, HasBillingConfig r

     , MonadReader r m, HasPaymentsConfig r

                 traverse findBillable sub

                 traverseOf billable findBillable sub

     , MonadReader r m, HasBillingConfig r

     , MonadReader r m, HasPaymentsConfig r

  in  maybe ifUnpaid Paid <$> findPayment reqid

  in  maybe ifUnpaid Paid <$> runMaybeT (findPayment reqid)

createPaymentDetails :: (MonadRandom m, MonadReader r m, HasBillingConfig r, MonadDB m)

createPaymentDetails :: (MonadRandom m, MonadReader r m, HasPaymentsConfig r, MonadDB m)

createOutputs _ (TL.CreditToUser uid) amt = do
  addrMay <- (>>= view userAddress) <$> findUser uid
  let createOutput addr = BT.Output amt (PayPKHash (addr ^. _BtcAddr))
  pure . maybeToList $ createOutput <$> addrMay

createOutputs _ (TL.CreditToUser uid) amt = (fmap maybeToList) . runMaybeT $ do
  user <- findUser uid
  addr <- MaybeT . pure $ user ^. userAddress
  pure $ BT.Output amt (PayPKHash (addr ^. _BtcAddr))

data LogEvent = StartWork { _eventTime :: C.UTCTime }
              | StopWork  { _eventTime :: C.UTCTime }

data LogEvent = StartWork { _eventTime :: !C.UTCTime }
              | StopWork  { _eventTime :: !C.UTCTime }

  = CreditToAddress BtcAddr

  = CreditToAddress !BtcAddr

  | CreditToUser UserId

  | CreditToUser !UserId

  | CreditToProject ProjectId

  | CreditToProject !ProjectId

  { _creditTo  :: CreditTo
  , _event     :: LogEvent
  , _eventMeta :: Maybe A.Value

  { _creditTo  :: !CreditTo
  , _event     :: !LogEvent
  , _eventMeta :: !(Maybe A.Value)

data EventAmendment = TimeChange ModTime C.UTCTime
                    | CreditToChange ModTime CreditTo
                    | MetadataChange ModTime A.Value

data EventAmendment = TimeChange !ModTime !C.UTCTime
                    | CreditToChange !ModTime !CreditTo
                    | MetadataChange !ModTime !A.Value

import           Control.Error.Util (maybeT)

import           Control.Monad.Trans.Maybe (MaybeT)

fromMaybeT :: (Monad m) => m a -> MaybeT m a -> m a
fromMaybeT a m = maybeT a pure m

  { _username    :: UserName
  , _userAddress :: Maybe BtcAddr
  , _userEmail   :: Email

  { _username    :: !UserName
  , _userAddress :: !(Maybe BtcAddr)
  , _userEmail   :: !Email

  alter table work_events rename column credit_to_btc_addr to btc_addr;

  alter table work_events rename column credit_to_address to btc_addr;

Description: Add missing identifiers to event metadata tables
Created: 2017-06-08 04:38:05.341636 UTC
Depends: 2016-10-14_02-49-36_event-amendments
Apply: |
  alter table event_metadata_amendments 
  add column id uuid primary key default uuid_generate_v4();
  alter table event_credit_to_amendments 
  add column id uuid primary key default uuid_generate_v4();
  alter table event_time_amendments
  add column id uuid primary key default uuid_generate_v4();

Description: (Describe migration here.)
Created: 2017-09-24 22:06:53.509947 UTC
Depends: 2016-12-31_03-45-17_create-payments
Apply: |
  alter table billables add column payment_request_email_template text null; 
  alter table billables add column payment_request_memo_template text null; 
Revert: |
  alter table billables drop column payment_request_email_template;
  alter table billables drop column payment_request_memo_template;

import           ClassyPrelude

import           ClassyPrelude hiding (FilePath)

import qualified Data.ByteString.Char8         as C

import qualified Data.ByteString.Char8         as C8

import           Data.X509
import           Data.X509.File                (readKeyFile, readSignedObject)
import qualified Network.Bippy.Types           as BT
import qualified Network.Mail.SMTP             as SMTP
import qualified Network.Socket                as NS
import           System.Environment
import           System.IO                     (FilePath)

import           System.Environment            (getEnvironment)
import Filesystem.Path.CurrentOS (FilePath, fromText, encodeString)

import qualified Aftok.Payments                as AP

import           Aftok.Config

  , authSiteKey   :: System.IO.FilePath

  , authSiteKey   :: FilePath

  , templatePath  :: System.IO.FilePath
  , staticAssetPath :: System.IO.FilePath
  }
data SmtpConfig = SmtpConfig
  { smtpHost :: NS.HostName
  , smtpPort :: Maybe NS.PortNumber
  , smtpUser :: SMTP.UserName
  , smtpPass :: SMTP.Password

  , templatePath  :: FilePath
  , staticAssetPath :: FilePath

data BillingConfig = BillingConfig
  { network                :: BT.Network
  , signingKeyFile         :: System.IO.FilePath
  , certsFile              :: System.IO.FilePath
  , exchangeRateServiceURI :: String
  }
loadQConfig :: System.IO.FilePath -> IO QConfig

loadQConfig :: FilePath -> IO QConfig

  cfg <- C.load [C.Required cfgFile]
  let dbEnvCfg = pgsDefaultConfig . C.pack <$> lookup "DATABASE_URL" env

  cfg <- C.load [C.Required $ encodeString cfgFile]
  let dbEnvCfg = pgsDefaultConfig . C8.pack <$> lookup "DATABASE_URL" env

          <*> C.require cfg "siteKey"

          <*> (fromText <$> C.require cfg "siteKey")

          <*> C.lookupDefault "/opt/aftok/server/templates/" cfg "templatePath"
          <*> C.lookupDefault "/opt/aftok/server/static/" cfg "staticAssetPath"

          <*> (fromText <$> C.lookupDefault "/opt/aftok/server/templates/" cfg "templatePath")
          <*> (fromText <$> C.lookupDefault "/opt/aftok/server/static/" cfg "staticAssetPath")

readSmtpConfig :: CT.Config -> IO SmtpConfig
readSmtpConfig cfg =
  SmtpConfig <$> C.require cfg "smtpHost"
             <*> ((fmap . fmap) fromInteger $ C.lookup cfg "smtpPort")
             <*> C.require cfg "smtpUser"
             <*> C.require cfg "smtpKey"
readBillingConfig :: CT.Config -> IO BillingConfig
readBillingConfig cfg =
  BillingConfig <$> (parseNetwork <$> C.require cfg "network")
                <*> C.require cfg "signingKeyFile"
                <*> C.require cfg "certsFile"
                <*> C.require cfg "exchangeRateServiceURI"
  where parseNetwork :: String -> BT.Network
        parseNetwork "main" = BT.MainNet
        parseNetwork _      = BT.TestNet

toBillingConfig :: BillingConfig -> IO AP.BillingConfig
toBillingConfig c = do
  privKeys   <- readKeyFile (signingKeyFile c)
  pkiEntries <- readSignedObject (certsFile c)
  privKey <- case headMay privKeys of
    Just (PrivKeyRSA k) -> pure k
    Just (PrivKeyDSA _) -> fail "DSA keys not supported for payment request signing."
    Nothing             -> fail $ "No keys found in private key file " <> signingKeyFile c
  let pkiData = BT.X509SHA256 . CertificateChain $ pkiEntries
  pure $ AP.BillingConfig (network c) privKey pkiData

import           Control.Monad.Trans.Maybe (mapMaybeT)

import           Aftok.Util (fromMaybeT)

  maybeAuc <- snapEval $ findAuction aid uid -- this will verify auction access
  maybe (snapError 404 $ "Auction not found for id " <> tshow aid) pure maybeAuc

  fromMaybeT
    (snapError 404 $ "Auction not found for id " <> tshow aid)
    (mapMaybeT snapEval $ findAuction aid uid) -- this will verify auction access

import           Control.Error.Util (maybeT)
import           Control.Monad.Trans.Maybe (mapMaybeT)

  currentUser <- UserName . AU.userLogin <$> requireLogin
  qdbUser <- snapEval $ findUserByName currentUser
  case qdbUser of
    Nothing -> snapError 403 "Unable to retrieve user record for authenticated user"
    Just u -> pure (u ^. _1)

  currentUser <- UserName . AU.userLogin <$> requireUser
  maybeT
    (snapError 403 "Unable to retrieve user record for authenticated user")
    (pure . (^. _1))
    (mapMaybeT snapEval $ findUserByName currentUser)

{-# LANGUAGE TemplateHaskell #-}
module Aftok.Snaplet.Billing
  ( billableCreateHandler
  , billableListHandler
  , subscribeHandler
  ) where
import           ClassyPrelude
import           Control.Lens ((^.))
import           Data.Aeson
import           Data.Aeson.Types
import           Data.Thyme.Clock     as C
import           Data.Thyme.Time.Core (toThyme)
import           Snap.Snaplet         as S
import           Aftok                (UserId)
import           Aftok.Billables      
import           Aftok.Json
import           Aftok.Types
import           Aftok.Project
import           Aftok.Database       (createBillable, withProjectAuth, liftdb, DBOp(..))
import           Aftok.Snaplet
import           Aftok.Snaplet.Auth
parseCreateBillable :: UserId -> ProjectId -> Value -> Parser Billable
parseCreateBillable uid pid = unversion "Billable" p where
  p (Version 1 0) o = 
    Billable <$> pure pid
             <*> pure uid
             <*> o .: "name"
             <*> o .: "description"
             <*> (parseRecurrence' =<< o .: "recurrence")
             <*> (Satoshi <$> o .: "amount")
             <*> o .: "gracePeriod"
             <*> (fmap toThyme <$> o .: "requestExpiryPeriod")
             <*> o .:? "paymentRequestEmailTemplate"
             <*> o .:? "paymentRequestMemoTemplate"
  p v o = badVersion "Billable" v o
billableCreateHandler :: S.Handler App App BillableId
billableCreateHandler = do
  uid <- requireUserId
  pid <- requireProjectId
  requestBody <- readRequestJSON 4096
  b <- either (snapError 400 . tshow) pure $ parseEither (parseCreateBillable uid pid) requestBody
  snapEval $ createBillable uid b
billableListHandler :: S.Handler App App [(BillableId, Billable)]
billableListHandler = do
  uid <- requireUserId
  pid <- requireProjectId
  snapEval $ withProjectAuth pid uid (FindBillables pid)
subscribeHandler :: S.Handler App App SubscriptionId
subscribeHandler = do
  uid <- requireUserId
  bid <- requireId "billableId" BillableId
  t <- liftIO C.getCurrentTime
  snapEval . liftdb $ CreateSubscription uid bid (t ^. C._utctDay)
  

import           ClassyPrelude

import           ClassyPrelude 

import           Control.Lens         (view, _1, _2, _Right, _Left, preview, (&), (.~))

import           Control.Lens         (view, _1, _2, _Right, _Left, preview, (&), (.~), (^.))
import           Control.Monad.Trans.Maybe (mapMaybeT)

import           Aftok.Config         as AC

import           Aftok.Payments

import           Aftok.Payments       
import           Aftok.Util (fromMaybeT)

import           Aftok.QConfig        as QC

paymentResponseHandler :: QC.BillingConfig -> S.Handler App App PaymentId

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

  exchResp  <- liftIO . try $ asValue =<< (withOpenSSL $ getWith opts (exchangeRateServiceURI cfg))

  exchResp  <- liftIO . try $ asValue =<< (withOpenSSL $ getWith opts (cfg ^. exchangeRateServiceURI))

  prMay <- snapEval $ findPaymentRequest pkey
  maybe (snapError 404 $ "Outstanding payment request not found for key " <> (view _PaymentKey pkey))
        pure prMay

  fromMaybeT
    (snapError 404 $ "Outstanding payment request not found for key " <> (view _PaymentKey pkey))
    (mapMaybeT snapEval $ findPaymentRequest pkey)

import           ClassyPrelude

import           ClassyPrelude hiding (FilePath)

import           Control.Monad.Trans.Maybe (mapMaybeT, runMaybeT)

import           Filesystem.Path.CurrentOS (FilePath, encodeString)

import           System.IO                  (FilePath)

import           Aftok.Config

import           Aftok.QConfig

import           Aftok.QConfig as QC

import           Aftok.Util (fromMaybeT)

  mp <- snapEval $ findProject pid uid
  maybe (snapError 404 $ "Project not found for id " <> tshow pid) pure mp

  fromMaybeT
    (snapError 404 $ "Project not found for id " <> tshow pid)
    (mapMaybeT snapEval $ findUserProject uid pid)

    (,,) <$> findUser uid
         <*> findProject pid uid

    (,,) <$> (runMaybeT $ findUser uid)
         <*> (runMaybeT $ findUserProject uid pid)

  let SmtpConfig{..} = smtpConfig cfg
      mailer = maybe (sendMailWithLogin smtpHost) (sendMailWithLogin' smtpHost) smtpPort

  let SmtpConfig{..} = QC.smtpConfig cfg
      mailer = maybe (sendMailWithLogin _smtpHost) (sendMailWithLogin' _smtpHost) _smtpPort

      (mailer smtpUser smtpPass)

      (mailer _smtpUser _smtpPass)

buildProjectInviteEmail :: System.IO.FilePath

buildProjectInviteEmail :: FilePath

  templates <- directoryGroup templatePath

  templates <- directoryGroup $ encodeString templatePath

import           Control.Monad.Trans.Maybe (mapMaybeT)

import           Aftok.Util (fromMaybeT)

  projectMay <- snapEval $ findProject pid uid
  project <- maybe (snapError 400 $ "Project not found for id " <> tshow pid) pure projectMay

  project <- fromMaybeT
    (snapError 400 $ "Project not found for id " <> tshow pid)
    (mapMaybeT snapEval $ findUserProject uid pid)

import           Control.Monad.Trans.Either

import           Control.Monad.Trans.Except    (runExceptT)

  e <- liftPG $ \conn -> liftIO $ runEitherT (runQDBM conn $ interpret liftdb p)

  e <- liftPG $ \conn -> liftIO $ runExceptT (runQDBM conn $ interpret liftdb p)

import           ClassyPrelude

import           ClassyPrelude hiding (FilePath)

import Data.Either.Combinators (fromRight)

import Filesystem.Path.CurrentOS (decodeString, encodeString)

import           Aftok.Snaplet.Billing

  cfg <- loadQConfig $ either (const "conf/aftok.cfg") id cfgPath

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

           initCookieSessionManager (authSiteKey cfg) "quookie" (Just "aftok.com") (cookieTimeout cfg)

           initCookieSessionManager (encodeString $ authSiteKey cfg) "quookie" (Just "aftok.com") (cookieTimeout cfg)

  let loginRoute         = method GET requireLogin >> redirect "/home"
      xhrLoginRoute      = void $ method POST requireLogin
      registerRoute      = void $ method POST registerHandler
      acceptInviteRoute  = void $ method POST acceptInvitationHandler

  let loginRoute          = method GET requireLogin >> redirect "/home"
      xhrLoginRoute      =  void $ method POST requireLogin
      registerRoute       = void $ method POST registerHandler
      inviteRoute         = void $ method POST (projectInviteHandler cfg)
      acceptInviteRoute   = void $ method POST acceptInvitationHandler

      listProjectsRoute   = serveJSON (fmap qdbProjectJSON) $ method GET projectListHandler

      projectListRoute    = serveJSON (fmap qdbProjectJSON) $ method GET projectListHandler

      logWorkRoute f      = serveJSON eventIdJSON $ method POST (logWorkHandler f)
      logWorkBTCRoute f   = serveJSON eventIdJSON $ method POST (logWorkBTCHandler f)

      inviteRoute         = void . method POST $ projectInviteHandler cfg

      logWorkRoute f      = serveJSON eventIdJSON $ method POST (logWorkHandler f)
      logWorkBTCRoute f   = serveJSON eventIdJSON $ method POST (logWorkBTCHandler f)
      amendEventRoute     = serveJSON amendmentIdJSON $ method PUT amendEventHandler

      auctionRoute        = serveJSON auctionJSON $ method GET auctionGetHandler
      auctionBidRoute     = serveJSON bidIdJSON $ method POST auctionBidHandler

      auctionRoute        = serveJSON auctionJSON   $ method GET auctionGetHandler
      auctionBidRoute     = serveJSON bidIdJSON     $ method POST auctionBidHandler 

      payableRequestsRoute = serveJSON billDetailsJSON $ method GET listPayableRequestsHandler
      paymentRoute         = (writeLBS . runPutLazy . encodeMessage =<< method GET getPaymentRequestHandler)
                             <|> (void . method POST . paymentResponseHandler $ billingConfig cfg)

      billableCreateRoute = serveJSON billableIdJSON $ method POST billableCreateHandler
      billableListRoute   = serveJSON (fmap qdbBillableJSON) $ method GET billableListHandler
      subscribeRoute      = serveJSON subscriptionIdJSON $ method POST subscribeHandler

      amendEventRoute     = serveJSON amendmentIdJSON $ method PUT amendEventHandler

      payableRequestsRoute = serveJSON billDetailsJSON $ method GET listPayableRequestsHandler
      getPaymentRequestRoute = writeLBS . runPutLazy . encodeMessage =<< method GET getPaymentRequestHandler
      submitPaymentRoute     = serveJSON paymentIdJSON $ method POST (paymentResponseHandler $ billingConfig cfg)

  addRoutes [ ("static", serveDirectory $ staticAssetPath cfg)

  addRoutes [ ("static", serveDirectory . encodeString $ staticAssetPath cfg)

            , ("projects/:projectId/auctions",          auctionCreateRoute)

            , ("projects/:projectId/auctions",          auctionCreateRoute) -- <|> auctionListRoute
            , ("projects/:projectId/billables",         billableCreateRoute <|> billableListRoute)

            , ("projects", projectCreateRoute)
            , ("projects", listProjectsRoute)

            , ("projects",                              projectCreateRoute <|> projectListRoute)

            , ("subscribe/:billableId",        subscribeRoute)

            , ("pay/:paymentRequestKey", paymentRoute)

            , ("pay/:paymentRequestKey", getPaymentRequestRoute <|> submitPaymentRoute)

  writeLBS =<< (A.encode . f <$> ma)

  value <- ma
  writeLBS $ A.encode (f value)