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

Cabal-version: >= 1.22

Cabal-version: >= 2.0

  exposed-modules:    Aftok
                      Aftok.Auction

  exposed-modules:    Aftok.Auction

                      Aftok.Currency
                      Aftok.Currency.Bitcoin

                      Aftok.Database.PostgreSQL.Types

                      Aftok.TimeLog.Serialization

    , from-sum

    , haskoin-core 

    , haskoin-core 

import ClassyPrelude 

import ClassyPrelude

import           Network.Mail.Mime
import           Network.Mail.SMTP          as SMTP

import qualified Network.Mail.Mime          as Mime
import qualified Network.Mail.SMTP          as SMTP

import           Text.StringTemplate

import Network.Haskoin.Address (Address)
import Text.StringTemplate (directoryGroup, newSTMP, getStringTemplate, setManyAttrib, render)

import Aftok            (User, UserId, userEmail, _Email)
import Aftok.Types (satoshi)

import Aftok.Types            (User, UserId, ProjectId(..), userEmail, _Email)
import Aftok.Currency.Bitcoin (NetworkId, satoshi)

import           Aftok.Project (Project, ProjectId(..), projectName)

import           Aftok.Project (Project, projectName)

data AftokMEnv = AftokMEnv 

data AftokMEnv = AftokMEnv

  network = pcfg . P.network

  networkMode = pcfg . P.networkMode

liftQDBM (QDBM r) = 
  AftokM . mapReaderT (withExceptT DBErr) . withReaderT _conn $ r

liftQDBM (QDBM r) = do
  let f a = (a ^. dcfg . D.billingConfig . AC.networkMode, a ^. conn)
  AftokM . mapReaderT (withExceptT DBErr) . withReaderT f $ r

  let mailer = maybe (sendMailWithLogin _smtpHost) (sendMailWithLogin' _smtpHost) _smtpPort

  let mailer = maybe (SMTP.sendMailWithLogin _smtpHost) (SMTP.sendMailWithLogin' _smtpHost) _smtpPort

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

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

                         -> m Mail

                         -> m Mime.Mail

    Just template -> 

    Just template ->

          setAttrs = setManyAttrib 

          setAttrs = setManyAttrib

          fromAddr = Address Nothing ("billing@aftok.com")
          toAddr   = Address Nothing (toEmail ^. _Email)

          fromAddr = Mime.Address Nothing ("billing@aftok.com")
          toAddr   = Mime.Address Nothing (toEmail ^. _Email)

          body     = plainTextPart . render $ setAttrs template

          body     = SMTP.plainTextPart . render $ setAttrs template

memoGen :: Subscription' UserId Billable 
        -> T.Day 
        -> C.UTCTime 

memoGen :: Subscription' UserId Billable
        -> T.Day
        -> C.UTCTime

      setAttrs = setManyAttrib 

      setAttrs = setManyAttrib

import Aftok (Email(..))

import Aftok.Types (Email(..))

loadConfig cfgFile = 

loadConfig cfgFile =

readConfig cfg = Config 

readConfig cfg = Config

  <*> (AC.readBillingConfig $ C.subconfig "billing" cfg) 

  <*> (AC.readBillingConfig $ C.subconfig "billing" cfg)

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE TemplateHaskell    #-}
module Aftok where
import           ClassyPrelude
import           Control.Lens           (makeLenses, makePrisms)
import           Data.Aeson
import           Data.Aeson.Types
import           Data.Data
import           Data.UUID
import           Network.Haskoin.Crypto (Address (..), base58ToAddr)
newtype BtcAddr = BtcAddr Address deriving (Show, Eq, Ord)
makePrisms ''BtcAddr
parseBtcAddr :: Text -> Maybe BtcAddr
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
newtype Months = Months Integer
  deriving (Eq, Show, Data, Typeable)
data DepreciationFunction = LinearDepreciation Months Months
  deriving (Eq, Show, Data, Typeable)
newtype UserId = UserId UUID deriving (Show, Eq, Ord)
makePrisms ''UserId
newtype UserName = UserName Text deriving (Show, Eq)
makePrisms ''UserName
newtype Email = Email Text deriving (Show, Eq)
makePrisms ''Email
data User = User
  { _username    :: !UserName
  , _userAddress :: !(Maybe BtcAddr)
  , _userEmail   :: !Email
  }
makeLenses ''User
--                        | others tbd
instance ToJSON DepreciationFunction where
  toJSON (LinearDepreciation (Months up) (Months dp)) =
    object [ "type" .= ("LinearDepreciation" :: Text)
           , "arguments" .= object [ "undep" .= up
                                   , "dep" .= dp
                                   ]
           ]
instance FromJSON DepreciationFunction where
  parseJSON (Object v) = do
    t <- v .: "type" :: Parser Text
    args <- v .: "arguments"
    case unpack t of
      "LinearDepreciation" ->
        let undep = Months <$> (args .: "undep")
            dep   = Months <$> (args .: "dep")
        in  LinearDepreciation <$> undep <*> dep
      x -> fail $ "No depreciation function recognized for type " <> x
  parseJSON _ = mzero

import           ClassyPrelude

import           ClassyPrelude hiding (rem)

import           Data.Hourglass

import           Data.Hourglass (Seconds(..))
import           Data.Ratio ((%))
import           Data.Traversable (for)

import           Aftok               (UserId)
import           Aftok.Project       (ProjectId)
import           Aftok.Types         (Satoshi (..))

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

  } deriving (Eq, Show)

  } deriving (Eq)

  deriving (Show, Eq)

  deriving (Eq)

  foldl' (\s b -> s + (b^.bidAmount)) (Satoshi 0) bids

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

    btc  bid = toRational $ bid ^. bidAmount

    btc  bid = toRational $ bid ^. bidAmount . satoshi

        | total + (bid ^. bidAmount) < raiseAmount' =
          bid : takeWinningBids (total + (bid ^. bidAmount)) xs

        | total <> (bid ^. bidAmount) < raiseAmount' =
          bid : takeWinningBids (total <> (bid ^. bidAmount)) xs

          let remainder = raiseAmount' - total
              winFraction = toRational remainder / toRational (bid ^. bidAmount)
              remainderSeconds = Seconds . round $ winFraction * toRational (bid ^. bidSeconds)
          in  [bid & bidSeconds .~ remainderSeconds & bidAmount .~ remainder]

          let winFraction rem = rem % (bid ^. bidAmount . satoshi)
              remainderSeconds (Satoshi rem) = Seconds . round $ winFraction rem * fromIntegral (bid ^. bidSeconds)
              adjustBid rem = bid & bidSeconds .~ remainderSeconds rem & bidAmount .~ rem
          in  toList $ adjustBid <$> raiseAmount' `ssub` total

  in  if submittedTotal >= raiseAmount'
        then WinningBids $ takeWinningBids 0 $ sortBy bidOrder bids
        else InsufficientBids (raiseAmount' - submittedTotal)

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

    x | x + (bid ^. bidAmount) < raiseAmount' ->
      put (x + bid ^. bidAmount) >>

    x | x <> (bid ^. bidAmount) < raiseAmount' ->
      put (x <> bid ^. bidAmount) >>

      let remainder = raiseAmount' - x
          winFraction = toRational remainder / toRational (bid ^. bidAmount)
          remainderSeconds = Seconds . round $ winFraction * toRational (bid ^. bidSeconds)
      in  put (x + remainder) >>
          (pure . Just $ Commitment bid (remainderSeconds) remainder)

      let winFraction rem = rem % (bid ^. bidAmount . satoshi)
          remainderSeconds (Satoshi rem) = Seconds . round $ winFraction rem * fromIntegral (bid ^. bidSeconds)
      in  for (raiseAmount' `ssub` x) $ \remainder ->
            put (x <> remainder) *>
            (pure $ Commitment bid (remainderSeconds remainder) remainder)

import           Aftok            (UserId)
import           Aftok.Project    (ProjectId)
import           Aftok.Types      (Satoshi)

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

  } 

  }

