newtype AuctionId = AuctionId Int deriving (Show, Eq)

newtype AuctionId = AuctionId Int64 deriving (Show, Eq)

  , _endsAt :: UTCTime 

  , _auctionEnd :: UTCTime 

  { _userId :: UserId
  , _seconds :: Seconds
  , _btcAmount :: BTC

  { _bidUser    :: UserId
  , _bidSeconds :: Seconds
  , _bidAmount  :: BTC
  , _bidTime    :: UTCTime

      bidSeconds bid = toRational $ bid ^. seconds
      bidAmount  bid = toRational $ bid ^. (btcAmount . btc)
      costRatio  bid = bidSeconds bid / bidAmount bid

      secs bid = toRational $ bid ^. bidSeconds
      btc  bid = toRational $ bid ^. (bidAmount . satoshis)
      costRatio bid = secs bid / btc bid

        | (total ++ x ^. btcAmount) < (auction ^. raiseAmount) = 
          x : (takeWinningBids (total ++ x ^. btcAmount) xs)

        | (total ++ x ^. bidAmount) < (auction ^. raiseAmount) = 
          x : (takeWinningBids (total ++ x ^. bidAmount) xs)

              winFraction = (toRational $ remainder ^. btc) / (toRational $ x ^. (btcAmount . btc))
              remainderSeconds = Seconds . round $ winFraction * (toRational $ x ^. seconds)

              winFraction = (toRational $ remainder ^. satoshis) / (toRational $ x ^. (bidAmount . satoshis))
              remainderSeconds = Seconds . round $ winFraction * (toRational $ x ^. bidSeconds)

          in  [x & seconds .~ remainderSeconds & btcAmount .~ remainder]

          in  [x & bidSeconds .~ remainderSeconds & bidAmount .~ remainder]

{-# LANGUAGE TemplateHaskell #-}

import Control.Error.Safe

import Database.SQLite

import Database.SQLite.Simple

sqliteQDB :: SQLiteHandle -> IO (QDB (EitherT Text IO) SQLiteHandle)
sqliteQDB db = do
  _ <- defineTableOpt db True eventTable
  _ <- defineTableOpt db True auctionTable
  return $ QDB 
    { recordEvent = recordEvent'
    , readWorkIndex = readWorkIndex' 
    , newAuction = newAuction'
    , readAuction = readAuction'
    , recordBid = recordBid'
    , readBids = readBids'
    , createUser = createUser'
    }
recordEvent' :: LogEntry -> ReaderT SQLiteHandle (EitherT Text IO) ()
recordEvent' (LogEntry ba ev) = do 
  db <- ask
  lift . lift . void $ insertRow db "workEvents" 
    [ ("btcAddr", ba ^. address ^. from packed)
    , ("event", unpack (eventName ev))
    , ("eventTime", formatSqlTime (logTime ev)) 
    ]
readWorkIndex' :: ReaderT SQLiteHandle (EitherT Text IO) WorkIndex
readWorkIndex' = do
  db <- ask
  let selection = execStatement db "SELECT btcAddr, event, eventTime from workEvents" 
  rows <- lift . EitherT $ fmap (over _Left pack) selection
  return . intervals . catMaybes $ fmap parseLogEntry (join rows)
newAuction' :: Auction -> ReaderT SQLiteHandle (EitherT Text IO) AuctionId
newAuction' a = do
  db <- ask
  _  <-  lift . lift $ insertRow db "auctions"
    [ ("raiseAmount", show $ a ^. (raiseAmount . btc))
    , ("eventTime", formatSqlTime $ a ^. endsAt) 
    ]
  lift . lift . fmap (AuctionId . fromInteger) $ getLastRowID db

readAuction' :: AuctionId -> ReaderT a (EitherT Text IO) Auction
readAuction' (AuctionId aid) = do
  db <- ask
  let selection = execParamStatement db 
                  "SELECT raiseAmount, endsAt FROM auctions WHERE ROWID = :aid" 
                  [("aid", Int aid)]
  rows <- lift . EitherT $ fmap (over _Left pack) selection

newtype PLogEntry = PLogEntry LogEntry
makePrisms ''PLogEntry

instance ToRow PLogEntry where
  toRow (PLogEntry (LogEntry a e)) = 
    toRow (a ^. address, e ^. (eventType . to eventName), e ^. eventTime)

recordBid' :: UTCTime -> Bid -> ReaderT a (EitherT Text IO) ()
recordBid' = undefined
readBids' :: AuctionId -> ReaderT a (EitherT Text IO) [(UTCTime, Bid)]
readBids' = undefined

instance FromRow PLogEntry where
  fromRow = 
    let workEventParser = WorkEvent <$> (field >>= nameEvent) <*> field 
        logEntryParser  = LogEntry <$> (fmap BtcAddr field) <*> workEventParser 
    in  fmap PLogEntry logEntryParser

createUser' :: User -> ReaderT a (EitherT Text IO) UserId
createUser' = undefined

newtype PAuction = PAuction Auction
makePrisms ''PAuction

parseLogEntry :: Row Value -> Maybe LogEntry
parseLogEntry row = do
  a <- lookup "btcAddr" row >>= valueAddr
  t <- lookup "eventTime" row >>= valueTime
  ev <- lookup "event" row >>= (valueEvent t)
  return $ LogEntry a ev
parseAuction :: Row Value -> Maybe Auction
parseAuction row = 
  Auction <$> (lookup "raiseAmount" row >>= valueBTC)
          <*> (lookup "endsAt" row >>= valueTime)

instance FromRow PAuction where
  fromRow = 
    let auctionParser = Auction <$> (fmap BTC field) <*> field
    in  fmap PAuction auctionParser

valueBTC :: Value -> Maybe BTC
valueBTC (Int i) _ = Just $ BTC i
valueBTC _ = Nothing

recordEvent' :: LogEntry -> ReaderT Connection IO ()
recordEvent' logEntry = do 
  conn <- ask
  lift $ execute conn 
    "INSERT INTO work_events (btc_addr, event_type, event_time) VALUES (?, ?, ?)" 
    (logEntry ^. (from _PLogEntry))

valueAddr :: Value -> Maybe BtcAddr
valueAddr (Text t) = parseBtcAddr $ pack t
valueAddr _ = Nothing

readWorkIndex' :: ReaderT Connection IO WorkIndex
readWorkIndex' = do
  conn <- ask
  rows <- lift $ query_ conn
    "SELECT btc_addr, event_type, event_time from workEvents" 
  lift . return . workIndex $ fmap (^. _PLogEntry) rows

valueTime :: Value -> Maybe UTCTime
valueTime (Text t) = parseTime defaultTimeLocale "%c" t
valueTime _        = Nothing

newAuction' :: Auction -> ReaderT Connection IO AuctionId
newAuction' auc = do
  conn <- ask
  lift $ execute conn
    "INSERT INTO auctions (raise_amount, end_time) VALUES (?, ?)"
    (auc ^. (raiseAmount . satoshis), auc ^. auctionEnd)
  lift . fmap AuctionId $ lastInsertRowId conn

valueEvent :: UTCTime -> Value -> Maybe WorkEvent
valueEvent t (Text "start") = Just (StartWork t)
valueEvent t (Text "stop")  = Just (StopWork t)
valueEvent _              _ = Nothing

readAuction' :: AuctionId -> ReaderT Connection IO (Maybe Auction)
readAuction' (AuctionId aid) = do
  conn <- ask
  rows <- lift $ query conn
    "SELECT raise_amount, end_time FROM auctions WHERE ROWID = ?" 
    (Only aid)
  lift . return . headMay $ fmap (^. _PAuction) rows

formatSqlTime :: UTCTime -> String
formatSqlTime t = formatTime defaultTimeLocale "%c" t

recordBid' :: AuctionId -> Bid -> ReaderT Connection IO ()
recordBid' (AuctionId aid) bid = do
  conn <- ask
  lift $ execute conn
    "INSERT INTO bids (auction_id, user_id, bid_seconds, bid_amount, bid_time) values (?, ?, ?, ?, ?)"
    (aid, bid ^. bidUser, bid ^. bidSeconds, bid ^. bidAmount, bid ^. bidTime)

eventTable :: SQLTable
eventTable = Table "workEvents" 
  [ Column "btcAddr"   (SQLVarChar 256) []
  , Column "event"     (SQLVarChar 64) []
  , Column "eventTime" (SQLDateTime DATETIME) [] 
  ] []

readBids' :: AuctionId -> ReaderT Connection IO [(UTCTime, Bid)]
readBids' = undefined

auctionTable :: SQLTable
auctionTable = Table "auctions" 
  [ Column "raiseAmouont" (SQLInt BIG False False) []
  , Column "endsAt"       (SQLDateTime DATETIME) [] 
  ] []

createUser' :: User -> ReaderT Connection IO UserId
createUser' = undefined

sqliteQDB :: QDB IO Connection
sqliteQDB = QDB 
  { recordEvent = recordEvent'
  , readWorkIndex = readWorkIndex' 
  , newAuction = newAuction'
  , readAuction = readAuction'
  , recordBid = recordBid'
  , readBids = readBids'
  , createUser = createUser'
  }

  , readAuction :: AuctionId -> ReaderT a m Auction
  , recordBid :: UTCTime -> Bid -> ReaderT a m ()

  , readAuction :: AuctionId -> ReaderT a m (Maybe Auction)
  , recordBid :: AuctionId -> Bid -> ReaderT a m ()

{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, NoImplicitPrelude #-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}

  , btcAddr, event

  , EventType(..)
  , eventName, nameEvent

  , eventType, eventTime

  , workIndex

  , eventName

  , intervals

import Control.Lens

import qualified Data.Aeson.Types as A

data WorkEvent = StartWork { logTime :: UTCTime }
               | StopWork  { logTime :: UTCTime } deriving (Show, Eq)

data EventType = StartWork | StopWork deriving (Show, Eq)

eventName :: WorkEvent -> Text
eventName (StartWork _) = "start"
eventName (StopWork  _) = "stop"

eventName :: EventType -> Text
eventName StartWork = "start"
eventName StopWork  = "stop"
nameEvent :: MonadPlus m => Text -> m EventType
nameEvent "start" = return StartWork
nameEvent "stop"  = return StopWork
nameEvent _       = mzero

data WorkEvent = WorkEvent 
  { _eventType :: EventType
  , _eventTime :: UTCTime
  } deriving (Show, Eq)
makeLenses ''WorkEvent

  parseJSON (Object jv) = do
    t <- jv .: "type" :: A.Parser Text
    case t of
      "start" -> StartWork <$> jv .: "timestamp"     
      "stop"  -> StopWork <$> jv .: "timestamp"
      _ -> mzero

  parseJSON (Object jv) = 
    WorkEvent <$> (jv .: "type" >>= nameEvent) <*> jv .: "timestamp"     

  { btcAddr :: BtcAddr
  , event :: WorkEvent 

  { _btcAddr :: BtcAddr
  , _event :: WorkEvent 

makeLenses ''LogEntry

  parseJSON (Object jv) = LogEntry <$>
                          jv .: "btcAddr" <*>
                          jv .: "workEvent"

  parseJSON (Object jv) = 
    LogEntry <$> jv .: "btcAddr" <*> jv .: "workEvent"

intervals :: Foldable f => f LogEntry -> WorkIndex
intervals logEntries = 
  let logSum = F.foldl' appendLogEntry MS.empty logEntries
  in  MS.map (bimap (fmap event) (fmap workInterval)) $ logSum

workIndex :: Foldable f => f LogEntry -> WorkIndex
workIndex logEntries = 
  let logSum :: RawIndex
      logSum = F.foldl' appendLogEntry MS.empty logEntries
  in  MS.map (bimap (fmap (^. event)) (fmap workInterval)) $ logSum

appendLogEntry workIndex entry = 
  let acc = reduceToIntervals $ pushEntry entry workIndex 
  in  insert (btcAddr entry) acc workIndex

appendLogEntry idx entry = 
  let acc = reduceToIntervals $ pushEntry entry idx 
  in  insert (entry ^. btcAddr) acc idx

pushEntry entry = first (entry :) . MS.findWithDefault ([], []) (btcAddr entry) 

pushEntry entry = first (entry :) . MS.findWithDefault ([], []) (entry ^. btcAddr) 

reduceToIntervals ((LogEntry addr (StopWork end')) : (LogEntry _ (StartWork start')) : xs, acc) = 

reduceToIntervals ((LogEntry addr (WorkEvent StopWork end')) : (LogEntry _ (WorkEvent StartWork start')) : xs, acc) = 

newtype BTC = BTC { _btc :: Int64 } deriving (Show, Eq, Ord)

newtype BTC = BTC { _satoshis :: Int64 } deriving (Show, Eq, Ord)

  (<>) b1 b2 = BTC $ _btc b1 + _btc b2

  (<>) (BTC b1) (BTC b2) = BTC $ b1 + b2

  invert b = BTC . negate . _btc $ b

  invert (BTC b) = BTC . negate $ b

    , safe                 >= 0.3.8
    , errors               >= 1.4.7

    , sqlite               == 0.5.2.2

    , sqlite-simple        >= 0.4.8    && < 0.5