Postgres & auth are beginning to function.

[?]

Feb 16, 2015, 12:24 AM

PBD7LZYQHXAA3KLH2ZUX5GW4UFML6BQ32KXZF4KZ6OYFASUYFJ5QC

Dependencies

[2] I2KHGVD4 Require project permissions for access to most data.
[3] GKGVYBZG Added JSON serialization to TimeLog
[4] NVOCQVAS Initial failing tests.
[5] TNR3TEHK Switch to Postgres + snaplet arch compiles.
[6] BROSTG5K Beginning of modularization of server.
[7] VJPT6HDR Fix remaining type errors after addition of login handler.
[8] IZEVQF62 Work in progress replacing sqlite with postgres.
[9] Z7KS5XHH Very WIP. Wow.
[10] BXGLKYRX Added primitive user registration handler.
[*] ADMKQQGC Initial empty Snap project.
[*] OBFPJS2G Project successfully builds and tests under nix.
[*] 5W5M56VJ Move library code to 'lib'
[*] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[*] WO2MINIF Auctions now compile!
[*] HE3JTXO3 Added client call to payouts.
[*] 4IQVQL4T Added client for payouts endpoint.
[*] AXKKXBWN Initial attempt at writing down my ideas for a company based on trust.

Change contents

edit in .gitignore at line 12

[13.29]

local
stable
snaplets
regtest.conf
site_key.txt
replacement in lib/Quixotic/Database/PostgreSQL.hs at line 152

[3.4341]→[3.4341:4444](∅→∅)

"INSERT INTO bids (auction_id, user_id, bid_seconds, bid_amount, bid_time) values (?, ?, ?, ?, ?)"

[3.4341]

[3.4444]

"INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time) values (?, ?, ?, ?, ?)"
replacement in lib/Quixotic/Database/PostgreSQL.hs at line 172

[3.4978]→[3.4978:5055](∅→∅)

"INSERT INTO users (handle, btc_addr, email) VALUES (?, ?) RETURNING id"

[3.4978]

[3.339]

"INSERT INTO users (handle, btc_addr, email) VALUES (?, ?, ?) RETURNING id"
file addition: Util (d--r------)

[14.18]
file addition: Http.hs (----------)

[0.242]

module Quixotic.Util.Http where

import ClassyPrelude

import Data.ByteString (split)
import Data.Attoparsec.ByteString
import qualified Data.ByteString.Base64 as B64

type AuthHeader = (Text, ByteString)

authHeaderParser :: Parser AuthHeader
authHeaderParser = do
let isBase64Char w = (w >= 47 && w <= 57 ) ||
(w >= 64 && w <= 90 ) ||
(w >= 97 && w <= 122) ||
(w == 43 || w == 61 )
b64 <- string "Basic " *> takeWhile1 isBase64Char
decoded <- either fail pure $ B64.decode b64
case split 58 decoded of
(uname : pwd : []) -> pure $ (decodeUtf8 uname, pwd)
_ -> fail "Could not unpack auth header into username and password components"
replacement in lib/Quixotic.hs at line 40

[3.3223]→[3.3223:3251](∅→∅)

