Quixotic.Auction

    , sqlite

    , lens
    , sqlite-simple

    , transformers

{-# LANGUAGE RecordWildCards #-}

module Main (main) where

module Main where

import ClassyPrelude

import ClassyPrelude 

import Control.Applicative
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Either

import Control.Lens
import Control.Monad.Trans.Reader

import qualified Data.Text.Lazy as LT
import Data.Time.Clock
import Database.SQLite

import Database.SQLite.Simple

import Snap.Util.FileServe

  db  <- openConnection $ dbName cfg
  adb <- sqliteQDB db
  quickHttpServe $ runReaderT (site adb) db

  db  <- open $ dbName cfg
  quickHttpServe $ runReaderT (site sqliteQDB) db

site adb = route 
  [ ("logStart/:btcAddr", handleLogRequest adb StartWork)
  , ("logEnd/:btcAddr",   handleLogRequest adb StopWork)
  , ("payouts", currentPayouts adb)

site qdb = route 
  [ ("logStart/:btcAddr", handleLogRequest qdb StartWork)
  , ("logEnd/:btcAddr",   handleLogRequest qdb StopWork)
  , ("payouts", currentPayouts qdb)

  cfg <- C.load [C.Required cfgFile]

  cfg <- C.load [C.Required (fpToString cfgFile)]

handleLogRequest :: QDB IO a -> (UTCTime -> WorkEvent) -> ReaderT a Snap ()
handleLogRequest db adb ev = do 

handleLogRequest :: QDB IO a -> EventType -> ReaderT a Snap ()
handleLogRequest qdb ev = do 
  let QDB{..} = qdb

  let addr = fmap T.pack addrBytes >>= parseBtcAddr 
  timestamp <- liftIO getCurrentTime
  liftIO $ recordEvent adb db $ LogEntry addr (ev timestamp)

  timestamp <- lift $ liftIO getCurrentTime
  maybe 
    (lift $ snapError 400 "")
    (\a -> mapReaderT liftIO $ recordEvent (LogEntry a (WorkEvent ev timestamp)))
    (fmap decodeUtf8 addrBytes >>= parseBtcAddr)

currentPayouts db adb = do 
  ptime <- liftIO getCurrentTime
  let dep = linearDepreciation (Months 6) (Months 60) 

currentPayouts qdb = do 
  let QDB{..} = qdb
      dep = linearDepreciation (Months 6) (Months 60) 

      buildPayoutsResponse :: WorkIndex -> Snap ()
      buildPayoutsResponse widx = writeBS . A.encode . PayoutsResponse $ payouts dep ptime widx
      payoutsAction :: EitherT T.Text Snap WorkIndex
      payoutsAction = mapEitherT liftIO $ readWorkIndex adb db 

  ptime <- lift . liftIO $ getCurrentTime
  widx <- mapReaderT liftIO $ readWorkIndex
  lift . writeLBS . A.encode . PayoutsResponse $ payouts dep ptime widx

  lift $ eitherT (raise . LT.fromStrict) buildPayoutsResponse payoutsAction

snapError :: Int -> Text -> Snap ()
snapError c t = do
  modifyResponse $ setResponseStatus c $ encodeUtf8 t
  writeText $ ((tshow c) <> " - " <> t)
  r <- getResponse
  finishWith r

    m = fmap fromRational (mapKeys address p)

    m = fmap fromRational $ mapKeys (^. address) p