import qualified Data.Configurator.Types       as CT

import qualified Data.Configurator.Types       as C

import Database.PostgreSQL.Simple              (ConnectInfo(..))
import Filesystem.Path.CurrentOS (FilePath, fromText, encodeString)

import           Database.PostgreSQL.Simple              (ConnectInfo(..))
import           Filesystem.Path.CurrentOS (FilePath, fromText, encodeString)

import Aftok.Currency.Bitcoin (NetworkMode)

  { _network                :: BT.Network

  { _networkMode            :: NetworkMode

  } 

  }

readSmtpConfig :: CT.Config -> IO SmtpConfig

readSmtpConfig :: C.Config -> IO SmtpConfig

readBillingConfig :: CT.Config -> IO BillingConfig

readBillingConfig :: C.Config -> IO BillingConfig

  BillingConfig <$> (parseNetwork <$> C.require cfg "network")

  BillingConfig <$> C.require cfg "networkMode"

  where parseNetwork :: String -> BT.Network
        parseNetwork "main" = BT.MainNet
        parseNetwork _      = BT.TestNet

readConnectInfo :: CT.Config -> IO ConnectInfo

readConnectInfo :: C.Config -> IO ConnectInfo

    Just (PrivKeyDSA _) -> fail "DSA keys not 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)

  pure $ PaymentsConfig (c ^. network) privKey pkiData

  pure $ PaymentsConfig (c ^. networkMode) privKey pkiData

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE TemplateHaskell            #-}
module Aftok.Currency.Bitcoin where
import           ClassyPrelude
import qualified Data.Configurator.Types as C
import           Control.Lens
import           Network.Bippy.Types (Satoshi (..))
import           Network.Haskoin.Constants
satoshi :: Lens' Satoshi Word64
satoshi inj (Satoshi value) = Satoshi <$> inj value
ssub :: Satoshi -> Satoshi -> Maybe Satoshi
ssub (Satoshi a) (Satoshi b) | a > b = Just . Satoshi $ (a - b)
ssub _ _ = Nothing
data NetworkId
  = BTC
  | BCH
  deriving (Eq, Show, Ord)
renderNetworkId :: NetworkId -> Text
renderNetworkId = \case
  BTC -> "btc"
  BCH -> "bch"
parseNetworkId :: Text -> Maybe NetworkId
parseNetworkId = \case
  "btc" -> Just BTC
  "bch" -> Just BCH
  _ -> Nothing
data NetworkMode
  = LiveMode
  | TestMode
parseNetworkMode :: Text -> Maybe NetworkMode
parseNetworkMode = \case
  "test" -> Just TestMode
  "live" -> Just LiveMode
  _ -> Nothing
instance C.Configured NetworkMode where
  convert (C.String t) = parseNetworkMode t
  convert _ = Nothing
toNetwork :: NetworkMode -> NetworkId -> Network
toNetwork LiveMode = \case
  BTC -> btc
  BCH -> bch
toNetwork TestMode = \case
  BTC -> btcTest
  BCH -> bchTest
toNetworkId :: Network -> Maybe NetworkId
toNetworkId n = case getNetworkName n of
  "btc" -> Just BTC
  "btcTest" -> Just BTC
  "bch" -> Just BCH
  "bchTest" -> Just BCH
  _ -> Nothing

module Aftok.Currency where
import           Data.Aeson (Value)
import           Data.Aeson.Types (Parser)
data Network a = Network
  { addressFromJSON :: Parser a
  , addressToJSON :: a -> Value
  }

module Aftok.Database.PostgreSQL.Types where
import           ClassyPrelude                        hiding (null)
import           Data.Aeson (FromJSON(..), ToJSON(..))
import           Aftok.TimeLog.Serialization (depfFromJSON, depfToJSON)
import           Aftok.Types (DepreciationFunction)
newtype SerDepFunction = SerDepFunction { unSerDepFunction :: DepreciationFunction }
instance FromJSON SerDepFunction where
  parseJSON v = SerDepFunction <$> depfFromJSON v
instance ToJSON SerDepFunction where
  toJSON (SerDepFunction depf) = depfToJSON depf

import           ClassyPrelude

import           ClassyPrelude                        hiding (null)

import           Network.Haskoin.Crypto               (addrToBase58)

import           Aftok

import           Aftok.Currency.Bitcoin

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

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

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

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

runQDBM :: Connection -> QDBM a -> ExceptT DBError IO a
runQDBM conn (QDBM r) = runReaderT r conn