{ _projectId :: ProjectId

[3.3223]

[3.3251]

{ _invitationProject :: ProjectId
edit in quixotic.cabal at line 30

[15.751]

[16.1584]

Quixotic.Util.Http
edit in quixotic.cabal at line 35

[16.1742]

[13.3072]

, attoparsec >= 0.12.1.2
edit in quixotic.cabal at line 37

[13.3089]

[16.1780]

, bytestring
edit in quixotic.cabal at line 53

[17.1084]

[18.1070]

, base64-bytestring >= 1.0.0.1
edit in quixotic.cabal at line 71

[16.2171]

[13.3112]

, attoparsec
file addition: scripts (d--r------)

[19.2]
file addition: create_project.sh (---r------)

[0.1220]

#!/bin/bash

curl -v -u "nuttycom:kjntest" -H "Content-Type: application/json" -d '{"projectName":"the"}' http://localhost:8000/projects
file addition: create_user.sh (---r------)

[0.1220]

#!/bin/bash

curl -v -H "Content-Type: application/json" -d '{"username":"nuttycom", "password":"kjntest", "email":"kris@quixoticcompany.com", "btcAddr":"1KamUn1BaRMd2HwikyQWGTdUvfPScg9QA5"}' http://localhost:8000/register
edit in server/Main.hs at line 17

[2.117]

[3.782]

import Quixotic.Snaplet.Projects
replacement in server/Main.hs at line 52

[3.106]→[3.823:867](∅→∅),[2.179]→[3.823:867](∅→∅),[3.823]→[3.823:867](∅→∅)

, ("register", registerHandler)

[2.179]

[3.3639]

, ("register", method POST registerHandler)
, ("projects", projectsHandler)
replacement in server/Main.hs at line 57

[3.3862]→[3.3862:3957](∅→∅)

, ("projects/:projectId", ok)
, ("payouts/:projectId", payoutsHandler)

[3.3862]

[3.8999]

, ("projects/:projectId", method GET ok)
, ("payouts/:projectId", method GET payoutsHandler)
replacement in server/Quixotic/Snaplet/Auth.hs at line 7

[2.310]→[2.310:423](∅→∅)

import Data.ByteString (split)
import Data.Attoparsec.ByteString
import qualified Data.ByteString.Base64 as B64

[2.310]

[2.423]

import Data.Attoparsec.ByteString (parseOnly)
edit in server/Quixotic/Snaplet/Auth.hs at line 11

[2.465]

[2.465]

import Quixotic.Util.Http (authHeaderParser)
edit in server/Quixotic/Snaplet/Auth.hs at line 18

[2.605]→[2.605:643](∅→∅)

type AuthHeader = (Text, ByteString)
edit in server/Quixotic/Snaplet/Auth.hs at line 19

[2.644]→[2.644:1164](∅→∅)

authHeaderParser :: Parser AuthHeader
authHeaderParser = do
let isBase64Char w = (w >= 47 && w <= 57 ) ||
(w >= 64 && w <= 90 ) ||
(w >= 97 && w <= 122) ||
(w == 43 || w == 61 )
b64 <- string "Basic" *> takeWhile1 isBase64Char
decoded <- either fail pure $ B64.decode b64
case split 58 decoded of
(uname : pwd : []) -> pure $ (decodeUtf8 uname, pwd)
_ -> fail "Could not unpack auth header into username and password components"
edit in server/Quixotic/Snaplet/Auth.hs at line 23

[2.1323]

[2.1323]

logError rawHeader
edit in server/Quixotic/Snaplet/Auth.hs at line 46

[2.2252]

[2.2252]

QDB{..} <- view qdb <$> with qm get
replacement in server/Quixotic/Snaplet/Auth.hs at line 50

[2.2445]→[2.2445:2558](∅→∅)

Just pid -> error $ "FIXME: implement project access check - got pid " ++ " " ++ show uid ++ " " ++ show pid

[2.2445]

[2.2558]

Just pid -> do
projects <- liftPG . runReaderT $ findUserProjects uid
if any (\p -> p ^. projectId == pid) projects
then pure pid
else snapError 403 $ "User " ++ (tshow uid) ++ " does not have access to project " ++ (tshow pid)
file addition: Projects.hs (----------)

[2.182]

{-# LANGUAGE TemplateHaskell #-}

module Quixotic.Snaplet.Projects
( projectsHandler
) where

import ClassyPrelude

import Control.Lens
import Control.Monad.State
import Data.Aeson as A
import Quixotic
import Quixotic.Database
import Quixotic.Snaplet
import Quixotic.Snaplet.Auth

import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.PostgresqlSimple

data CreateProject = CreateProject { createProjectName :: Text }

instance FromJSON CreateProject where
parseJSON (Object v) = CreateProject <$> v .: "projectName"
parseJSON _ = mzero

projectsHandler :: Handler App App ()
projectsHandler = do
void $ method POST projectCreateHandler
void $ method GET projectListHandler

projectCreateHandler :: Handler App App ProjectId
projectCreateHandler = do
QDB{..} <- view qdb <$> with qm get
uid <- requireUserId
requestBody <- readRequestBody 4096
cp <- maybe (snapError 400 "Could not parse project data") pure $ A.decode requestBody
timestamp <- liftIO getCurrentTime
liftPG . runReaderT . createProject $ Project (createProjectName cp) timestamp uid

projectListHandler :: Handler App App [Project]
projectListHandler = ok
replacement in server/Quixotic/Snaplet/Users.hs at line 39

[3.716]→[3.716:751](∅→∅)

requestBody <- readRequestBody 0

[3.716]

[3.751]

requestBody <- readRequestBody 4096
replacement in server/Quixotic/Snaplet/Users.hs at line 41

[3.843]→[3.843:1025](∅→∅)

authUser <- with auth $
AU.createUser (userData ^. (cuser.username._UserName)) (userData ^. password)
let createQUser = liftPG $ runReaderT (createUser $ userData ^. cuser)

[3.843]

[3.1025]

let createSUser = AU.createUser (userData ^. (cuser.username._UserName)) (userData ^. password)
createQUser = liftPG $ runReaderT (createUser $ userData ^. cuser)
authUser <- with auth createSUser
replacement in server/Quixotic/Snaplet.hs at line 51

[3.3096]→[3.3096:3122](∅→∅)

ok :: MonadSnap m => m ()

[3.3096]

[3.3122]

ok :: MonadSnap m => m a
edit in server/Quixotic/Snaplet.hs at line 56

[2.3904]
replacement in sql/quixotic-pg.sql at line 2

[3.3166]→[3.3166:3201](∅→∅)

btc_addr varchar(34) primary key

[3.3166]

[3.3201]

id serial primary key,
handle text not null,
btc_addr text not null,
email text not null
);

create table projects (
id serial primary key,
project_name text not null,
inception_date timestamp without time zone not null,
initiator_id integer references users (id) not null
replacement in sql/quixotic-pg.sql at line 15

[3.3205]→[3.3205:3234](∅→∅)

create table users_trusted (

[3.3205]

[3.3234]

create type event_t as enum ('start_work', 'stop_work');

create table work_events (
replacement in sql/quixotic-pg.sql at line 19

[3.3259]→[3.3259:3357](∅→∅)

btc_addr varchar(34) references users (btc_addr) not null,
trust_interval interval not null
)

[3.3259]

[3.3357]

project_id integer references projects(id) not null,
user_id integer references users(id) not null,
btc_addr text not null,
event_type event_t not null,
event_time timestamp without time zone not null
);
replacement in sql/quixotic-pg.sql at line 26

[3.3358]→[3.3358:3418](∅→∅)

create type event_type as enum ('start_work', 'stop_work');

[3.3358]

[3.3418]

create table auctions (
id serial primary key,
project_id integer references projects(id) not null,
initiator_id integer references users (id) not null,
raise_amount numeric not null,
end_time timestamp without time zone not null
);
replacement in sql/quixotic-pg.sql at line 34

[3.3419]→[3.3419:3442](∅→∅)

create table timelog (

[3.3419]

[3.3442]

create table bids (
replacement in sql/quixotic-pg.sql at line 36

[3.3467]→[3.3467:3610](∅→∅)

btc_addr varchar(34) references users (btc_addr) not null,
log_time timestamp without time zone not null,
log_type event_type not null
)

[3.3467]

auction_id integer references projects (id) not null,
bidder_id integer references users (id) not null,
bid_seconds integer not null,
bid_amount numeric not null,
bid_time timestamp without time zone not null
);
file addition: Util (d--r------)

[13.3700]
file addition: HttpSpec.hs (----------)

[0.4914]

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

module Quixotic.Util.HttpSpec where

import ClassyPrelude

import Quixotic.Util.Http
import Data.Attoparsec.ByteString

import Test.Hspec

spec :: Spec
spec = do
describe "HTTP Basic header parsing" $ do
it "parses the Basic auth header" $ do
let rawHeader = "Basic bnV0dHljb206a2pudGVzdA=="

(parseOnly authHeaderParser rawHeader) `shouldBe` (Right ("nuttycom", "kjntest"))

main :: IO ()
main = hspec spec