Maintainer:    kris@nutty.lang

Maintainer:    kris@nutty.land

  build-depends:      quixotic
                    , base
                    , aeson
                    , containers
                    , either
                    , mtl
                    , sqlite
                    , text
                    , time
                    , configurator         == 0.2.*
                    , optparse-applicative >= 0.9.0    && < 0.10
                    , bytestring           >= 0.9.1    && < 0.11
                    , scotty               >= 0.9.0

  build-depends:      
      quixotic
    , base                      >= 4     && < 5
    , aeson
    , containers
    , either
    , mtl                       >= 2     && < 3
    , sqlite
    , text
    , time
    , MonadCatchIO-transformers >= 0.2.1 && < 0.4
    , configurator              == 0.2.*
    , optparse-applicative      >= 0.9.0    && < 0.10
    , bytestring                >= 0.9.1    && < 0.11
    , snap-core                 >= 0.9   && < 0.10
    , snap-server               >= 0.9   && < 0.10

module Api.Worklog (resource) where
import Control.Applicative ((<$>))
import Control.Concurrent.STM (atomically, modifyTVar, readTVar)
import Control.Monad.Error (throwError)
import Control.Monad.Reader (ReaderT, asks)
import Control.Monad.Trans (liftIO)
import Data.Set (Set)
import qualified Data.Foldable as F
import qualified Data.Set      as Set
import qualified Data.Text     as T
import Rest (Handler, ListHandler, Range (count, offset), Resource, Void, domainReason, mkInputHandler, mkListing, mkResourceReader, named, singleRead,
             withListing, xmlJsonE, xmlJsonI, xmlJsonO)
import qualified Rest.Resource as R
import ApiTypes (BlogApi, ServerData (..))
import Type.User (User)
import Type.UserInfo (UserInfo (..))
import Type.UserSignupError (UserSignupError (..))
import qualified Type.User     as User
import qualified Type.UserInfo as UserInfo
resource :: 

module Api (api) where
import Rest.API

import Web.Scotty

import Snap.Core
import Snap.Util.FileServe
import Snap.Http.Server

main = do 

main = do

  dbMain cfg db adb

  quickHttpServe $ site cfg

data QConfig
  = QConfig

site :: QConfig -> a -> ADB IO a -> Snap ()
site cfg db adb =
    route [ ("logStart/:btcAddr", handleLogRequest db adb StartWork)
          , ("logEnd/:btcAddr", handleLogRequest db adb StopWork)
          , ("payouts", currentPayouts db adb)
          ] 
data QConfig = QConfig

dbMain :: QConfig -> a -> ADB IO a -> IO ()
dbMain cfg db adb = do
  scotty (port cfg) $ do
{--
Log the start time of a work interval.
Log completion of the current work interval.
Record change of a work interval start.
Record change of a work interval end.
Given a trusted token, authorize another token.
--}
    post "/logStart/:btcAddr" $ handleLogRequest db adb StartWork
    post "/logEnd/:btcAddr" $ handleLogRequest db adb StopWork

    get "/payouts" $ currentPayouts db adb
handleLogRequest :: a -> ADB IO a -> (UTCTime -> WorkEvent) -> ActionM ()

handleLogRequest :: a -> ADB IO a -> (UTCTime -> WorkEvent) -> Snap ()

  BtcAddrParam addr <- param "btcAddr"

  addrBytes <- getParam "btcAddr"
  let addr = fmap T.pack addrBytes >>= parseBtcAddr 

currentPayouts :: a -> ADB IO a -> ActionM ()

currentPayouts :: a -> ADB IO a -> Snap ()

      buildPayoutsResponse :: WorkIndex -> ActionM ()
      buildPayoutsResponse widx = json . PayoutsResponse $ payouts dep ptime widx

      buildPayoutsResponse :: WorkIndex -> Snap ()
      buildPayoutsResponse widx = writeBS . encode . PayoutsResponse $ payouts dep ptime widx

      payoutsAction :: EitherT T.Text ActionM WorkIndex

      payoutsAction :: EitherT T.Text Snap WorkIndex

newtype BtcAddrParam = BtcAddrParam BtcAddr 

instance Parsable BtcAddrParam where
  parseParam t = maybe (Left "Invalid BTC address") (Right . BtcAddrParam) $ (parseBtcAddr . LT.toStrict) t