:set -isrc
:set -hide-package MonadCatchIO-mtl
:set -hide-package monads-fd
:set -XOverloadedStrings

      - Associate events with user identifier as well as BTC address, and add 
        late resolution of BTC addresses at point of payout calculation.

      - add late resolution of BTC addresses at point of payout calculation.

                    , KindSignatures

                      Aftok.Billables

                      Aftok.Payments

                      Aftok.Time

    , bippy               == 0.1.0.0

    , aeson               == 0.9.*

    , aeson               >= 0.11.2

    , haskoin-core        >= 0.4

    , postgresql-simple   == 0.5.*

    , postgresql-simple   >= 0.5.2.0

                    , KindSignatures

                    , KindSignatures

  other-modules: Aftok.QConfig
               , Aftok.Snaplet
               , Aftok.Snaplet.Auctions
               , Aftok.Snaplet.Auth
               , Aftok.Snaplet.Projects
               , Aftok.Snaplet.Users
               , Aftok.Snaplet.Util
               , Aftok.Snaplet.WorkLog

    , bippy

{-# LANGUAGE TemplateHaskell #-}
module Aftok.Billables where
import           ClassyPrelude
import           Control.Lens               (makeLenses)
import           Data.UUID
import           Aftok.Time (Days(..))
newtype BillableId = BillableId UUID deriving (Show, Eq)
data BillingFrequency 
  = Annually
  | Monthly Int
  | SemiMonthly
  | Weekly Int
makeLenses ''BillingFrequency
data Recurrence
  = Recurring { _frequency :: BillingFrequency } 
  | OneTime   
makeLenses ''Recurrence
data Billable (p :: *) (c :: *) = Billable
  { _project :: p
  , _name :: Text
  , _description :: Text
  , _recurrence :: Recurrence
  , _amount :: c
  , _gracePeriod :: Days
  }
makeLenses ''Billable
monthly :: BillingFrequency
monthly = Monthly 1
bimonthly :: BillingFrequency
bimonthly = Monthly 2
quarterly :: BillingFrequency
quarterly = Monthly 3
seminannually :: BillingFrequency
seminannually = Monthly 6
annually :: BillingFrequency
annually = Annually

import           Database.PostgreSQL.Simple.FromField

import           Database.PostgreSQL.Simple.FromField 

import           Network.Haskoin.Crypto (addrToBase58)

btcAddrParser f v = BtcAddr <$> fromField f v

btcAddrParser f v = do
  addrMay <- parseBtcAddr <$> fromField f v
  let err = ConversionFailed { errSQLType = "text"
                             , errSQLTableOid = tableOid f
                             , errSQLField = maybe "" B.unpack (name f)
                             , errHaskellType = "BtcAddr"
                             , errMessage = "could not deserialize value to a valid BTC address"
                             }
  maybe (conversionError err) pure addrMay

      let err = UnexpectedNull (B.unpack tn)
                               (tableOid f)
                               (maybe "" B.unpack (name f))
                               "UTCTime -> LogEvent"
                               "columns of type event_t should not contain null values"

      let err = UnexpectedNull { errSQLType = B.unpack tn
                               , errSQLTableOid = tableOid f
                               , errSQLField = maybe "" B.unpack (name f)
                               , errHaskellType = "UTCTime -> LogEvent"
                               , errMessage = "columns of type event_t should not contain null values"
                               }

      let err = Incompatible (B.unpack tn)
                             (tableOid f)
                             (maybe "" B.unpack (name f))
                             "UTCTime -> LogEvent"
                             "column was not of type event_t"

      let err = Incompatible { errSQLType = B.unpack tn
                             , errSQLTableOid = tableOid f
                             , errSQLField = maybe "" B.unpack (name f)
                             , errHaskellType = "UTCTime -> LogEvent"
                             , errMessage = "column was not of type event_t"
                             }

       <*> fieldWith btcAddrParser

       <*> fieldWith (optionalField btcAddrParser)

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

          ( pid, uid, creditToName c, addr ^. _BtcAddr . to addrToBase58, eventName e, fromThyme $ e ^. eventTime, m)

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

          ( eid, fromThyme $ mt ^. _ModTime, creditToName c, addr ^. _BtcAddr . to addrToBase58 )

      , auc ^. (raiseAmount.to fromSatoshi)

      , auc ^. (raiseAmount . satoshi)

      , bid ^. (bidAmount.to fromSatoshi)

      , bid ^. (bidAmount . satoshi)

    pinsert UserId

    let addrMay :: Maybe ByteString
        addrMay = user' ^? (userAddress . traverse . _BtcAddr . to addrToBase58)
    in  pinsert UserId

      (user' ^. (username._UserName), user' ^. (userAddress._BtcAddr), user' ^. userEmail._Email)

      ( user' ^. (username._UserName)
      , addrMay
      , user' ^. userEmail._Email
      )

  dbEval (CreateBillable _) = error "Not implemented"
  dbEval (ReadBillable _) = error "Not implemented" 
  dbEval (CreatePaymentRequest _ _) = error "Not implemented"
  dbEval (CreatePayment _ ) = error "Not implemented"

import           Aftok.Billables  as B

import           Aftok.Payments

import           Aftok.Types

  CreateBillable   :: Billable ProjectId Satoshi -> DBOp BillableId
  ReadBillable     :: BillableId -> DBOp (Maybe (Billable ProjectId Satoshi))
  CreatePaymentRequest :: UserId -> PaymentRequest ProjectId BillableId -> DBOp PaymentRequestId
  CreatePayment        :: Payment PaymentRequestId UserId -> DBOp PaymentId

-- Billing ops

createBillable :: UserId -> Billable ProjectId Satoshi -> DBProg BillableId
createBillable uid b = withProjectAuth (b ^. B.project) uid $ CreateBillable b
readBillable :: BillableId -> DBProg (Maybe (Billable ProjectId Satoshi))
readBillable = fc . ReadBillable
--createPaymentRequest :: BillableId -> DBProg PaymentRequestId
--createPaymentRequest bid = do
--  billable <- readBillable bid
  
readPaymentHistory :: UserId -> DBProg [Payment PaymentRequestId UserId]
readPaymentHistory = error "Not yet implemented"

createBid :: AuctionId -> UserId -> Bid -> DBProg (BidId)

createBid :: AuctionId -> UserId -> Bid -> DBProg BidId

import qualified Data.Text                        as T

import           Aftok.Util (traverseKeys)

      , "raiseAmount"  .= (x ^. (raiseAmount._Satoshi))

      , "raiseAmount"  .= (x ^. (raiseAmount . satoshi))

parseCreditToV1 x = CreditToAddress <$> (parseBtcAddrJson =<< (x .: "btcAddr"))

parseCreditToV1 x = CreditToAddress <$> (parseJSON =<< (x .: "btcAddr"))

        fmap CreditToAddress . parseBtcAddrJson <$> O.lookup "creditToAddress" o'

        fmap CreditToAddress . parseJSON <$> O.lookup "creditToAddress" o'

  p (Version 1 _) v = Payouts . MS.mapKeys (CreditToAddress . BtcAddr) <$> parseJSON (Object v)

  p (Version 1 _) v = 
    let parseKey :: String -> Parser CreditTo
        parseKey k = maybe 
                     (fail $ "Key " <> k <> " cannot be parsed as a valid BTC address.") 
                     (pure . CreditToAddress) 
                     (parseBtcAddr $ T.pack k)
    in  Payouts <$> join (traverseKeys parseKey <$> parseJSON (Object v))
    

  p ver x = badVersion "Payouts" ver x

  p ver x = 
    badVersion "Payouts" ver x

parseBtcAddrJson :: Value -> Parser BtcAddr
parseBtcAddrJson v = do
  t <- parseJSON v
  maybe (fail $ show t <> " is not a valid BTC address") pure $ parseBtcAddr t

{-# LANGUAGE TemplateHaskell #-}
module Aftok.Payments where
import           ClassyPrelude
import           Control.Lens               (makeLenses)
import           Data.Thyme.Clock           as C
import           Data.UUID
import qualified Network.Bippy.Proto as P
newtype PaymentRequestId = PaymentRequestId UUID deriving (Show, Eq)
newtype PaymentId = PaymentId UUID deriving (Show, Eq)
data PaymentRequest (p :: *) (b :: *) = PaymentRequest
  { _project :: p
  , _paymentRequest :: P.PaymentRequest
  , _paymentRequestDate :: C.UTCTime
  , _billable :: b
  }
makeLenses ''PaymentRequest
data Payment r u = Payment
  { _request :: r
  , _payment :: P.Payment
  , _paymentDate :: C.UTCTime
  , _payor :: u
  }
makeLenses ''Payment

module Aftok.Time where
import           ClassyPrelude
newtype Days = Days Int

module Aftok.Types where

module Aftok.Types (Satoshi(..), satoshi) where

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

newtype Satoshi = Satoshi { fromSatoshi :: Word64 }
                  deriving (Show, Eq, Ord, Num, Real, Bounded)
makePrisms ''Satoshi

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

import           Data.Map.Strict as M

traverseKeys :: (Ord k, Applicative f) => (a -> f k) -> Map a b -> f (Map k b)
traverseKeys f m = 
  let insf a b m' = flip insert b <$> f a <*> m'
  in  foldrWithKey insf (pure M.empty) m

newtype BtcAddr = BtcAddr Text deriving (Show, Eq, Ord)

import           Network.Haskoin.Crypto (Address(..), base58ToAddr) 
newtype BtcAddr = BtcAddr Address deriving (Show, Eq, Ord)

parseBtcAddr = Just . BtcAddr -- FIXME: perform validation

parseBtcAddr addr = BtcAddr <$> (base58ToAddr . encodeUtf8) addr
instance FromJSON BtcAddr where
  parseJSON v = do
    t <- parseJSON v
    maybe (fail $ show t <> " is not a valid BTC address") pure $ parseBtcAddr t

  , _userAddress :: BtcAddr

  , _userAddress :: Maybe BtcAddr

  create extension if not exists "uuid-ossp";

  --create extension if not exists "uuid-ossp";

Description: Create tables for persistence of billable & payments data.
Created: 2016-12-31 03:45:38.125915 UTC
Depends: 2016-10-13_05-36-55_user-event-log
Apply: |
  create type aftok_event_t as enum(
    'create_user',
    'create_project',
    'add_user_to_project',
    'create_invitation',
    'accept_invitation',
    'create_event',
    'amend_event',
    'create_auction',
    'create_bid',
    'create_billable',
    'create_payment_request',
    'create_payment'
  );
  -- a log of raw events - the current state of the database
  -- should be reproducible by replaying the entire history of
  -- events
  create table if not exists aftok_events (
    id uuid primary key default uuid_generate_v4(),
    event_time timestamp with time zone not null,
    event_type aftok_event_t not null,
    event_json json not null
  );
  create type recurrence_t as enum ('onetime', 'weekly', 'semimonthly', 'monthly', 'annually');
  create table if not exists billables (
    id uuid primary key default uuid_generate_v4(),
    project_id uuid not null references projects(id),
    event_id uuid not null references aftok_events(id),
    name text not null,
    description text,
    recurrence_type recurrence_t not null,
    recurrence_count int,
    billing_amount numeric not null,
    grace_period_days int not null
  );
  create table if not exists subscriptions (
    id uuid primary key default uuid_generate_v4(),
    user_id uuid not null references users(id),
    billable_id uuid not null references billables(id),
    event_id uuid not null references aftok_events(id)
  );
  create table if not exists payment_requests (
    id uuid primary key default uuid_generate_v4(),
    subscription_id uuid not null references subscriptions(id),
    event_id uuid not null references aftok_events(id),
    request_data bytea not null
  );
  create table if not exists payments (
    id uuid primary key default uuid_generate_v4(),
    payment_request_id uuid not null references payment_requests(id),
    event_id uuid not null references aftok_events(id),
    payment_data bytea not null
  );
Revert: |
  drop table payments;
  drop table payment_requests;
  drop table subscriptions;
  drop table billables;
  drop table aftok_events;

module Aftok.Snaplet.Payments where
import           ClassyPrelude
import           Network.Bippy
import           Network.Bippy.Types
import           Snap.Core
import           Snap.Snaplet
requestPaymentHandler :: Handler App App 
requestPaymentHandler = do
  -- get payout percentages from payouts handler
  uid <- requireUserId
  pid <- requireProjectId
  ptime <- liftIO $ C.getCurrentTime
  payouts <- snapEval $ fc (ReadWorkIndex pid)
  pure $ payouts (toDepF $ project ^. depf) ptime widx
  -- look up the outstanding 
  undefined

    let parseUser = User <$> (UserName <$> v .: "username")
                         <*> (BtcAddr  <$> v .: "btcAddr")
                         <*> (Email    <$> v .: "email")

    let parseUser = User <$> (UserName      <$> v .: "username")
                         <*> (parseBtcAddr  <$> v .: "btcAddr")
                         <*> (Email         <$> v .: "email")

extra-deps: 
- snaplet-postgresql-simple-0.6.0.4

- location:
    git: git@github.com:aftok/bippy.git
    commit: 6284d5fff3954e0e52d559298364035a220867af
  extra-dep: true
allow-newer: true
extra-deps:
- aeson-0.11.2.1
- base-orphans-0.5.4
- bytestring-builder-0.10.8.1.0
- call-stack-0.1.0
- haskoin-core-0.4.0
- hspec-2.3.2
- hspec-core-2.3.2
- hspec-discover-2.3.2
- hspec-expectations-0.8.2
- mmorph-1.0.9
- mono-traversable-0.10.2
- murmur3-1.0.1
- pbkdf-1.1.1.1
- postgresql-libpq-0.9.2.0
- postgresql-simple-0.5.2.1

- secp256k1-0.4.5
- snaplet-postgresql-simple-0.6.0.4
- unix-compat-0.4.3.1
- vector-th-unbox-0.2.1.6

#allow-newer: true