Added initial auction create route.

[?]

Mar 6, 2016, 8:14 PM

HALRDT2F22DAQ54M334YSKD2XJCAXDXEZPDKGMOWKH7XELBAS6MAC

Dependencies

[2] EKI57EJR Add alternative implementation of auction winner determination.
[3] EKY7U7SK Finish conversion to stack.
[4] Y35QCWYW Minor improvement in WorkIndex type to eliminate duplicated information.
[5] NLZ3JXLO Fix formatting with stylish-haskell.
[6] ZP62WC47 Begin conversion to build with stack.
[7] RPAJLHMT Change to use UUIDs instead of ints for primary keys.
[8] Z7KS5XHH Very WIP. Wow.
[9] M4KM76DG Merge branch 'stackify'
[10] PBD7LZYQ Postgres & auth are beginning to function.
[11] NEDDHXUK Reformat via stylish-haskell
[12] LHJ2HFXV Add property test for auction algorithm.
[13] GKGVYBZG Added JSON serialization to TimeLog
[14] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[15] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[16] IZEVQF62 Work in progress replacing sqlite with postgres.
[17] LAROLAYU WIP
[18] A6HKMINB Attempting to improve JSON handling.
[19] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[20] NVOCQVAS Initial failing tests.
[21] 2G3GNDDU Event logging is now functioning in postgres.
[22] KEP5WUFJ Convert project to stack-based build.
[23] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[24] 6L5BK5EH Use generic SMTP rather than Sendmail-specific mail client.
[25] 7HPY3QPF Fix linting errors. (yay hlint!)
[26] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[27] GCVQD44V Create amends endpoint, switch to UUID primary keys
[*] W35DDBFY Factor common JSON conversions up into client lib module.
[*] I2KHGVD4 Require project permissions for access to most data.
[*] BROSTG5K Beginning of modularization of server.
[*] ADMKQQGC Initial empty Snap project.
[*] MGOF7IUF Update TASKS list to reflect completed projects.

Change contents

edit in aftok.cabal at line 29

[3.393]

[3.393]

Aftok.Project
edit in aftok.cabal at line 54

[3.206]→[3.77:77](∅→∅)
replacement in lib/Aftok/Auction.hs at line 20

[3.239]→[2.129:158](∅→∅)

