Start of migration back toward snap.

[?]

Nov 26, 2014, 7:35 PM

WZUHEZSBRKHQMNWDKVG4X6DDIQEAXTGI6IGAJ5ERPRQ3W2KUMX4QC

Dependencies

[2] Z3M53KTL Adrift.
[3] ADMKQQGC Initial empty Snap project.
[4] 64VI73NP Server now compiles using abstracted SQLite
[5] RSEB2NFG Replacing Snap with Scotty.
[6] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[7] 5W5M56VJ Move library code to 'lib'
[*] EQXRXRZD Changed to use tasty instead of test-framework

Change contents

replacement in quixotic.cabal at line 8

[3.326]→[3.326:357](∅→∅)

Maintainer: kris@nutty.lang

[3.326]

[3.357]

Maintainer: kris@nutty.land
replacement in quixotic.cabal at line 54

[3.1863]→[3.1863:2037](∅→∅),[3.2037]→[3.1:30](∅→∅),[3.30]→[3.2037:2091](∅→∅),[3.2037]→[3.2037:2091](∅→∅),[3.2091]→[2.29:81](∅→∅),[2.81]→[3.2091:2273](∅→∅),[3.2091]→[3.2091:2273](∅→∅)

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

[3.1863]

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
file addition: Api (d--r------)

[9.1243]
file addition: WorkLog.hs (----------)

[0.547]

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 ::
file addition: Api.hs (----------)

[9.1243]

module Api (api) where

import Rest.API
replacement in server/Main.hs at line 19

[3.2567]→[3.1363:1381](∅→∅),[3.1363]→[3.1363:1381](∅→∅)

import Web.Scotty

[3.2567]

[3.5492]

import Snap.Core
import Snap.Util.FileServe
import Snap.Http.Server
replacement in server/Main.hs at line 24

[3.1492]→[3.218:229](∅→∅)

main = do

[3.1492]

[2.153]

main = do
replacement in server/Main.hs at line 28

[3.288]→[2.226:246](∅→∅)

dbMain cfg db adb

[3.288]

[3.2594]

quickHttpServe $ site cfg
replacement in server/Main.hs at line 30

[3.2595]→[2.247:272](∅→∅)

data QConfig
= QConfig

[3.2595]

[2.272]

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
edit in server/Main.hs at line 46

[2.475]→[2.475:569](∅→∅),[2.569]→[3.1598:1816](∅→∅),[3.1598]→[3.1598:1816](∅→∅),[3.1816]→[3.339:468](∅→∅)

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
replacement in server/Main.hs at line 47

[3.5696]→[3.469:512](∅→∅),[3.512]→[3.5717:5718](∅→∅),[3.2808]→[3.5717:5718](∅→∅),[3.5717]→[3.5717:5718](∅→∅),[3.5718]→[3.513:587](∅→∅)

get "/payouts" $ currentPayouts db adb

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

[3.5696]

[3.587]

handleLogRequest :: a -> ADB IO a -> (UTCTime -> WorkEvent) -> Snap ()
replacement in server/Main.hs at line 49

[3.620]→[3.2904:2943](∅→∅),[3.2904]→[3.2904:2943](∅→∅)

BtcAddrParam addr <- param "btcAddr"

[3.620]

[3.2943]

addrBytes <- getParam "btcAddr"
let addr = fmap T.pack addrBytes >>= parseBtcAddr
replacement in server/Main.hs at line 54

[3.6063]→[3.683:729](∅→∅)

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

[3.6063]

[3.729]

currentPayouts :: a -> ADB IO a -> Snap ()
replacement in server/Main.hs at line 59

[3.759]→[3.759:895](∅→∅)

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

[3.759]

[3.6168]

buildPayoutsResponse :: WorkIndex -> Snap ()
buildPayoutsResponse widx = writeBS . encode . PayoutsResponse $ payouts dep ptime widx
replacement in server/Main.hs at line 62

[3.6169]→[3.896:952](∅→∅)

payoutsAction :: EitherT T.Text ActionM WorkIndex

[3.6169]

[3.952]

payoutsAction :: EitherT T.Text Snap WorkIndex
edit in server/Main.hs at line 66

[3.1086]→[3.1086:1087](∅→∅),[3.1087]→[3.3260:3305](∅→∅),[3.6169]→[3.3260:3305](∅→∅)

newtype BtcAddrParam = BtcAddrParam BtcAddr
edit in server/Main.hs at line 67

[3.8457]→[3.2400:2437](∅→∅),[3.2437]→[3.3306:3415](∅→∅)

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