import Aftok.Currency.Bitcoin
  ( _Satoshi,
    ssub,

import Aftok.Currency
  ( IsCurrency (..),

import Bippy.Types (Satoshi (..))

import Data.Traversable (for)

data Auction

data Auction c

        _raiseAmount :: Satoshi,

        _raiseAmount :: c,

data Bid

data Bid c

        _bidAmount :: Satoshi,

        _bidAmount :: c,

data Commitment

data Commitment c

      { _baseBid :: Bid,

      { _baseBid :: Bid c,

        _commitmentAmount :: Satoshi

        _commitmentAmount :: c

data AuctionResult
  = WinningBids [Bid]
  | InsufficientBids Satoshi

data AuctionResult c
  = WinningBids [Bid c]
  | InsufficientBids c

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

bidsTotal :: Monoid c => [Bid c] -> c
bidsTotal = foldMap (view bidAmount)

bidOrder :: Bid -> Bid -> Ordering
bidOrder = comparing costRatio `mappend` comparing (^. bidTime)

bidOrder ::
  forall c.
  IsCurrency c =>
  Bid c ->
  Bid c ->
  Ordering
bidOrder = comparing costRatio <> comparing (^. bidTime)

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

    costRatio :: Bid c -> Rational
    costRatio bid = (toRational $ bid ^. bidSeconds) / (toRational $ bid ^. bidAmount . _Units)

runAuction :: Auction -> [Bid] -> AuctionResult

runAuction :: IsCurrency c => Auction c -> [Bid c] -> AuctionResult c

runAuction' :: Satoshi -> [Bid] -> AuctionResult

runAuction' ::
  forall c.
  IsCurrency c =>
  c ->
  [Bid c] ->
  AuctionResult c

  let takeWinningBids :: Satoshi -> [Bid] -> [Bid]

  let takeWinningBids :: c -> [Bid c] -> [Bid c]

        | -- if the total is fully within the raise amount
          total <> (bid ^. bidAmount) < raiseAmount' =

        | total <> (bid ^. bidAmount) < raiseAmount' =
          -- if the total is fully within the raise amount

        | -- if the last bid will exceed the raise amount, reduce it to fit
          total < raiseAmount' =
          let winFraction r = r % (bid ^. bidAmount . _Satoshi)
              remainderSeconds (Satoshi r) =

        | total < raiseAmount' =
          -- if the last bid will exceed the raise amount, reduce it to fit
          let winFraction r =
                (r ^. _Units) % (bid ^. bidAmount . _Units)
              remainderSeconds r =

              adjustBid r = bid & bidSeconds .~ remainderSeconds r & bidAmount .~ r
           in toList $ adjustBid <$> raiseAmount' `ssub` total

              adjustBid r =
                bid & bidSeconds .~ remainderSeconds r & bidAmount .~ r
           in toList $ adjustBid <$> raiseAmount' `csub` total

        (WinningBids $ takeWinningBids (Satoshi 0) $ sortBy bidOrder bids)

        (WinningBids $ takeWinningBids mempty $ sortBy bidOrder bids)

        (raiseAmount' `ssub` submittedTotal)
bidCommitment :: Satoshi -> Bid -> State Satoshi (Maybe Commitment)
bidCommitment raiseAmount' bid = do
  raised <- get
  case raised of
    -- if the total is fully within the raise amount
    x
      | x <> (bid ^. bidAmount) < raiseAmount' ->
        put (x <> bid ^. bidAmount)
          >> (pure . Just $ Commitment bid (bid ^. bidSeconds) (bid ^. bidAmount))
    -- if the last bid will exceed the raise amount, reduce it to fit
    x
      | x < raiseAmount' ->
        let winFraction r = r % (bid ^. bidAmount . _Satoshi)
            remainderSeconds (Satoshi r) =
              Seconds . round $ winFraction r * fromIntegral (bid ^. bidSeconds)
         in for (raiseAmount' `ssub` x) $ \remainder ->
              put (x <> remainder)
                *> (pure $ Commitment bid (remainderSeconds remainder) remainder)
    -- otherwise,
    _ -> pure Nothing

        (raiseAmount' `csub` submittedTotal)

    H.Address,

import qualified Haskoin.Address as H

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

_Satoshi :: Iso' Satoshi Word64
_Satoshi = iso (\(Satoshi w) -> w) (Satoshi)

instance Monoid Zatoshi where
  mempty = Zatoshi 0

zsub :: Zatoshi -> Zatoshi -> Maybe Zatoshi
zsub (Zatoshi a) (Zatoshi b) | a > b = Just . Zatoshi $ (a - b)
zsub _ _ = Nothing

    Z.zsub,

{-# LANGUAGE StandaloneDeriving #-}

import qualified Aftok.Currency.Zcash as Zcash
import qualified Bippy.Types as Bitcoin
import Control.Lens (view)
import qualified Haskoin.Address as Bitcoin

import qualified Aftok.Currency.Bitcoin as B
import qualified Aftok.Currency.Zcash as Z
import Control.Lens (Iso')
import qualified Text.Show

  BTC :: Currency Bitcoin.Address Bitcoin.Satoshi
  ZEC :: Currency Zcash.Address Zcash.Zatoshi

  BTC :: Currency B.Address B.Satoshi
  ZEC :: Currency Z.Address Z.Zatoshi
instance Eq (Currency a c) where
  BTC == BTC = True
  ZEC == ZEC = True
instance Show (Currency a c) where
  show = \case
    BTC -> "BTC"
    ZEC -> "ZEC"

instance Eq (Currency' c) where
  (Currency' BTC) == (Currency' BTC) = True
  (Currency' ZEC) == (Currency' ZEC) = True
instance Show (Currency' c) where
  show (Currency' c) = show c

class (Eq c, Ord c, Monoid c) => IsCurrency c where
  csub :: c -> c -> Maybe c
  cscale :: c -> Rational -> Maybe c
  _Units :: Iso' c Word64
  currency' :: Currency' c

scaleCurrency :: Currency a c -> c -> Rational -> Maybe c
scaleCurrency c amount factor = case c of
  BTC -> (\(Bitcoin.Satoshi amt) -> Just $ Bitcoin.Satoshi ((round $ toRational amt * factor) :: Word64)) amount
  ZEC -> (\amt -> Zcash.toZatoshi ((round $ toRational (view Zcash._Zatoshi amt) * factor) :: Word64)) amount

instance IsCurrency B.Satoshi where
  csub = B.ssub
  cscale (B.Satoshi amt) factor =
    let r = toRational amt * factor
     in if (r >= 0) then Just (B.Satoshi . round $ r) else Nothing
  _Units = B._Satoshi
  currency' = Currency' BTC
instance IsCurrency Z.Zatoshi where
  csub = Z.zsub
  cscale (Z.Zatoshi amt) factor =
    let r = toRational amt * factor
     in if (r >= 0) then Just (Z.Zatoshi . round $ r) else Nothing
  _Units = Z._Zatoshi
  currency' = Currency' ZEC

    auctionStart,

    description,

    name,

    name,
    description

-- import           Aftok.Currency                 ( Amount(..) )
-- import qualified Aftok.Currency.Bitcoin        as Bitcoin
import Aftok.Currency.Bitcoin (_Satoshi)
-- import qualified Aftok.Currency.Zcash          as Zcash
import Aftok.Database (Limit(..))

import Aftok.Currency (Amount (..))
import Aftok.Database (Limit (..))

    btcAmountParser,

    currencyAmountParser,
    currencyType,
    currencyValue,

import Aftok.Interval (RangeQuery(..))

import Aftok.Interval (RangeQuery (..))

auctionParser :: RowParser Auction

auctionParser :: RowParser (Auction Amount)

    <*> btcAmountParser

    <*> currencyAmountParser

bidParser :: RowParser Bid

bidParser :: RowParser (Bid Amount)

  Bid <$> idParser UserId <*> (Seconds <$> field) <*> btcAmountParser <*> utcParser

  Bid <$> idParser UserId <*> (Seconds <$> field) <*> currencyAmountParser <*> utcParser

createAuction :: Auction -> DBM AuctionId

createAuction :: Auction Amount -> DBM AuctionId

    [sql| INSERT INTO auctions (project_id, initiator_id, name, description, raise_amount, end_time)
          VALUES (?, ?, ?, ?) RETURNING id |]
    ( auc ^. (projectId . _ProjectId),
      auc ^. (initiator . _UserId),

    [sql| INSERT INTO auctions (project_id, initiator_id, name, description, currency, raise_amount, start_time, end_time)
          VALUES (?, ?, ?, ?, ?, ?, ?, ?) RETURNING id |]
    ( auc ^. projectId . _ProjectId,
      auc ^. initiator . _UserId,

      auc ^. (raiseAmount . _Satoshi),
      auc ^. (auctionEnd . to C.fromThyme)

      auc ^. raiseAmount . to currencyType,
      auc ^. raiseAmount . to currencyValue,
      auc ^. auctionStart . to C.fromThyme,
      auc ^. auctionEnd . to C.fromThyme

findAuction :: AuctionId -> DBM (Maybe Auction)

findAuction :: AuctionId -> DBM (Maybe (Auction Amount))

listAuctions :: ProjectId -> RangeQuery -> Limit -> DBM [Auction]

listAuctions :: ProjectId -> RangeQuery -> Limit -> DBM [Auction Amount]

      auctionParser
      [sql| SELECT project_id, initiator_id, created_at, name, description, raise_amount, start_time, end_time

        auctionParser
        [sql| SELECT project_id, initiator_id, created_at, name, description, raise_amount, start_time, end_time

      (pid ^. _ProjectId, C.fromThyme e, limit)

        (pid ^. _ProjectId, C.fromThyme e, limit)

      auctionParser
      [sql| SELECT project_id, initiator_id, created_at, name, description, raise_amount, start_time, end_time

        auctionParser
        [sql| SELECT project_id, initiator_id, created_at, name, description, raise_amount, start_time, end_time

      (pid ^. _ProjectId, C.fromThyme s, C.fromThyme e, limit)

        (pid ^. _ProjectId, C.fromThyme s, C.fromThyme e, limit)

      auctionParser
      [sql| SELECT project_id, initiator_id, created_at, name, description, raise_amount, start_time, end_time

        auctionParser
        [sql| SELECT project_id, initiator_id, created_at, name, description, raise_amount, start_time, end_time

      (pid ^. _ProjectId, C.fromThyme s, limit)

        (pid ^. _ProjectId, C.fromThyme s, limit)

      auctionParser
      [sql| SELECT project_id, initiator_id, created_at, name, description, raise_amount, start_time, end_time

        auctionParser
        [sql| SELECT project_id, initiator_id, created_at, name, description, raise_amount, start_time, end_time

      (pid ^. _ProjectId, limit)

        (pid ^. _ProjectId, limit)

createBid :: AuctionId -> Bid -> DBM BidId

createBid :: AuctionId -> Bid Amount -> DBM BidId

      bid ^. (bidAmount . _Satoshi),

      bid ^. bidAmount . to currencyType,
      bid ^. bidAmount . to currencyValue,

findBids :: AuctionId -> DBM [(BidId, Bid)]

findBids :: AuctionId -> DBM [(BidId, Bid Amount)]

    Limit(..),

    Limit (..),

  ListAuctions :: ProjectId -> RangeQuery -> Limit -> DBOp [A.Auction]
  CreateAuction :: A.Auction -> DBOp A.AuctionId
  FindAuction :: A.AuctionId -> DBOp (Maybe A.Auction)
  CreateBid :: A.AuctionId -> A.Bid -> DBOp A.BidId
  FindBids :: A.AuctionId -> DBOp [(A.BidId, A.Bid)]

  ListAuctions :: ProjectId -> RangeQuery -> Limit -> DBOp [A.Auction Amount]
  CreateAuction :: A.Auction Amount -> DBOp A.AuctionId
  FindAuction :: A.AuctionId -> DBOp (Maybe (A.Auction Amount))
  CreateBid :: A.AuctionId -> A.Bid Amount -> DBOp A.BidId
  FindBids :: A.AuctionId -> DBOp [(A.BidId, A.Bid Amount)]

createAuction :: (MonadDB m) => A.Auction -> m A.AuctionId

createAuction :: (MonadDB m) => A.Auction Amount -> m A.AuctionId

listAuctions :: (MonadDB m) =>  UserId -> ProjectId -> RangeQuery -> Limit -> m [A.Auction]

listAuctions :: (MonadDB m) => UserId -> ProjectId -> RangeQuery -> Limit -> m [A.Auction Amount]

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

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

findAuction' :: (MonadDB m) => A.AuctionId -> UserId -> m A.Auction

findAuction' :: (MonadDB m) => A.AuctionId -> UserId -> m (A.Auction Amount)

createBid :: (MonadDB m) => A.AuctionId -> UserId -> A.Bid -> m A.BidId

createBid :: (MonadDB m) => A.AuctionId -> UserId -> A.Bid Amount -> m A.BidId

import Control.Error.Util (maybeT)

  ( Address,
    textToAddr,

  ( textToAddr,

auctionJSON :: A.Auction -> Value

auctionJSON :: A.Auction Amount -> Value

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

        "name" .= (x ^. A.name),
        "description" .= (x ^. A.description),
        "raiseAmount" .= (x ^. (A.raiseAmount . to amountJSON)),
        "auctionStart" .= (x ^. A.auctionStart),
        "auctionEnd" .= (x ^. A.auctionEnd)

parseAmountJSON :: Value -> Parser Amount
parseAmountJSON = \case
  Object o ->
    maybeT (fail $ "Expected to find one of [\"satoshi\", \"zatoshi\"] as a key.") pure $
      MaybeT (fmap (Amount BTC . review _Satoshi) <$> o .:? "satoshi")
        <|> MaybeT (fmap (Amount ZEC . review _Zatoshi) <$> o .:? "zatoshi")
  val -> fail $ "Value " <> show val <> " is not a JSON object."

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

parseRecurrence' = \case
  (Object o) -> parseRecurrence o
  val -> fail $ "Value " <> show val <> " is not a JSON object."

import Aftok.Currency (Currency, scaleCurrency)

import Aftok.Currency (Currency, IsCurrency, cscale)

  (MonadDB m, Ord a, Semigroup c, Ord c) =>

  (MonadDB m, Ord a, IsCurrency c) =>

      let scaled frac = note AmountInvalid $ scaleCurrency currency amt frac

      let scaled frac = note AmountInvalid $ cscale amt frac

  (MonadDB m, Ord a, Semigroup c, Ord c) =>

  (MonadDB m, Ord a, IsCurrency c) =>

import Data.AdditiveGroup

import Data.AdditiveGroup ()

  ALTER TABLE auctions ADD COLUMN currency currency_t NOT NULL;

    auctionListHandler,

import Aftok.Currency (Amount)

  ( createAuction,

  ( Limit (..),
    createAuction,

    listAuctions,

import Aftok.Snaplet.Util (decimalParam, rangeQueryParam)

import Bippy.Types (Satoshi (..))

data AuctionCreateRequest = CA {raiseAmount :: Word64, auctionStart :: C.UTCTime, auctionEnd :: C.UTCTime}

data AuctionCreateRequest
  = CA
      { name :: Text,
        description :: Maybe Text,
        raiseAmount :: Amount,
        auctionStart :: C.UTCTime,
        auctionEnd :: C.UTCTime
      }

    p o = CA <$> o .: "raiseAmount" <*> o .: "auctionStart" <*> o .: "auctionEnd"

    p o =
      CA
        <$> o .: "auctionName"
        <*> o .:? "auctionDesc"
        <*> (parseAmountJSON =<< o .: "raiseAmount")
        <*> o .: "auctionStart"
        <*> o .: "auctionEnd"

bidCreateParser :: UserId -> C.UTCTime -> Value -> Parser Bid

bidCreateParser :: UserId -> C.UTCTime -> Value -> Parser (Bid Amount)

        <*> (Satoshi <$> o .: "bidAmount")

        <*> (parseAmountJSON =<< o .: "bidAmount")

  t <- liftIO C.getCurrentTime

  now <- liftIO C.getCurrentTime

      t
      (Satoshi . raiseAmount $ req)

      now
      (name req)
      (description req)
      (raiseAmount $ req)

auctionListHandler :: S.Handler App App [Auction]

auctionListHandler :: S.Handler App App [Auction Amount]

  snapEval $ listAuctions pid uid

  rq <- rangeQueryParam
  limit <- Limit . fromMaybe 1 <$> decimalParam "limit"
  snapEval $ listAuctions uid pid rq limit

auctionGetHandler :: S.Handler App App Auction

auctionGetHandler :: S.Handler App App (Auction Amount)

import Aftok.Interval (RangeQuery (..))

rangeQueryParam :: MonadSnap m => m RangeQuery
rangeQueryParam = do
  endpoints <- (,) <$> timeParam "after" <*> timeParam "before"
  pure $ case endpoints of
    (Just s, Just e) -> During s e
    (Nothing, Just e) -> Before e
    (Just s, Nothing) -> After s
    (Nothing, Nothing) -> Always

import Aftok.Interval

  endpoints <- (,) <$> timeParam "after" <*> timeParam "before"
  let ival = case endpoints of
        (Just s, Just e) -> During s e
        (Nothing, Just e) -> Before e
        (Just s, Nothing) -> After s
        (Nothing, Nothing) -> Always
  limit <- fromMaybe 1 <$> decimalParam "limit"

  ival <- rangeQueryParam
  limit <- Limit . fromMaybe 1 <$> decimalParam "limit"

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

      ("projects/:projectId/auctions", auctionCreateRoute <|> auctionListRoute),

genBid :: Gen Bid

genBid :: Gen (Bid Satoshi)