{ _raiseAmount :: Satoshi

[3.239]

[2.158]

{ _initiator :: UserId
--, _createdAt :: C.UTCTime
, _raiseAmount :: Satoshi
--, _auctionStart :: C.UTCTime
replacement in lib/Aftok/Database/PostgreSQL.hs at line 21

[3.1583]→[3.1583:1614](∅→∅)

import Aftok.Auction

[3.1583]

[3.1614]

import Aftok.Auction as A
edit in lib/Aftok/Database/PostgreSQL.hs at line 24

[3.1678]

[3.1678]

import Aftok.Project as P
replacement in lib/Aftok/Database/PostgreSQL.hs at line 94

[3.2039]→[3.628:662](∅→∅),[3.669]→[3.628:662](∅→∅)

Auction <$> fieldWith btcParser

[3.2039]

[3.2144]

Auction <$> fieldWith uidParser
<*> fieldWith btcParser
replacement in lib/Aftok/Database/PostgreSQL.hs at line 215

[3.3057]→[3.3057:3162](∅→∅),[3.3162]→[3.157:254](∅→∅)

"INSERT INTO auctions (project_id, raise_amount, end_time) \
\VALUES (?, ?, ?) RETURNING id"
(pid ^. _ProjectId, auc ^. (raiseAmount.to fromSatoshi), auc ^. (auctionEnd.to fromThyme))

[3.3057]

[3.5182]

"INSERT INTO auctions (project_id, user_id, raise_amount, end_time) \
\VALUES (?, ?, ?, ?) RETURNING id"
( pid ^. _ProjectId
, auc ^. (A.initiator . _UserId)
, auc ^. (raiseAmount.to fromSatoshi)
, auc ^. (auctionEnd.to fromThyme)
)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 288

[3.4751]→[3.4292:4398](∅→∅)

(p ^. projectName, p ^. (inceptionDate.to fromThyme), p ^. (initiator._UserId), toJSON $ p ^. depf)

[3.4751]

[3.946]

(p ^. projectName, p ^. (inceptionDate.to fromThyme), p ^. (P.initiator . _UserId), toJSON $ p ^. depf)
replacement in lib/Aftok/Database.hs at line 13

[3.270]→[2.1119:1183](∅→∅)

import Aftok.Auction (Auction, AuctionId, Bid, BidId)

[3.270]

[3.301]

import Aftok.Project as P
import Aftok.Auction as A
replacement in lib/Aftok/Database.hs at line 90

[3.7739]→[3.7739:7796](∅→∅)

addUserToProject pid (p ^. initiator) (p ^. initiator)

[3.7739]

[3.7796]

addUserToProject pid (p ^. P.initiator) (p ^. P.initiator)
edit in lib/Aftok/Database.hs at line 155

[3.9333]

[3.1305]

-- Auction ops
edit in lib/Aftok/Database.hs at line 158

[3.1306]

createAuction :: ProjectId -> Auction -> DBProg AuctionId
createAuction pid a = do
withProjectAuth pid (a ^. A.initiator) $ CreateAuction pid a
edit in lib/Aftok/Json.hs at line 20

[3.1358]

[3.1358]

import Aftok.Project
file addition: Project.hs (----------)

[3.679]

{-# LANGUAGE TemplateHaskell #-}

module Aftok.Project where

import ClassyPrelude

import Control.Lens (makeLenses, makePrisms)
import Data.ByteString.Base64.URL as B64
import Data.Thyme.Clock as C
import Data.UUID
import OpenSSL.Random

import Aftok

newtype ProjectId = ProjectId UUID deriving (Show, Eq)
makePrisms ''ProjectId

type ProjectName = Text
data Project = Project
{ _projectName :: ProjectName
, _inceptionDate :: C.UTCTime
, _initiator :: UserId
, _depf :: DepreciationFunction
}
makeLenses ''Project

newtype InvitationCode = InvitationCode ByteString deriving (Eq)
makePrisms ''InvitationCode

randomInvCode :: IO InvitationCode
randomInvCode = InvitationCode <$> randBytes 32

parseInvCode :: Text -> Either String InvitationCode
parseInvCode t = do
code <- B64.decode . encodeUtf8 $ t
if length code == 32
then Right $ InvitationCode code
else Left "Invitation code appears to be invalid."

renderInvCode :: InvitationCode -> Text
renderInvCode (InvitationCode bs) = decodeUtf8 $ B64.encode bs

data Invitation = Invitation
{ _projectId :: ProjectId
, _invitingUser :: UserId
, _invitedEmail :: Email
, _invitationTime :: C.UTCTime
, _acceptanceTime :: Maybe C.UTCTime
}
makeLenses ''Invitation
edit in lib/Aftok.hs at line 12

[3.5968]→[3.5968:6019](∅→∅)

import Data.ByteString.Base64.URL as B64
edit in lib/Aftok.hs at line 13

[3.6046]→[3.6046:6095](∅→∅)

import Data.Thyme.Clock as C
edit in lib/Aftok.hs at line 14

[3.6122]→[3.6122:6154](∅→∅)

import OpenSSL.Random
edit in lib/Aftok.hs at line 42

[3.2984]→[3.1910:1911](∅→∅),[3.1910]→[3.1910:1911](∅→∅),[3.1911]→[3.2271:2326](∅→∅),[3.2326]→[3.3041:3065](∅→∅),[3.3041]→[3.3041:3065](∅→∅),[3.3065]→[3.6911:6935](∅→∅),[3.6935]→[3.3065:3088](∅→∅),[3.3065]→[3.3065:3088](∅→∅),[3.3088]→[3.6245:6279](∅→∅),[3.6279]→[3.6968:7000](∅→∅),[3.6968]→[3.6968:7000](∅→∅),[3.7000]→[3.6280:6352](∅→∅),[3.6352]→[3.3168:3194](∅→∅),[3.10913]→[3.3168:3194](∅→∅),[3.3168]→[3.3168:3194](∅→∅),[3.3194]→[3.7001:7130](∅→∅),[3.7130]→[3.189:237](∅→∅),[3.237]→[3.3399:3400](∅→∅),[3.7179]→[3.3399:3400](∅→∅),[3.3399]→[3.3399:3400](∅→∅),[3.3400]→[3.7180:7291](∅→∅),[3.7291]→[3.238:261](∅→∅),[3.261]→[3.7315:7407](∅→∅),[3.7315]→[3.7315:7407](∅→∅),[3.7025]→[3.3442:3443](∅→∅),[3.7407]→[3.3442:3443](∅→∅),[3.3442]→[3.3442:3443](∅→∅),[3.3443]→[3.7408:7512](∅→∅),[3.7512]→[3.6353:6474](∅→∅),[3.6474]→[3.7625:7697](∅→∅),[3.7625]→[3.7625:7697](∅→∅),[3.7697]→[3.3567:3571](∅→∅),[3.3567]→[3.3567:3571](∅→∅),[3.3571]→[3.7698:7722](∅→∅)

newtype ProjectId = ProjectId UUID deriving (Show, Eq)
makePrisms ''ProjectId

type ProjectName = Text
data Project = Project
{ _projectName :: ProjectName
, _inceptionDate :: C.UTCTime
, _initiator :: UserId
, _depf :: DepreciationFunction
}
makeLenses ''Project

newtype InvitationCode = InvitationCode ByteString deriving (Eq)
makePrisms ''InvitationCode

randomInvCode :: IO InvitationCode
randomInvCode = InvitationCode <$> randBytes 32

parseInvCode :: Text -> Either String InvitationCode
parseInvCode t = do
code <- B64.decode . encodeUtf8 $ t
if length code == 32
then Right $ InvitationCode code
else Left "Invitation code appears to be invalid."

renderInvCode :: InvitationCode -> Text
renderInvCode (InvitationCode bs) = decodeUtf8 $ B64.encode bs

data Invitation = Invitation
{ _projectId :: ProjectId
, _invitingUser :: UserId
, _invitedEmail :: Email
, _invitationTime :: C.UTCTime
, _acceptanceTime :: Maybe C.UTCTime
}
makeLenses ''Invitation
file addition: Auctions.hs (----------)

[3.2082]

{-# LANGUAGE TemplateHaskell #-}

module Aftok.Snaplet.Auctions
( auctionCreateHandler
) where

import ClassyPrelude

import Data.Aeson
import Data.Aeson.Types
import Data.Thyme.Clock as C
--import Data.Thyme.Format.Aeson ()

import Aftok.Database (createAuction)
import Aftok.Auction (AuctionId, Auction(..))
import Aftok.Json
import Aftok.Types

import Aftok.Snaplet
import Aftok.Snaplet.Auth

import Snap.Snaplet

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

auctionCreateParser :: Value -> Parser AuctionCreateRequest
auctionCreateParser = unv1 "auctions" $ \v ->
case v of
(Object o) -> CA <$> o .: "raiseAmount"
<*> o .: "auctionEnd"
_ -> mzero

auctionCreateHandler :: Handler App App AuctionId
auctionCreateHandler = do
uid <- requireUserId
pid <- requireProjectId
requestBody <- readRequestJSON 4096
req <- either (snapError 400 . tshow) pure $ parseEither auctionCreateParser requestBody
--t <- liftIO C.getCurrentTime
snapEval . createAuction pid $ Auction uid (Satoshi . raiseAmount $ req) (auctionEnd req)
edit in server/Aftok/Snaplet/Auth.hs at line 13

[3.7887]

[3.7887]

import Aftok.Project
replacement in server/Aftok/Snaplet/Projects.hs at line 4

[3.2398]→[3.2378:2414](∅→∅)

module Aftok.Snaplet.Projects where

[3.2398]

[3.2462]

module Aftok.Snaplet.Projects
( projectCreateHandler
, projectListHandler
, projectGetHandler
, projectInviteHandler
) where
edit in server/Aftok/Snaplet/Projects.hs at line 24

[3.2498]

[3.2498]

import Aftok.Project
replacement in server/Aftok/Snaplet/Projects.hs at line 32

[3.2726]→[3.11999:12066](∅→∅)

data CProject = CP { cpn :: Text, cpdepf :: DepreciationFunction }

[3.2726]

[3.2791]

data ProjectCreateRequest = CP { cpn :: Text, cpdepf :: DepreciationFunction }
replacement in server/Aftok/Snaplet/Projects.hs at line 34

[3.2792]→[3.12067:12100](∅→∅)

instance FromJSON CProject where

[3.2792]

[3.12100]

instance FromJSON ProjectCreateRequest where
edit in server/Aftok/Snaplet/Users.hs at line 17

[3.8846]

[3.8846]

import Aftok.Project
edit in server/Aftok/Snaplet/WorkLog.hs at line 15

[3.9928]

[3.9928]

import Aftok.Project
edit in server/Main.hs at line 14

[3.11489]

[3.11489]

import Aftok.Snaplet.Auctions
edit in server/Main.hs at line 53

[3.12971]

[3.7876]

auctionCreateRoute = void $ method POST auctionCreateHandler
edit in server/Main.hs at line 72

[33.322]

[3.13275]

, ("projects/:projectId/auctions", auctionCreateRoute)