runQDBM :: NetworkMode -> Connection -> QDBM a -> ExceptT DBError IO a
runQDBM mode conn (QDBM r) = runReaderT r (mode, conn)
null :: RowParser Null
null =  field

btcAddrParser :: FieldParser BtcAddr
btcAddrParser f v = do
  addrMay <- parseBtcAddr <$> fromField f v

networkIdParser :: FieldParser NetworkId
networkIdParser f b = do
  networkName <- fromField f b
  case networkName of
    Just "btc" -> pure BTC
    Just "bch" -> pure BCH
    Just other -> returnError ConversionFailed f ("Network identifier " <> other <> " is not supported.")
    Nothing    -> pure BTC
addressParser :: NetworkMode -> RowParser (NetworkId, Address)
addressParser mode = do
  networkId <- fieldWith (networkIdParser)
  address <- fieldWith $ addrFieldParser (toNetwork mode networkId)
  pure (networkId, address)
addrFieldParser :: Network -> FieldParser Address
addrFieldParser n f v = do
  addrMay <- stringToAddr n <$> fromField f v

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

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

creditToParser :: RowParser CreditTo
creditToParser = join $ fieldWith creditToParser'

creditToParser :: NetworkMode -> RowParser (CreditTo (NetworkId, Address))
creditToParser mode = join $ fieldWith (creditToParser' mode)

creditToParser' :: FieldParser (RowParser CreditTo)
creditToParser' f v =
  let parser :: Text -> RowParser CreditTo
      parser "credit_to_address"  = CreditToAddress <$> (fieldWith btcAddrParser <* nullField <* nullField)
      parser "credit_to_user"     = CreditToUser    <$> (nullField *> idParser UserId <* nullField)
      parser "credit_to_project"  = CreditToProject <$> (nullField *> nullField *> idParser P.ProjectId)

creditToParser' :: NetworkMode -> FieldParser (RowParser (CreditTo (NetworkId, Address)))
creditToParser' mode f 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)

logEntryParser :: RowParser LogEntry
logEntryParser =
  LogEntry <$> creditToParser

logEntryParser :: NetworkMode -> RowParser (LogEntry (NetworkId, Address))
logEntryParser mode =
  LogEntry <$> creditToParser mode

qdbLogEntryParser :: RowParser KeyedLogEntry
qdbLogEntryParser =
  (,,) <$> idParser P.ProjectId

qdbLogEntryParser :: NetworkMode -> RowParser (KeyedLogEntry (NetworkId, Address))
qdbLogEntryParser mode =
  (,,) <$> idParser ProjectId

       <*> logEntryParser

       <*> logEntryParser mode

  A.Auction <$> idParser P.ProjectId

  A.Auction <$> idParser ProjectId

userParser :: RowParser User
userParser =

userParser :: NetworkMode -> RowParser BTCUser
userParser mode =

       <*> fieldWith (optionalField btcAddrParser)

       <*> ((null *> null *> pure Nothing) <|> fmap Just (addressParser mode))

            <*> fieldWith fromJSONField

            <*> (unSerDepFunction <$> fieldWith fromJSONField)

  P.Invitation <$> idParser P.ProjectId

  P.Invitation <$> idParser ProjectId

  B.Billable <$> idParser P.ProjectId

  B.Billable <$> idParser ProjectId

  conn <- ask

  conn <- asks snd

  conn <- ask

  conn <- asks snd

  conn <- ask

  conn <- asks snd

  conn <- ask
  lift . ExceptT $ withTransaction conn (runExceptT $ runReaderT rt conn)

  env <- ask
  lift . ExceptT $ withTransaction (snd env) (runExceptT $ runReaderT rt env)

  pinsert EventId 
    [sql| INSERT INTO aftok_events 
          (event_time, created_by, event_type, event_json) 

  pinsert EventId
    [sql| INSERT INTO aftok_events
          (event_time, created_by, event_type, event_json)

askNetworkMode :: QDBM NetworkMode
askNetworkMode = QDBM $ asks fst

pgEval (CreateEvent (P.ProjectId pid) (UserId uid) (LogEntry c e m)) =

pgEval (CreateEvent (ProjectId pid) (UserId uid) (LogEntry c e m)) =

    CreditToAddress addr ->
      pinsert EventId 
        [sql| INSERT INTO work_events 

    CreditToCurrency (nid, addr) -> do
      mode <- askNetworkMode
      let network = toNetwork mode nid
      pinsert EventId
        [sql| INSERT INTO work_events

              , event_type, event_time, event_metadata ) 
              VALUES (?, ?, ?, ?, ?, ?, ?) 

              , event_type, event_time, event_metadata )
              VALUES (?, ?, ?, ?, ?, ?, ?)

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

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

      pinsert EventId 
        [sql| INSERT INTO work_events 

      pinsert EventId
        [sql| INSERT INTO work_events

              , event_type, event_time, event_metadata ) 
              VALUES (?, ?, ?, ?, ?, ?, ?) 

              , event_type, event_time, event_metadata )
              VALUES (?, ?, ?, ?, ?, ?, ?)

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

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

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

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

pgEval (FindEvent (EventId eid)) =
  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 

pgEval (FindEvent (EventId eid)) = do
  mode <- askNetworkMode
  headMay <$> pquery (qdbLogEntryParser mode)
    [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

pgEval (FindEvents (P.ProjectId pid) (UserId uid) ival) =
  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 

pgEval (FindEvents (ProjectId pid) (UserId uid) ival) = do
  mode <- askNetworkMode
  let q (Before e) = pquery (logEntryParser mode)
        [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

      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 = ? 

      q (During s e) = pquery (logEntryParser mode)
        [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 = ?

      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 

      q (After s) = pquery (logEntryParser mode)
        [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

  in  q ival

  q ival

  pinsert AmendmentId 
    [sql| INSERT INTO event_time_amendments 
          (event_id, amended_at, event_time) 

  pinsert AmendmentId
    [sql| INSERT INTO event_time_amendments
          (event_id, amended_at, event_time)

pgEval (AmendEvent (EventId eid) (CreditToChange mt c)) =

pgEval (AmendEvent (EventId eid) (CreditToChange mt c)) = do
  mode <- askNetworkMode

    CreditToAddress addr ->
      pinsert AmendmentId 
        [sql| INSERT INTO event_credit_to_amendments 
              (event_id, amended_at, credit_to_type, credit_to_btc_addr) 

    CreditToCurrency (nid, addr) -> do
      let network = toNetwork mode nid
      pinsert AmendmentId
        [sql| INSERT INTO event_credit_to_amendments
              (event_id, amended_at, credit_to_type, credit_to_btc_addr)

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

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

      pinsert AmendmentId 
        [sql| INSERT INTO event_credit_to_amendments 
              (event_id, amended_at, credit_to_type, credit_to_project_id) 

      pinsert AmendmentId
        [sql| INSERT INTO event_credit_to_amendments
              (event_id, amended_at, credit_to_type, credit_to_project_id)

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

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

      pinsert AmendmentId 
        [sql| INSERT INTO event_credit_to_amendments 
              (event_id, amended_at, credit_to_type, credit_to_user_id) 

      pinsert AmendmentId
        [sql| INSERT INTO event_credit_to_amendments
              (event_id, amended_at, credit_to_type, credit_to_user_id)

  pinsert AmendmentId 
    [sql| INSERT INTO event_metadata_amendments 
          (event_id, amended_at, event_metadata) 

  pinsert AmendmentId
    [sql| INSERT INTO event_metadata_amendments
          (event_id, amended_at, event_metadata)

pgEval (ReadWorkIndex (P.ProjectId pid)) = do
  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 

pgEval (ReadWorkIndex (ProjectId pid)) = do
  mode <- askNetworkMode
  logEntries <- pquery (logEntryParser mode)
    [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

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

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

    ( auc ^. (A.projectId . P._ProjectId)

    ( auc ^. (A.projectId . _ProjectId)

  headMay <$> pquery auctionParser 
    [sql| SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time 
          FROM auctions 

  headMay <$> pquery auctionParser
    [sql| SELECT project_id, initiator_id, created_at, raise_amount, start_time, end_time
          FROM auctions

  pinsert A.BidId 
    [sql| INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time) 

  pinsert A.BidId
    [sql| INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time)

  pquery ((,) <$> idParser A.BidId <*> bidParser) 

  pquery ((,) <$> idParser A.BidId <*> bidParser)

pgEval (CreateUser user') =
  let addrMay :: Maybe ByteString
      addrMay = user' ^? (userAddress . traverse . _BtcAddr . to addrToBase58)
  in  pinsert UserId 
    [sql| INSERT INTO users (handle, btc_addr, email) VALUES (?, ?, ?) RETURNING id |]

pgEval (CreateUser user') = do
  mode <- askNetworkMode
  let nidMay = fst <$> _userAddress user'
      addrMay :: Maybe Text
      addrMay = do
        network <- toNetwork mode <$> nidMay
        address <- snd <$> _userAddress user'
        pure $ addrToString network address
  pinsert UserId
    [sql| INSERT INTO users (handle, network, addr, email)
          VALUES (?, ?, ?, ?) RETURNING id |]

    , renderNetworkId <$> nidMay

pgEval (FindUser (UserId uid)) =
  headMay <$> pquery userParser 

pgEval (FindUser (UserId uid)) = do
  mode <- askNetworkMode
  headMay <$> pquery (userParser mode)

pgEval (FindUserByName (UserName h)) =
  headMay <$> pquery ((,) <$> idParser UserId <*> userParser) 

pgEval (FindUserByName (UserName h)) = do
  mode <- askNetworkMode
  headMay <$> pquery ((,) <$> idParser UserId <*> userParser mode)

pgEval (CreateInvitation (P.ProjectId pid) (UserId uid) (Email e) t) = do

pgEval (CreateInvitation (ProjectId pid) (UserId uid) (Email e) t) = do

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

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

  headMay <$> pquery invitationParser 
    [sql| SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time 

  headMay <$> pquery invitationParser
    [sql| SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time

  void $ pexec 

  void $ pexec

  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 

  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

  pinsert P.ProjectId 
    [sql| INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn) 

  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)

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

  pquery (idParser P.ProjectId)

  pquery (idParser ProjectId)

    [sql| SELECT s.user_id 
          FROM subscripions s 
          JOIN billables b ON s.billable_id = b.id 

    [sql| SELECT s.user_id
          FROM subscripions s
          JOIN billables b ON s.billable_id = b.id

    (Only (pid ^. P._ProjectId))

    (Only (pid ^. _ProjectId))

pgEval (FindProject (P.ProjectId pid)) =
  headMay <$> pquery projectParser 

pgEval (FindProject (ProjectId pid)) =
  headMay <$> pquery projectParser

  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 = ? 

  pquery ((,) <$> idParser 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 = ?

  pexec 

  pexec

    (pid ^. P._ProjectId, new ^. _UserId, current ^. _UserId)

    (pid ^. _ProjectId, new ^. _UserId, current ^. _UserId)

pgEval dbop @ (CreateBillable _ b) = do

pgEval dbop@(CreateBillable _ b) = do

  pinsert B.BillableId 
    [sql| INSERT INTO billables 
          ( project_id, event_id, name, description 
          , recurrence_type, recurrence_count 

  pinsert B.BillableId
    [sql| INSERT INTO billables
          ( project_id, event_id, name, description
          , recurrence_type, recurrence_count

          , payment_request_memo_template) 

          , payment_request_memo_template)

    ( b ^. (B.project . P._ProjectId)

    ( b ^. (B.project . _ProjectId)

  headMay <$> pquery billableParser 
    [sql| SELECT b.project_id, e.created_by, b.name, b.description, 
                 b.recurrence_type, b.recurrence_count, 

  headMay <$> pquery billableParser
    [sql| SELECT b.project_id, e.created_by, b.name, b.description,
                 b.recurrence_type, b.recurrence_count,

          FROM billables b JOIN aftok_events e ON e.id = b.event_id 

          FROM billables b JOIN aftok_events e ON e.id = b.event_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 

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

          FROM billables b JOIN aftok_events e ON e.id = b.event_id 

          FROM billables b JOIN aftok_events e ON e.id = b.event_id

    (Only (pid ^. P._ProjectId))

    (Only (pid ^. _ProjectId))

pgEval dbop @ (CreateSubscription uid bid start_date) = do

pgEval dbop@(CreateSubscription uid bid start_date) = do

  pinsert B.SubscriptionId 
    [sql| INSERT INTO subscriptions 
          (user_id, billable_id, event_id, start_date) 

  pinsert B.SubscriptionId
    [sql| INSERT INTO subscriptions
          (user_id, billable_id, event_id, start_date)

  headMay <$> pquery subscriptionParser 
    [sql| SELECT id, billable_id, start_date, end_date 
          FROM subscriptions s 

  headMay <$> pquery subscriptionParser
    [sql| SELECT id, billable_id, start_date, end_date
          FROM subscriptions s

  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 = ? 

  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 = ?

    (uid ^. _UserId, pid ^. P._ProjectId)

    (uid ^. _UserId, pid ^. _ProjectId)

pgEval dbop @ (CreatePaymentRequest req) = do

pgEval dbop@(CreatePaymentRequest req) = do

  pinsert PaymentRequestId 
    [sql| INSERT INTO payment_requests 
          (subscription_id, event_id, request_data, url_key, request_time, billing_date) 

  pinsert PaymentRequestId
    [sql| INSERT INTO payment_requests
          (subscription_id, event_id, request_data, url_key, request_time, billing_date)

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

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

  [sql| SELECT subscription_id, request_data, url_key, request_time, billing_date 
        FROM payment_requests 

  [sql| SELECT subscription_id, request_data, url_key, request_time, billing_date
        FROM payment_requests

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

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

  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, 

  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,

            FROM payment_requests r 
            JOIN subscriptions s on s.id = r.subscription_id 
            JOIN billables b on b.id = s.billable_id 

            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 = ? 

            WHERE subscription_id = ?

pgEval dbop @ (CreatePayment p) = do

pgEval dbop@(CreatePayment p) = do

  pinsert PaymentId 
    [sql| INSERT INTO payments 
          (payment_request_id, event_id, payment_data, payment_date, exchange_rates) 

  pinsert PaymentId
    [sql| INSERT INTO payments
          (payment_request_id, event_id, payment_data, payment_date, exchange_rates)

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

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

import           Aftok

import           Aftok.Types

import           Aftok.Currency.Bitcoin    (NetworkId)

type KeyedLogEntry = (ProjectId, UserId, LogEntry)
type InvitingUID   = UserId
type InvitedUID    = UserId

import           Network.Haskoin.Address   (Address)
type KeyedLogEntry a = (ProjectId, UserId, LogEntry a)
type InvitingUID     = UserId
type InvitedUID      = UserId
type BTCNet = (NetworkId, Address)
type BTCUser = User BTCNet

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

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

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

  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)

createUser :: (MonadDB m) => User -> m UserId

createUser :: (MonadDB m) => BTCUser -> m UserId

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

findUser :: (MonadDB m) => UserId -> MaybeT m BTCUser

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

findUserByName :: (MonadDB m) => UserName -> MaybeT m (UserId, BTCUser)

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

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

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

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

findEvent :: (MonadDB m) => EventId -> m (Maybe KeyedLogEntry)

findEvent :: (MonadDB m) => EventId -> m (Maybe (KeyedLogEntry BTCNet))

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

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

readWorkIndex :: (MonadDB m) => ProjectId -> UserId -> m WorkIndex

readWorkIndex :: (MonadDB m) => ProjectId -> UserId -> m (WorkIndex BTCNet)

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

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

{-# LANGUAGE LambdaCase         #-}

{-# LANGUAGE TupleSections      #-}

import           ClassyPrelude                    hiding (Day)

import           ClassyPrelude                    hiding (Day, fail, fromEitherM, UTCTime)

import           Control.FromSum                  (fromMaybeM, fromEitherM)

import           Control.Monad.Fail               (MonadFail(..))

import           Data.Thyme.Clock                 as C

import           Data.Thyme.Clock                 as Clock

import           Aftok

import           Network.Haskoin.Address          (Address, addrToJSON, addrFromJSON, stringToAddr)
import           Aftok.Currency.Bitcoin

instance Show Version where
  show Version{..} = intercalate "." $ fmap show [majorVersion, minorVersion]

failT :: Text -> Parser a
failT = fail . T.unpack
printVersion :: Version -> Text
printVersion Version{..} = T.intercalate "." $ fmap (pack . show) [majorVersion, minorVersion]

version :: QuasiQuoter
version = 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."
                      }

version :: MonadFail m => ByteString -> m Version
version = fromEitherM fail . PC.parseOnly versionParser
v :: QuasiQuoter
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 <- either (fail . show) pure $ PC.parseOnly versionParser (C.pack s)
  dataToExpQ (const Nothing) v

  ver <- version $ C.pack s
  dataToExpQ (const Nothing) ver

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

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

  vers   <- either fail pure $ PC.parseOnly versionParser (encodeUtf8 verstr)

  vers   <- fromEitherM fail $ PC.parseOnly versionParser (encodeUtf8 verstr)

badVersion name ver = const . fail $ "Unrecognized " <> name <> " schema version: " <> show ver

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

idValue l a = toJSON . tshow $ view l a

idValue l a = toJSON . U.toText $ view l a

--
-- CreditTo
--

creditToJSON :: CreditTo -> Value
creditToJSON (CreditToAddress addr) = v2 $ obj [ "creditToAddress" .= (addr ^. _BtcAddr) ]
creditToJSON (CreditToUser uid)     = v2 $ obj [ "creditToUser"    .= idValue _UserId uid ]
creditToJSON (CreditToProject pid)  = v2 $ obj [ "creditToProject" .= projectIdJSON pid ]

creditToJSON :: NetworkMode -> CreditTo (NetworkId, Address) -> Value
creditToJSON nmode (CreditToCurrency (netId, addr)) =
  v2 $ obj [ "creditToAddress" .= addrToJSON (toNetwork nmode netId) addr
           , "creditToNetwork" .= renderNetworkId netId
           ]
creditToJSON _ (CreditToUser uid) =
  v2 $ obj [ "creditToUser"    .= idValue _UserId uid ]
creditToJSON _ (CreditToProject pid) =
  v2 $ obj [ "creditToProject" .= projectIdJSON pid ]
parseCreditTo :: NetworkMode -> Value -> Parser (CreditTo (NetworkId, Address))
parseCreditTo nmode = unversion "CreditTo" $ \case
  (Version 1 0) -> parseCreditToV1 nmode
  (Version 2 0) -> parseCreditToV2 nmode
  ver           -> badVersion "EventAmendment" ver
parseBtcAddr
  :: NetworkMode
  -> NetworkId
  -> Text
  -> Parser (CreditTo (NetworkId, Address))
parseBtcAddr nmode net addrText =
  maybe
    (fail . unpack $ "Address " <> addrText <> " cannot be parsed as a BTC network address.")
    (pure . CreditToCurrency . (net,))
    (stringToAddr (toNetwork nmode net) addrText)
parseCreditToV1
  :: NetworkMode
  -> Object
  -> Parser (CreditTo (NetworkId, Address))
parseCreditToV1 nmode x = do
  parseBtcAddr nmode BTC =<< x .: "btcAddr"
parseCreditToV2 :: NetworkMode -> Object -> Parser (CreditTo (NetworkId, Address))
parseCreditToV2 nmode o =
  let parseCreditToAddr = do
        netName <- o .: "creditToNetwork"
        net <- fromMaybeM
          (fail . T.unpack $ "Currency network " <> netName <> " not recognized.")
          (parseNetworkId netName)
        addrValue <- o .: "creditToAddress"
        CreditToCurrency . (net,) <$> addrFromJSON (toNetwork nmode net) addrValue
      parseCreditToUser =
        fmap CreditToUser . parseId _UserId =<< o .: "creditToUser"
      parseCreditToProject =
        fmap CreditToProject . parseId _ProjectId =<< o .: "creditToProject"
      notFound = fail $ "Value " <> show o <> " does not represent a CreditTo value."
  in  parseCreditToAddr <|> parseCreditToUser <|> parseCreditToProject <|> notFound
--
-- Payouts
--

payoutsJSON :: Payouts -> Value
payoutsJSON (Payouts m) = v2 $
  let payoutsRec :: (CreditTo, Rational) -> Value
      payoutsRec (c, r) = object [ "creditTo" .= creditToJSON c

payoutsJSON :: NetworkMode -> Payouts (NetworkId, Address)-> Value
payoutsJSON nmode (Payouts m) = v2 $
  let payoutsRec :: (CreditTo (NetworkId, Address), Rational) -> Value
      payoutsRec (c, r) = object [ "creditTo" .= creditToJSON nmode c

parsePayoutsJSON :: NetworkMode -> Value -> Parser (Payouts (NetworkId, Address))
parsePayoutsJSON nmode = unversion "Payouts" $ p where
  p :: Version -> Object -> Parser (Payouts (NetworkId, Address))
  p (Version 1 _) val =
    Payouts <$> join (traverseKeys (parseBtcAddr nmode BTC) <$> parseJSON (Object val))
  p (Version 2 0) val =
    let parsePayoutRecord x = (,) <$> (parseCreditToV2 nmode =<< (x .: "creditTo"))
                                  <*> (x .: "payoutRatio")
    in  Payouts . MS.fromList <$> (traverse parsePayoutRecord =<< parseJSON (Object val))
  p ver x =
    badVersion "Payouts" ver x

workIndexJSON :: WorkIndex -> Value
workIndexJSON (WorkIndex widx) = v2 $
  let widxRec :: (CreditTo, NonEmpty Interval) -> Value
      widxRec (c, l) = object [ "creditTo"  .= creditToJSON c

--
-- WorkIndex
--
workIndexJSON :: NetworkMode -> WorkIndex (NetworkId, Address) -> Value
workIndexJSON nmode (WorkIndex widx) = v2 $
  let widxRec :: (CreditTo (NetworkId, Address), NonEmpty Interval) -> Value
      widxRec (c, l) = object [ "creditTo"  .= creditToJSON nmode c

logEntryJSON :: LogEntry -> Value
logEntryJSON (LogEntry c ev m) = v2 $
  obj [ "creditTo"  .= creditToJSON c

logEntryJSON :: NetworkMode -> LogEntry (NetworkId, Address) -> Value
logEntryJSON nmode (LogEntry c ev m) = v2 $
  obj [ "creditTo"  .= creditToJSON nmode c

  , "requestExpiryPeriod" .= (C.toSeconds' <$> (b ^. B.requestExpiryPeriod))

  , "requestExpiryPeriod" .= (Clock.toSeconds' <$> (b ^. B.requestExpiryPeriod))

  where 

  where

  where 

  where

parseUUID v = do
  str <- parseJSON v

parseUUID val = do
  str <- parseJSON val

parseId p = fmap (review p) . parseUUID 
parseCreditTo :: Value -> Parser CreditTo
parseCreditTo = unversion "CreditTo" $ p where
  p (Version 1 0) = parseCreditToV1
  p (Version 2 0) = parseCreditToV2
  p ver           = badVersion "EventAmendment" ver
parseCreditToV1 :: Object -> Parser CreditTo
parseCreditToV1 x = CreditToAddress <$> (parseJSON =<< (x .: "btcAddr"))
parseCreditToV2 :: Object -> Parser CreditTo
parseCreditToV2 o =
  let parseCreditToAddr o' =
        fmap CreditToAddress . parseJSON <$> O.lookup "creditToAddress" o'
      parseCreditToUser o' =
        fmap CreditToUser . parseId _UserId <$> O.lookup "creditToUser" o'
      parseCreditToProject o' =
        fmap CreditToProject . parseId _ProjectId <$> O.lookup "creditToProject" o'
      notFound = fail $ "Value " <> show o <> " does not represent a CreditTo value."
      parseV v = (parseCreditToAddr v <|> parseCreditToUser v <|> parseCreditToProject v)
  in  fromMaybe notFound $ parseV o
parsePayoutsJSON :: Value -> Parser Payouts
parsePayoutsJSON = unversion "Payouts" $ p where
  p :: Version -> Object -> Parser Payouts
  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 (Version 2 0) v =
    let parsePayoutRecord x = (,) <$> (parseCreditToV2 =<< (x .: "creditTo")) <*> x .: "payoutRatio"
    in  Payouts . MS.fromList <$> (traverse parsePayoutRecord =<< parseJSON (Object v))

parseId p = fmap (review p) . parseUUID

  p ver x =
    badVersion "Payouts" ver x
parseEventAmendment :: ModTime -> Value -> Parser EventAmendment
parseEventAmendment t = unversion "EventAmendment" $ p where
  p (Version 1 _) = parseEventAmendmentV1 t
  p (Version 2 0) = parseEventAmendmentV2 t

parseEventAmendment
  :: NetworkMode
  -> ModTime
  -> Value
  -> Parser (EventAmendment (NetworkId, Address))
parseEventAmendment nmode t = unversion "EventAmendment" $ p where
  p (Version 1 _) = parseEventAmendmentV1 nmode t
  p (Version 2 0) = parseEventAmendmentV2 nmode t

parseEventAmendmentV1 :: ModTime -> Object -> Parser EventAmendment
parseEventAmendmentV1 t o =
  let parseA :: Text -> Parser EventAmendment

parseEventAmendmentV1
  :: NetworkMode
  -> ModTime
  -> Object
  -> Parser (EventAmendment (NetworkId, Address))
parseEventAmendmentV1 nmode t o =
  let parseA :: Text -> Parser (EventAmendment (NetworkId, Address))

      parseA "addrChange"     = CreditToChange t <$> parseCreditToV1 o

      parseA "addrChange"     = CreditToChange t <$> parseCreditToV1 nmode o

      parseA tid = fail . show $ "Amendment type " <> tid <> " not recognized."

      parseA tid = fail . unpack $ "Amendment type " <> tid <> " not recognized."

parseEventAmendmentV2 :: ModTime -> Object -> Parser EventAmendment
parseEventAmendmentV2 t o =
  let parseA :: Text -> Parser EventAmendment

parseEventAmendmentV2
  :: NetworkMode
  -> ModTime
  -> Object
  -> Parser (EventAmendment (NetworkId, Address))
parseEventAmendmentV2 nmode t o =
  let parseA :: Text -> Parser (EventAmendment (NetworkId, Address))

      parseA "creditToChange" = CreditToChange t <$> parseCreditToV2 o

      parseA "creditToChange" = CreditToChange t <$> parseCreditToV2 nmode o

      parseA tid = fail . show $ "Amendment type " <> tid <> " not recognized."

      parseA tid = fail . unpack  $ "Amendment type " <> tid <> " not recognized."

parseLogEntry :: UserId -> (C.UTCTime -> LogEvent) -> Value -> Parser (C.UTCTime -> LogEntry)
parseLogEntry uid f = unversion "LogEntry" p where

parseLogEntry
  :: NetworkMode
  -> UserId
  -> (UTCTime -> LogEvent)
  -> Value
  -> Parser (UTCTime -> (LogEntry (NetworkId, Address)))
parseLogEntry nmode uid f = unversion "LogEntry" p where

    creditTo'  <- o .:? "creditTo" >>= maybe (pure $ CreditToUser uid) parseCreditToV2

    creditTo'  <- o .:? "creditTo" >>= maybe (pure $ CreditToUser uid) (parseCreditToV2 nmode)

  p v o = badVersion "LogEntry" v o

  p ver o = badVersion "LogEntry" ver o

parseRecurrence o = 

parseRecurrence o =

      parseV v = parseAnnually v <|> parseMonthly v <|> parseWeekly v <|> parseOneTime v

      parseV val = parseAnnually val
               <|> parseMonthly val
               <|> parseWeekly val
               <|> parseOneTime val

parseRecurrence' v = fail $ "Value " <> show v <> " is not a JSON object."

parseRecurrence' val = fail $ "Value " <> show val <> " is not a JSON object."

import           Network.Haskoin.Crypto (decodeBase58Check)

import           Network.Haskoin.Address.Base58 (decodeBase58Check)

parsePaymentKey bs = (PaymentKey . decodeUtf8) <$> decodeBase58Check bs

parsePaymentKey bs = (PaymentKey . decodeUtf8) <$> decodeBase58Check (decodeUtf8 bs)

import           Network.Haskoin.Crypto  (encodeBase58Check)

import           Network.Haskoin.Address (Address(..))
import           Network.Haskoin.Address.Base58 (encodeBase58Check)

import           Aftok                   (BtcAddr (..), UserId, userAddress,
                                          _BtcAddr)

import           Aftok.Types             (UserId, ProjectId, userAddress)

import           Aftok.Currency.Bitcoin  (NetworkId(..), NetworkMode, satoshi, toNetwork)

import           Aftok.Project           (ProjectId, depf)

import           Aftok.Project           (depf)

import           Aftok.Types             (satoshi)

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

  { _networkMode  :: !NetworkMode
  , _signingKey   :: !RSA.PrivateKey
  , _pkiData      :: !BT.PKIData

  , uriGen     :: PaymentKey                    -- ^ payment key to be included in the URL 

  , uriGen     :: PaymentKey                    -- ^ payment key to be included in the URL

               -> m (Maybe ByteString) 

               -> m (Maybe ByteString)

  | IllegalAddress !Address

  pkey    <- PaymentKey . decodeUtf8 . encodeBase58Check <$> getRandomBytes 32

  pkey    <- PaymentKey . encodeBase58Check <$> getRandomBytes 32

createPaymentDetails :: (MonadRandom m, MonadReader r m, HasPaymentsConfig r, MonadDB m)
                     => T.Day              -- ^ payout date (billing date)
                     -> C.UTCTime          -- ^ timestamp of payment request creation
                     -> Maybe Text         -- ^ user memo
                     -> Maybe URI          -- ^ payment response URL
                     -> Maybe ByteString   -- ^ merchant payload
                     -> Billable           -- ^ billing information
                     -> m P.PaymentDetails

createPaymentDetails
  :: ( MonadRandom m
     , MonadReader r m , HasPaymentsConfig r
     , MonadError e m, AsPaymentError e
     , MonadDB m
     )
  => T.Day              -- ^ payout date (billing date)
  -> C.UTCTime          -- ^ timestamp of payment request creation
  -> Maybe Text         -- ^ user memo
  -> Maybe URI          -- ^ payment response URL
  -> Maybe ByteString   -- ^ merchant payload
  -> Billable           -- ^ billing information
  -> m P.PaymentDetails

    (cfg ^. network)

    (toNetwork (cfg ^. networkMode) BTC)

getProjectPayouts :: (MonadDB m) => C.UTCTime -> ProjectId -> m TL.Payouts

getProjectPayouts
  :: (MonadDB m, MonadError e m, AsPaymentError e)
  => C.UTCTime
  -> ProjectId
  -> m (TL.Payouts (NetworkId, Address))

createPayoutsOutputs :: (MonadDB m) => C.UTCTime -> BT.Satoshi -> TL.Payouts -> m [BT.Output]

createPayoutsOutputs
  :: (MonadDB m, MonadError e m, AsPaymentError e)
  => C.UTCTime
  -> BT.Satoshi
  -> TL.Payouts (NetworkId, Address)
  -> m [BT.Output]

  let payoutFractions :: [(TL.CreditTo, BT.Satoshi)]

  let payoutFractions :: [(TL.CreditTo (NetworkId, Address), BT.Satoshi)]

createOutputs :: (MonadDB m) => C.UTCTime -> TL.CreditTo -> BT.Satoshi -> m [BT.Output]
createOutputs _ (TL.CreditToAddress (BtcAddr addr)) amt =

createOutputs
  :: (MonadDB m, MonadError e m, AsPaymentError e)
  => C.UTCTime
  -> TL.CreditTo (NetworkId, Address)
  -> BT.Satoshi
  -> m [BT.Output]
createOutputs _ (TL.CreditToCurrency (BTC, (PubKeyAddress addr))) amt =

createOutputs _ (TL.CreditToCurrency (_, other)) _ =
  throwError $ review _IllegalAddress other

  addr <- MaybeT . pure $ user ^. userAddress
  pure $ BT.Output amt (PayPKHash (addr ^. _BtcAddr))

  addr <- MaybeT . pure . fmap snd $ user ^. userAddress
  case addr of
    PubKeyAddress a -> pure $ BT.Output amt (PayPKHash a)
    other -> throwError $ review _IllegalAddress other

import           Data.UUID
import           Aftok

newtype ProjectId = ProjectId UUID deriving (Show, Eq, Ord)
makePrisms ''ProjectId

import           Aftok.Types

{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NoImplicitPrelude  #-}
module Aftok.TimeLog.Serialization
  ( depfFromJSON
  , depfToJSON
  ) where
import ClassyPrelude
import Control.Applicative ((<*>))
import Data.Aeson          (Value(..), (.=), (.:), object)
import Data.Aeson.Types    (Parser)
import Data.Functor        ((<$>))
import Aftok.Types
depfToJSON :: DepreciationFunction -> Value
depfToJSON = \case
  LinearDepreciation (Months up) (Months dp) ->
    object [ "type" .= ("LinearDepreciation" :: Text)
           , "arguments" .= object [ "undep" .= up
                                   , "dep" .= dp
                                   ]
           ]
depfFromJSON :: Value -> Parser DepreciationFunction
depfFromJSON = \case
  Object v -> do
    t <- v .: "type" :: Parser Text
    args <- v .: "arguments"
    case unpack t of
      "LinearDepreciation" ->
        let undep = Months <$> (args .: "undep")
            dep   = Months <$> (args .: "dep")
        in  LinearDepreciation <$> undep <*> dep
      x -> fail $ "No depreciation function recognized for type " <> x
  _ ->
    fail $ "Cannot interpret non-object value as a depreciation function."

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE NoImplicitPrelude  #-}

  , CreditTo(..), _CreditToAddress, _CreditToUser, _CreditToProject, creditToName

  , CreditTo(..), _CreditToCurrency, _CreditToUser, _CreditToProject, creditToName

import           ClassyPrelude

import           Control.Arrow      ((&&&))

import           Data.Eq            (Eq, (==))
import           Data.Either        (Either(..), rights)

import           Data.Function      (($), (.), id)
import           Data.Functor       (fmap)

import           Data.Maybe         (Maybe(..))

import           Data.Ratio         ()

import           Data.Ord           (Ord(..), Ordering(..))
import           Data.Ratio         (Rational)
import           Data.Text          (Text)

import           Prelude            ((/), (*))
import           Text.Show          (Show)

import           Aftok

import           Aftok.Project      (ProjectId)

import           Aftok.Types
type NDT = C.NominalDiffTime

{-|
 - The depreciation function should return a value between 0 and 1;
 - this result is multiplied by the length of an interval of work to determine
 - the depreciated value of the work.
 -}
type DepF = C.UTCTime -> Interval -> NDT

nameEvent :: MonadPlus m => Text -> m (C.UTCTime -> LogEvent)
nameEvent "start" = pure StartWork
nameEvent "stop"  = pure StopWork
nameEvent _       = mzero
data CreditTo
  -- payouts are made directly to this address, or to an address replacing this one
  = CreditToAddress !BtcAddr
  -- payouts are distributed as requested by the specified contributor
  | CreditToUser !UserId
  -- payouts are distributed to this project's contributors
  | CreditToProject !ProjectId
  deriving (Show, Eq, Ord)
makePrisms ''CreditTo

creditToName :: CreditTo -> Text
creditToName (CreditToAddress _) = "credit_to_address"
creditToName (CreditToUser _)    = "credit_to_user"
creditToName (CreditToProject _) = "credit_to_project"

nameEvent :: Text -> Maybe (C.UTCTime -> LogEvent)
nameEvent "start" = Just StartWork
nameEvent "stop"  = Just StopWork
nameEvent _       = Nothing

data LogEntry = LogEntry
  { _creditTo  :: !CreditTo

data LogEntry a = LogEntry
  { _creditTo  :: !(CreditTo a)

instance Ord LogEntry where

instance Ord a => Ord (LogEntry a) where

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

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

newtype Payouts = Payouts (Map CreditTo Rational)

newtype Payouts a = Payouts (Map (CreditTo a) Rational)

newtype WorkIndex = WorkIndex (Map CreditTo (NonEmpty Interval)) deriving (Show, Eq)

newtype WorkIndex a = WorkIndex (Map (CreditTo a) (NonEmpty Interval)) deriving (Show, Eq)

type NDT = C.NominalDiffTime
{-|
 - The depreciation function should return a value between 0 and 1;
 - this result is multiplied by the length of an interval of work to determine
 - the depreciated value of the work.
 -}
type DepF = C.UTCTime -> Interval -> NDT

payouts :: DepF -> C.UTCTime -> WorkIndex -> Payouts