From cb467b62c15cb9e1473f7264600063d78f8f4983 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 9 Nov 2014 21:49:16 -0800 Subject: [PATCH 01/45] WIP: cleaner PgQuery functions --- dbapi.cabal | 9 +- src/PgQuery.hs | 315 +++++++++++----------------------------------- src/RangeQuery.hs | 67 +++++----- 3 files changed, 116 insertions(+), 275 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 1ff77708b..39811709d 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -14,8 +14,9 @@ executable dbapi ghc-options: -Wall -W -Werror -O2 default-language: Haskell2010 default-extensions: OverloadedStrings + other-extensions: QuasiQuotes build-depends: base >=4.6 && <5 - , HDBC, HDBC-postgresql + , postgresql-simple >= 0.4.7.0 , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 @@ -24,6 +25,7 @@ executable dbapi , scientific, time , aeson, network >= 2.6 , bytestring, text, split, string-conversions + , stringsearch , containers, unordered-containers , optparse-applicative >= 0.9.1 && < 0.10 , regex-base, regex-tdfa @@ -33,6 +35,7 @@ executable dbapi , bcrypt, base64-string , network-uri >= 2.6 , resource-pool, process + , blaze-builder Other-Modules: Dbapi , PgStructure , PgQuery @@ -51,7 +54,7 @@ Test-Suite spec Other-Modules: Dbapi, Spec, SpecHelper Build-Depends: base, hspec2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json - , HDBC, HDBC-postgresql + , postgresql-simple >= 0.4.7.0 , warp >= 3.0.2, wai >= 3.0.1 , HTTP, convertible , case-insensitive @@ -60,6 +63,7 @@ Test-Suite spec , http-types, scientific, time , bytestring, aeson, network >= 2.6 , text, optparse-applicative + , stringsearch , unordered-containers , regex-base , string-conversions @@ -72,3 +76,4 @@ Test-Suite spec , split , network-uri >= 2.6 , resource-pool + , blaze-builder diff --git a/src/PgQuery.hs b/src/PgQuery.hs index f3b193b76..11f657911 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,262 +1,93 @@ --- {{{ Imports -module PgQuery ( - getRows -, insert -, update -, upsert -, addUser -, signInRole -, setRole -, resetRole -, checkPass -, pgFmtIdent -, pgFmtLit -, RangedResult(..) -, LoginAttempt(..) -, DbRole -) where +module PgQuery where -import Data.Text (Text, splitOn, intercalate, replace, takeWhile) -import Data.String.Conversions (cs) -import Data.Functor ( (<$>) ) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid ((<>), mconcat) -import qualified Data.Map as M - -import Text.Regex.TDFA ((=~)) -import Text.Regex.TDFA.Text () - -import Control.Monad (join) - -import qualified RangeQuery as R +import RangeQuery +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.ToField import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.List as L - -import Database.HDBC hiding (colType, colNullable) -import Database.HDBC.PostgreSQL - +import Data.ByteString.Search (split) import qualified Network.HTTP.Types.URI as Net - -import Types (SqlRow(..), getRow, sqlRowColumns, sqlRowValues) -import Crypto.BCrypt (hashPasswordUsingPolicy, fastBcryptHashingPolicy, validatePassword) - --- }}} +import Blaze.ByteString.Builder.ByteString (fromByteString) +import Data.Text hiding (map, intersperse, split) +import Data.Monoid +import Data.Maybe (fromMaybe) +import Data.Functor ( (<$>) ) +import Data.String.Conversions (cs) +import qualified Data.List as L data RangedResult = RangedResult { rrFrom :: Int , rrTo :: Int , rrTotal :: Int -, rrBody :: BL.ByteString +, rrBody :: BS.ByteString } deriving (Show) -type Schema = Text -type DbRole = BS.ByteString - -data LoginAttempt = - NoCredentials - | MalformedAuth - | LoginFailed - | LoginSuccess DbRole - deriving (Eq, Show) - -getRows :: Schema -> Text -> Net.Query -> Maybe R.NonnegRange -> Connection -> IO RangedResult -getRows schema table qq range conn = do - r <- quickQuery conn (cs query) [] - - return $ case r of - [[total, _, SqlNull]] -> RangedResult offset 0 (fromSql total) "[]" - [[total, limited_total, json]] -> - RangedResult offset (offset + fromSql limited_total - 1) - (fromSql total) (fromSql json) - _ -> RangedResult 0 0 0 "[]" - - where - offset = fromMaybe 0 $ R.offset <$> range - query = globalAndLimitedCounts schema table qq <> jsonArrayRows ( - selectStarClause schema table - <> whereClause qq - <> orderClause qq - <> limitClause range) - - -whereClause :: Net.Query -> Text -whereClause qs = - if null qs then "" else " where " <> conjunction - - where - cols = [ col | col <- qs, fst col `notElem` ["order"] ] - conjunction = mconcat $ L.intersperse " and " (map wherePred cols) - - -orderClause :: Net.Query -> Text -orderClause qs = do - let order = fromMaybe "" $ join $ lookup "order" qs - terms = mapMaybe parseOrderTerm $ splitOn "," $ cs order - termPred = mconcat $ L.intersperse ", " (map orderTermSql terms) - - if null terms - then "" - else " order by " <> termPred - - where - parseOrderTerm :: Text -> Maybe OrderTerm - parseOrderTerm s = - case splitOn "." s of - [d,c] -> - if d `elem` ["asc", "desc"] - then Just $ OrderTerm d c - else Nothing - _ -> Nothing - - orderTermSql :: OrderTerm -> Text - orderTermSql t = pgFmtIdent (otColumn t) <> " " <> otDirection t - +type CompleteQuery = (Query, [Action]) +type CompleteQueryT = CompleteQuery -> CompleteQuery +type JsonQuery = CompleteQuery +data QualifiedTable = QualifiedTable { + qtSchema :: Text +, qtName :: Text +} deriving (Show) data OrderTerm = OrderTerm { - otDirection :: Text -, otColumn :: Text + otTerm :: BS.ByteString +, otDirection :: BS.ByteString } +limitT :: Maybe NonnegRange -> CompleteQueryT +limitT r q = + q <> (" LIMIT ? OFFSET ? ", [toField limit, toField offset]) + where + limit = fromMaybe "ALL" $ show . rangeLimit <$> r + offset = fromMaybe 0 $ rangeOffset <$> r -wherePred :: Net.QueryItem -> Text -wherePred (column, predicate) = - pgFmtIdent (cs column) <> " " <> op <> " " <> pgFmtLit (cs value) +whereT :: Net.Query -> CompleteQueryT +whereT params q = + if L.null params + then q + else q <> conjunction + where + cols = [ col | col <- params, fst col `notElem` ["order"] ] + conjunction = mconcat $ L.intersperse (" and ",[]) (map wherePred cols) + +orderT :: [OrderTerm] -> CompleteQueryT +orderT ts q = + if L.null ts + then q + else q <> (" order by ",[]) <> clause + where + clause = mconcat $ L.intersperse (", ",[]) (map queryTerm ts) + queryTerm :: OrderTerm -> CompleteQuery + queryTerm t = + (" ? ? ", + [EscapeIdentifier (otTerm t), Plain (fromByteString $ otDirection t)] + ) + -- order = fromMaybe "" $ join (lookup "order" qs) + -- terms = mapMaybe parseOrderTerm $ splitOn "," $ cs order + -- termPred = mconcat $ L.intersperse ", " (map orderTermSql terms) + +wherePred :: Net.QueryItem -> CompleteQuery +wherePred (col, predicate) = + (" ? ? ? ", [EscapeIdentifier col, Plain op, toField value]) where opCode:rest = BS.split '.' $ fromMaybe "." predicate value = BS.intercalate "." rest - op = case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - _ -> "=" + op = fromByteString $ case opCode of + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + _ -> "=" -limitClause :: Maybe R.NonnegRange -> Text -limitClause range = - cs $ " LIMIT " <> limit <> " OFFSET " <> show offset <> " " - - where - limit = fromMaybe "ALL" $ show <$> (R.limit =<< range) - offset = fromMaybe 0 $ R.offset <$> range - -globalAndLimitedCounts :: Schema -> Text -> Net.Query -> Text -globalAndLimitedCounts schema table qq = - " select " - <> "(select count(1) from " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " " - <> whereClause qq - <> "), count(t), " - -selectStarClause :: Schema -> Text -> Text -selectStarClause schema table = - " select * from " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " " - -jsonArrayRows :: Text -> Text -jsonArrayRows q = - "array_to_json(array_agg(row_to_json(t))) from (" <> q <> ") t" - -insert :: Schema -> Text -> SqlRow -> Connection -> IO (M.Map String SqlValue) -insert schema table row conn = do - stmt <- prepare conn $ cs sql - _ <- execute stmt $ sqlRowValues row - Just m <- fetchRowMap stmt - return m - - where sql = insertClause schema table row - -addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Connection -> IO () -addUser identity pass role conn = do - Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy $ cs pass - _ <- quickQuery conn - "insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)" - $ map toSql [identity, hashed, role] - return () - -signInRole :: BS.ByteString -> BS.ByteString -> Connection -> IO LoginAttempt -signInRole user pass conn = do - u <- quickQuery conn "select pass, rolname from dbapi.auth where id = ?" [toSql user] - return $ case u of - [[hashed, role]] -> - if checkPass (fromSql hashed) (cs pass) - then LoginSuccess $ fromSql role - else LoginFailed - _ -> LoginFailed - -checkPass :: BS.ByteString -> BS.ByteString -> Bool -checkPass = validatePassword - -upsert :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> - IO (M.Map String SqlValue) -upsert schema table row qq conn = do - stmt <- prepare conn $ cs $ upsertClause schema table row qq - _ <- execute stmt $ join $ replicate 2 $ sqlRowValues row - m <- fetchRowMap stmt - return $ fromMaybe M.empty m - -update :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> - IO (M.Map String SqlValue) -update schema table row qq conn = do - stmt <- prepare conn $ cs $ updateClause schema table row qq - _ <- execute stmt $ sqlRowValues row - m <- fetchRowMap stmt - return $ fromMaybe M.empty m - -placeholders :: Text -> SqlRow -> Text -placeholders symbol = intercalate ", " . map (const symbol) . getRow - -insertClause :: Schema -> Text -> SqlRow -> Text -insertClause schema table (SqlRow []) = - "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " default values returning *" -insertClause schema table row = - "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " (" <> - intercalate ", " (map pgFmtIdent (sqlRowColumns row)) - <> ") values (" <> placeholders "?" row <> ") returning *" - -insertClauseViaSelect :: Schema -> Text -> SqlRow -> Text -insertClauseViaSelect schema table row = - "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " (" <> - intercalate ", " (map pgFmtIdent (sqlRowColumns row)) - <> ") select " <> placeholders "?" row - -updateClause :: Schema -> Text -> SqlRow -> Net.Query -> Text -updateClause schema table row qq = - "update " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " set (" <> - intercalate ", " (map pgFmtIdent (sqlRowColumns row)) - <> ") = (" <> placeholders "?" row <> ")" - <> whereClause qq - -upsertClause :: Schema -> Text -> SqlRow -> Net.Query -> Text -upsertClause schema table row qq = - "with upsert as (" <> updateClause schema table row qq - <> " returning *) " <> insertClauseViaSelect schema table row - <> " where not exists (select * from upsert) returning *" - -pgFmtIdent :: Text -> Text -pgFmtIdent x = - let escaped = replace "\"" "\"\"" (trimNullChars x) in - if escaped =~ danger - then "\"" <> escaped <> "\"" - else escaped - - where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: Text - -pgFmtLit :: Text -> Text -pgFmtLit x = - let trimmed = trimNullChars x - escaped = "'" <> replace "'" "''" trimmed <> "'" - slashed = replace "\\" "\\\\" escaped in - if escaped =~ ("\\\\" :: Text) - then "E" <> slashed - else slashed - -trimNullChars :: Text -> Text -trimNullChars = Data.Text.takeWhile (/= '\x0') - -setRole :: Connection -> DbRole -> IO () -setRole conn role = runRaw conn $ "set role " <> cs role - -resetRole :: Connection -> IO () -resetRole conn = runRaw conn "reset role" +orderParseTerm :: BS.ByteString -> Maybe OrderTerm +orderParseTerm s = + case split "." s of + [d,c] -> + if d `elem` ["asc", "desc"] + then Just $ OrderTerm (cs c) $ + if d == "asc" then "asc" else "desc" + else Nothing + _ -> Nothing diff --git a/src/RangeQuery.hs b/src/RangeQuery.hs index 45b6dfdbc..6eb4bfedf 100644 --- a/src/RangeQuery.hs +++ b/src/RangeQuery.hs @@ -1,8 +1,16 @@ -module RangeQuery where +module RangeQuery ( + rangeParse +, rangeRequested +, rangeLimit +, rangeOffset +, NonnegRange +) where import Control.Applicative import Network.HTTP.Types.Header +import qualified Data.ByteString.Char8 as BS + import Data.Ranged.Boundaries import Data.Ranged.Ranges @@ -14,6 +22,33 @@ import Data.Maybe (fromMaybe, listToMaybe) type NonnegRange = Range Int +rangeParse :: BS.ByteString -> Maybe NonnegRange +rangeParse range = do + let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString + + parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) + + let [_, from, to] = readMaybe . cs <$> parsedRange + let lower = fromMaybe emptyRange (rangeGeq <$> from) + let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to) + + return $ rangeIntersection lower upper + +rangeRequested :: RequestHeaders -> Maybe NonnegRange +rangeRequested = (rangeParse =<<) . lookup hRange + +rangeLimit :: NonnegRange -> Maybe Int +rangeLimit range = + case [rangeLower range, rangeUpper range] + of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) + _ -> Nothing + +rangeOffset :: NonnegRange -> Int +rangeOffset range = + case rangeLower range + of BoundaryBelow from -> from + _ -> error "range without lower bound" -- should never happen + rangeGeq :: Int -> NonnegRange rangeGeq n = Range (BoundaryBelow n) BoundaryAboveAll @@ -21,33 +56,3 @@ rangeGeq n = rangeLeq :: Int -> NonnegRange rangeLeq n = Range BoundaryBelowAll (BoundaryAbove n) - -parseRange :: String -> Maybe NonnegRange -parseRange range = do - let rangeRegex = "^([0-9]+)-([0-9]*)$" :: String - - parsedRange <- listToMaybe (range =~ rangeRegex :: [[String]]) - - let [_, from, to] = readMaybe <$> parsedRange - let lower = fromMaybe emptyRange (rangeGeq <$> from) - let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to) - - return $ rangeIntersection lower upper - -requestedRange :: RequestHeaders -> Maybe NonnegRange -requestedRange hdrs = parseRange =<< cs <$> lookup hRange hdrs - -requestedContentRange :: RequestHeaders -> Maybe NonnegRange -requestedContentRange hdrs = parseRange =<< cs <$> lookup "Content-Range" hdrs - -limit :: NonnegRange -> Maybe Int -limit range = - case [rangeLower range, rangeUpper range] - of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) - _ -> Nothing - -offset :: NonnegRange -> Int -offset range = - case rangeLower range - of BoundaryBelow from -> from - _ -> error "range without lower bound" -- should never happen From 2f91fdd8b5ab05861d8d67acc76d55fce57bcedb Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 9 Nov 2014 22:55:31 -0800 Subject: [PATCH 02/45] WIP: more clean query functions --- src/PgQuery.hs | 57 ++++++++++++++++++++++++++++++++++---------------- 1 file changed, 39 insertions(+), 18 deletions(-) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 11f657911..32f9e657a 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,4 +1,13 @@ -module PgQuery where +module PgQuery ( + CompleteQuery +, QualifiedTable +, limitT +, whereT +, orderT +, countRows +, asJsonWithCount +, orderParse +) where import RangeQuery import Database.PostgreSQL.Simple @@ -7,26 +16,18 @@ import qualified Data.ByteString.Char8 as BS import Data.ByteString.Search (split) import qualified Network.HTTP.Types.URI as Net import Blaze.ByteString.Builder.ByteString (fromByteString) -import Data.Text hiding (map, intersperse, split) import Data.Monoid -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Functor ( (<$>) ) +import Control.Monad (join) import Data.String.Conversions (cs) import qualified Data.List as L -data RangedResult = RangedResult { - rrFrom :: Int -, rrTo :: Int -, rrTotal :: Int -, rrBody :: BS.ByteString -} deriving (Show) - type CompleteQuery = (Query, [Action]) type CompleteQueryT = CompleteQuery -> CompleteQuery -type JsonQuery = CompleteQuery data QualifiedTable = QualifiedTable { - qtSchema :: Text -, qtName :: Text + qtSchema :: BS.ByteString +, qtName :: BS.ByteString } deriving (Show) data OrderTerm = OrderTerm { @@ -48,7 +49,7 @@ whereT params q = else q <> conjunction where cols = [ col | col <- params, fst col `notElem` ["order"] ] - conjunction = mconcat $ L.intersperse (" and ",[]) (map wherePred cols) + conjunction = mconcat $ L.intersperse andq (map wherePred cols) orderT :: [OrderTerm] -> CompleteQueryT orderT ts q = @@ -56,15 +57,23 @@ orderT ts q = then q else q <> (" order by ",[]) <> clause where - clause = mconcat $ L.intersperse (", ",[]) (map queryTerm ts) + clause = mconcat $ L.intersperse commaq (map queryTerm ts) queryTerm :: OrderTerm -> CompleteQuery queryTerm t = (" ? ? ", [EscapeIdentifier (otTerm t), Plain (fromByteString $ otDirection t)] ) - -- order = fromMaybe "" $ join (lookup "order" qs) - -- terms = mapMaybe parseOrderTerm $ splitOn "," $ cs order - -- termPred = mconcat $ L.intersperse ", " (map orderTermSql terms) + +countRows :: QualifiedTable -> CompleteQuery +countRows t = + ("select count(1) from ?.?", + [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) + +asJsonWithCount :: CompleteQueryT +asJsonWithCount (sql, params) = ( + "count(t), array_to_json(array_agg(row_to_json(t))) from (" <> sql <> ") t" + , params + ) wherePred :: Net.QueryItem -> CompleteQuery wherePred (col, predicate) = @@ -82,6 +91,12 @@ wherePred (col, predicate) = "neq" -> "<>" _ -> "=" +orderParse :: Net.Query -> [OrderTerm] +orderParse q = + mapMaybe orderParseTerm . split "," $ cs order + where + order = fromMaybe "" $ join (lookup "order" q) + orderParseTerm :: BS.ByteString -> Maybe OrderTerm orderParseTerm s = case split "." s of @@ -91,3 +106,9 @@ orderParseTerm s = if d == "asc" then "asc" else "desc" else Nothing _ -> Nothing + +commaq :: CompleteQuery +commaq = (", ", []) + +andq :: CompleteQuery +andq = (" and ", []) From 7196fbc001f500663e457fb455bc0e5f054b7c38 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 10 Nov 2014 15:59:43 -0800 Subject: [PATCH 03/45] WIP: use postgresql-simple in pgstructure --- src/PgQuery.hs | 2 +- src/PgStructure.hs | 237 ++++++++++++++++++++------------------------- 2 files changed, 107 insertions(+), 132 deletions(-) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 32f9e657a..41e6a1622 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,6 +1,6 @@ module PgQuery ( CompleteQuery -, QualifiedTable +, QualifiedTable(..) , limitT , whereT , orderT diff --git a/src/PgStructure.hs b/src/PgStructure.hs index e323a1569..544ed833f 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -1,29 +1,127 @@ +{-# LANGUAGE QuasiQuotes #-} module PgStructure where +import PgQuery (QualifiedTable(..)) import Data.Functor ( (<$>) ) -import Data.Maybe (mapMaybe) import Data.Text hiding (foldl, map, zipWith, concat) -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) import Control.Applicative ( (<*>) ) -import qualified Data.ByteString.Lazy as BL - +import qualified Data.List as L import qualified Data.Aeson as JSON import qualified Data.Map as Map -import Database.HDBC hiding (colType, colNullable) -import Database.HDBC.PostgreSQL - +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.SqlQQ +import Database.PostgreSQL.Simple.FromRow import Data.Aeson ((.=)) +foreignKeys :: Connection -> QualifiedTable -> IO (Map.Map Text ForeignKey) +foreignKeys c table = do + r <- query c [sql| + select kcu.column_name, ccu.table_name AS foreign_table_name, + ccu.column_name AS foreign_column_name + from information_schema.table_constraints AS tc + join information_schema.key_column_usage AS kcu + on tc.constraint_name = kcu.constraint_name + join information_schema.constraint_column_usage AS ccu + on ccu.constraint_name = tc.constraint_name + where constraint_type = 'FOREIGN KEY' + and tc.table_name=? and tc.table_schema = ? + order by kcu.column_name + |] + (qtName table, qtSchema table) + + return $ foldl addKey Map.empty r + where + addKey m [col, ftab, fcol] = Map.insert col (ForeignKey ftab fcol) m + addKey _ _ = error "foreignKeys: should never happen" + + +tables :: Connection -> Text -> IO [Table] +tables c schema = + query c [sql| + select table_schema, table_name, + is_insertable_into + from information_schema.tables + where table_schema = ? + order by table_name + |] $ Only schema + + +columns :: Connection -> QualifiedTable -> IO [Column] +columns c table = do + cols <- query c [sql| + select info.table_schema as schema, info.table_name as table_name, + info.column_name as name, info.ordinal_position as position, + info.is_nullable as nullable, info.data_type as col_type, + info.is_updatable as updatable, + info.character_maximum_length as max_len, + info.numeric_precision as precision, + info.column_default as default_value, + array_to_string(enum_info.vals, ',') as enum + from ( + select table_schema, table_name, column_name, ordinal_position, + is_nullable, data_type, is_updatable, + character_maximum_length, numeric_precision, + column_default, udt_name + from information_schema.columns + where table_schema = ? and table_name = ? + ) as info + left outer join ( + select n.nspname as s, + t.typname as n, + array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals + from pg_type t + join pg_enum e on t.oid = e.enumtypid + join pg_catalog.pg_namespace n ON n.oid = t.typnamespace + group by s, n + ) as enum_info + on (info.udt_name = enum_info.n) + order by position |] (qtSchema table, qtName table) + + fks <- foreignKeys c table + return $ map (\col -> col { colFK = Map.lookup (colName col) fks }) cols + + +primaryKeyColumns :: Connection -> QualifiedTable -> IO [Text] +primaryKeyColumns c table = do + r <- query c [sql| + select kc.column_name + from + information_schema.table_constraints tc, + information_schema.key_column_usage kc + where + tc.constraint_type = 'PRIMARY KEY' + and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema + and kc.constraint_name = tc.constraint_name + and kc.table_schema = ? + and kc.table_name = ? |] (qtSchema table, qtName table) + return $ concat r + + data Table = Table { tableSchema :: Text , tableName :: Text , tableInsertable :: Bool } deriving (Show) +instance FromRow Table where + fromRow = Table <$> field <*> field <*> (toBool <$> field) + +instance FromRow Column where + fromRow = Column <$> + field <*> field <*> field <*> field + <*> (toBool <$> field) + <*> field + <*> (toBool <$> field) + <*> field <*> field <*> field + <*> (vanishNull . splitOn "," <$> field) + <*> return Nothing + +vanishNull :: [a] -> Maybe [a] +vanishNull xs = if L.null xs then Nothing else Just xs + instance JSON.ToJSON Table where toJSON v = JSON.object [ "schema" .= tableSchema v @@ -40,24 +138,6 @@ data ForeignKey = ForeignKey { instance JSON.ToJSON ForeignKey where toJSON fk = JSON.object ["table".=fkTable fk, "column".=fkCol fk] -foreignKeys :: Text -> Text -> Connection -> IO (Map.Map Text ForeignKey) -foreignKeys schema table conn = do - r <- quickQuery conn - "select kcu.column_name, ccu.table_name AS foreign_table_name,\ - \ ccu.column_name AS foreign_column_name \ - \from information_schema.table_constraints AS tc \ - \ join information_schema.key_column_usage AS kcu \ - \ on tc.constraint_name = kcu.constraint_name \ - \ join information_schema.constraint_column_usage AS ccu \ - \ on ccu.constraint_name = tc.constraint_name \ - \where constraint_type = 'FOREIGN KEY' \ - \ and tc.table_name=? and tc.table_schema = ? \ - \order by kcu.column_name" (map toSql [table, schema]) - return $ foldl addKey Map.empty $ map (map fromSql) r - where - addKey m [col, ftab, fcol] = Map.insert col (ForeignKey ftab fcol) m - addKey m _ = m --should never happen - data Column = Column { colSchema :: Text , colTable :: Text @@ -86,108 +166,3 @@ instance JSON.ToJSON Column where , "references".= colFK c , "default" .= colDefault c , "enum" .= colEnum c ] - -data TableOptions = TableOptions { - tblOptcolumns :: [Column] -, tblOptpkey :: [Text] -} - -instance JSON.ToJSON TableOptions where - toJSON t = JSON.object [ - "columns" .= tblOptcolumns t - , "pkey" .= tblOptpkey t ] - -tables :: Text -> Connection -> IO [Table] -tables s conn = do - r <- quickQuery conn - "select table_schema, table_name,\ - \ is_insertable_into\ - \ from information_schema.tables\ - \ where table_schema = ?\ - \ order by table_name" [toSql s] - return $ mapMaybe mkTable r - - where - mkTable [schema, name, insertable] = - Just $ Table (fromSql schema) - (fromSql name) - (toBool (fromSql insertable)) - mkTable _ = Nothing - -columns :: Text -> Text -> Connection -> IO [Column] -columns s t conn = do - r <- quickQuery conn - "select info.table_schema as schema, info.table_name as table_name, \ - \ info.column_name as name, info.ordinal_position as position, \ - \ info.is_nullable as nullable, info.data_type as col_type, \ - \ info.is_updatable as updatable, \ - \ info.character_maximum_length as max_len, \ - \ info.numeric_precision as precision, \ - \ info.column_default as default_value, \ - \ array_to_string(enum_info.vals, ',') as enum \ - \ from ( \ - \ select table_schema, table_name, column_name, ordinal_position, \ - \ is_nullable, data_type, is_updatable, \ - \ character_maximum_length, numeric_precision, \ - \ column_default, udt_name \ - \ from information_schema.columns \ - \ where table_schema = ? and table_name = ? \ - \ ) as info \ - \ left outer join ( \ - \ select n.nspname as s, \ - \ t.typname as n, \ - \ array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals \ - \ from pg_type t \ - \ join pg_enum e on t.oid = e.enumtypid \ - \ join pg_catalog.pg_namespace n ON n.oid = t.typnamespace \ - \ group by s, n \ - \ ) as enum_info \ - \ on (info.udt_name = enum_info.n) \ - \order by position" [toSql s, toSql t] - fks <- foreignKeys s t conn - let lookupFK (_:_:name:_) = Map.lookup (fromSql name) fks - lookupFK _ = Nothing - let cols = zipWith ($) (map mkColumn r) (map lookupFK r) - return cols - - where - mkColumn [schema, table, name, pos, nullable, colT, updatable, maxlen, precision, defVal, enum] = Column (fromSql schema) - (fromSql table) - (fromSql name) - (fromSql pos) - (toBool (fromSql nullable)) - (fromSql colT) - (toBool (fromSql updatable)) - (fromSql maxlen) - (fromSql precision) - (fromSql defVal) - (Data.Text.splitOn "," <$> fromSql enum) - mkColumn _ = error $ "Incomplete column data received for table " <> - cs t <> " in schema " <> cs s <> "." - -printTables :: Text -> Connection -> IO BL.ByteString -printTables schema conn = JSON.encode <$> tables schema conn - -printColumns :: Text -> Text -> Connection -> IO BL.ByteString -printColumns schema table conn = - JSON.encode <$> (TableOptions <$> cols <*> pkey) - where - cols :: IO [Column] - cols = columns schema table conn - pkey :: IO [Text] - pkey = primaryKeyColumns schema table conn - -primaryKeyColumns :: Text -> Text -> Connection -> IO [Text] -primaryKeyColumns s t conn = do - r <- quickQuery conn - "select kc.column_name \ - \ from \ - \ information_schema.table_constraints tc, \ - \ information_schema.key_column_usage kc \ - \where \ - \ tc.constraint_type = 'PRIMARY KEY' \ - \ and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema \ - \ and kc.constraint_name = tc.constraint_name \ - \ and kc.table_schema = ? \ - \ and kc.table_name = ?" [toSql s, toSql t] - return $ map fromSql (concat r) From 41a982fb3126839246eb16f74e05f62246ca7804 Mon Sep 17 00:00:00 2001 From: "Adam C. Baker" Date: Mon, 10 Nov 2014 14:49:50 -0800 Subject: [PATCH 04/45] Remove HDBC imports --- src/Dbapi.hs | 1 - src/Main.hs | 2 -- src/Middleware.hs | 4 ---- src/Types.hs | 2 -- 4 files changed, 9 deletions(-) diff --git a/src/Dbapi.hs b/src/Dbapi.hs index 26e22276a..c05d0872a 100644 --- a/src/Dbapi.hs +++ b/src/Dbapi.hs @@ -30,7 +30,6 @@ import qualified Data.ByteString.Char8 as BS import Data.String.Conversions (cs) import qualified Data.CaseInsensitive as CI -import Database.HDBC.PostgreSQL (Connection) import PgStructure (printTables, printColumns, primaryKeyColumns, columns, Column(colName)) diff --git a/src/Main.hs b/src/Main.hs index 02a759497..2ae275da5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -15,8 +15,6 @@ import Options.Applicative hiding (columns) import Network.Wai.Middleware.Gzip (gzip, def) import Network.Wai.Middleware.Cors (cors) import Network.Wai.Middleware.Static (staticPolicy, only) -import Database.HDBC (disconnect) -import Database.HDBC.PostgreSQL (connectPostgreSQL') import Data.Pool(createPool, destroyAllResources) import Data.List (intercalate) import Data.Version (versionBranch) diff --git a/src/Middleware.hs b/src/Middleware.hs index 55b04f836..533090eae 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -7,10 +7,6 @@ import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) import Data.Pool(withResource, Pool) -import Database.HDBC (runRaw) -import Database.HDBC.PostgreSQL (Connection) -import Database.HDBC.Types (SqlError(..)) - import Data.String.Conversions(cs) import qualified Data.ByteString.Char8 as BS import Control.Exception (finally, throw, catchJust, catch, SomeException, diff --git a/src/Types.hs b/src/Types.hs index 0ad9a72ab..350f022cf 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,8 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Types where -import Database.HDBC (toSql, iToSql, SqlValue(..)) - import qualified Data.Aeson as JSON import Data.Aeson.Types (Parser) From 9d363da8f9b8debe39c13c92498c4410fdc29d8e Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 10 Nov 2014 16:24:19 -0800 Subject: [PATCH 05/45] Consolidate auth functions --- src/Auth.hs | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 src/Auth.hs diff --git a/src/Auth.hs b/src/Auth.hs new file mode 100644 index 000000000..100accc0d --- /dev/null +++ b/src/Auth.hs @@ -0,0 +1,37 @@ +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import Crypto.BCrypt +import Control.Monad (mzero) +import Control.Applicative ( (<$>), (<*>) ) +import Database.PostgreSQL.Simple + +data AuthUser = AuthUser { + userId :: String + , userPass :: String + , userRole :: String + } + +instance JSON.FromJSON AuthUser where + parseJSON (JSON.Object v) = AuthUser <$> + v JSON..: "id" <*> + v JSON..: "pass" <*> + v JSON..: "role" + parseJSON _ = mzero + +type DbRole = BS.ByteString + +data LoginAttempt = + NoCredentials + | MalformedAuth + | LoginFailed + | LoginSuccess DbRole + deriving (Eq, Show) + +checkPass :: BS.ByteString -> BS.ByteString -> Bool +checkPass = validatePassword + +setRole :: Connection -> DbRole -> IO () +setRole conn role = execute conn "set role ?" (Only role) + +resetRole :: Connection -> IO () +resetRole = flip execute_ "reset role" From 9b7af0296ebbd39443a9ac07f3906dca05839119 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 10 Nov 2014 17:07:38 -0800 Subject: [PATCH 06/45] Fix auth functions --- src/Auth.hs | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/src/Auth.hs b/src/Auth.hs index 100accc0d..bf75ff20b 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -1,9 +1,9 @@ -import qualified Data.Aeson as JSON +module Auth where + import qualified Data.ByteString.Char8 as BS import Crypto.BCrypt -import Control.Monad (mzero) -import Control.Applicative ( (<$>), (<*>) ) import Database.PostgreSQL.Simple +import GHC.Int data AuthUser = AuthUser { userId :: String @@ -11,13 +11,6 @@ data AuthUser = AuthUser { , userRole :: String } -instance JSON.FromJSON AuthUser where - parseJSON (JSON.Object v) = AuthUser <$> - v JSON..: "id" <*> - v JSON..: "pass" <*> - v JSON..: "role" - parseJSON _ = mzero - type DbRole = BS.ByteString data LoginAttempt = @@ -30,8 +23,25 @@ data LoginAttempt = checkPass :: BS.ByteString -> BS.ByteString -> Bool checkPass = validatePassword -setRole :: Connection -> DbRole -> IO () +setRole :: Connection -> DbRole -> IO Int64 setRole conn role = execute conn "set role ?" (Only role) -resetRole :: Connection -> IO () +resetRole :: Connection -> IO Int64 resetRole = flip execute_ "reset role" + +addUser :: Connection -> BS.ByteString -> BS.ByteString -> BS.ByteString -> IO Int64 +addUser c identity pass role = do + Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy pass + execute c + "insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)" + (identity, hashed, role) + +signInRole :: Connection -> BS.ByteString -> BS.ByteString -> IO LoginAttempt +signInRole c user pass = do + u <- query c "select pass, rolname from dbapi.auth where id = ?" $ Only user + return $ case u of + [[hashed, role]] -> + if checkPass hashed pass + then LoginSuccess role + else LoginFailed + _ -> LoginFailed From cb80dba23496e1be591a960d3beae044f21f3c15 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Tue, 11 Nov 2014 00:08:51 -0800 Subject: [PATCH 07/45] WIP: converting app request handlers --- src/App.hs | 281 +++++++++++++++++++++++++++++++++++++++++++++ src/Auth.hs | 10 ++ src/Dbapi.hs | 236 ------------------------------------- src/Main.hs | 10 +- src/PgQuery.hs | 20 ++-- src/PgStructure.hs | 25 ++-- 6 files changed, 322 insertions(+), 260 deletions(-) create mode 100644 src/App.hs delete mode 100644 src/Dbapi.hs diff --git a/src/App.hs b/src/App.hs new file mode 100644 index 000000000..6c525aad6 --- /dev/null +++ b/src/App.hs @@ -0,0 +1,281 @@ +module App where + +-- import Types (SqlRow, getRow) + +import Control.Monad (join, mzero) +import Data.Monoid ( (<>) ) +-- import Control.Arrow ((***)) +import Control.Applicative +-- import Options.Applicative hiding (columns) + +import Data.Text hiding (map) +-- import Data.Maybe (fromMaybe, isJust) +import Text.Regex.TDFA ((=~)) +-- import Data.Map (intersection, fromList, toList, Map) +-- import Data.List (sort) +-- import qualified Data.Set as S +-- import Data.Convertible.Base (convert) +-- import Data.Text (strip, Text) + +import Network.HTTP.Types.Status +import Network.HTTP.Types.Header +-- import Network.HTTP.Types.URI + +import Network.HTTP.Base (urlEncodeVars) + +import Network.Wai +-- import Network.Wai.Internal +-- import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) + +import Data.ByteString.Char8 hiding (zip, map) +import Data.String.Conversions (cs) +-- import qualified Data.CaseInsensitive as CI + +-- import PgStructure (printTables, printColumns, primaryKeyColumns, +-- columns, Column(colName)) + +import Data.Aeson +import Database.PostgreSQL.Simple + +import PgQuery +import RangeQuery +import PgStructure +import Data.Ranged.Ranges (emptyRange) + +app :: Connection -> Application +app conn req respond = + respond =<< case (path, verb) of + ([], _) -> do + body <- encode <$> (tables conn $ cs schema) + return $ responseLBS status200 [jsonH] $ cs body + + ([table], "OPTIONS") -> do + let t = QualifiedTable schema (cs table) + cols <- columns conn t + pkey <- map cs <$> primaryKeyColumns conn t + return $ responseLBS status200 [jsonH, allOrigins] + $ encode (TableOptions cols pkey) + + ([table], "GET") -> do + if range == Just emptyRange + then return $ responseLBS status416 [] "HTTP Range error" + else do + let qt = QualifiedTable schema table + let select = + ("select ",[]) <> ( + parentheticT + $ whereT qq $ countRows qt + ) <> commaq <> ( + asJsonWithCount + $ limitT range + $ orderT (orderParse qq) + $ whereT qq + $ selectStar qt + ) + r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn + let canonical = urlEncodeVars $ sort $ + map (join (***) cs) $ + parseSimpleQuery $ + rawQueryString req + return $ addHeaders [ + ("Content-Location", + "/" <> cs table <> if null canonical then "" else "?" <> cs canonical + )] r + + (_, _) -> + return $ responseLBS status404 [] "" + + where + path = pathInfo req + verb = requestMethod req + qq = queryString req + hdrs = requestHeaders req + schema = requestedSchema hdrs + range = rangeRequested hdrs + allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + + +requestedSchema :: RequestHeaders -> ByteString +requestedSchema hdrs = + case verStr of + Just [[_, ver]] -> ver + _ -> "1" + + where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String + accept = lookup hAccept hdrs :: Maybe ByteString + verStr = (=~ verRegex) <$> accept :: Maybe [[ByteString]] + +parsePayload :: FromJSON j => Request -> IO (Either String j) +parsePayload = fmap eitherDecode . strictRequestBody + +jsonH :: Header +jsonH = (hContentType, "application/json") + + +data TableOptions = TableOptions { + tblOptcolumns :: [Column] +, tblOptpkey :: [Text] +} + +instance ToJSON TableOptions where + toJSON t = object [ + "columns" .= tblOptcolumns t + , "pkey" .= tblOptpkey t ] + +-- jsonBodyAction :: Request -> (SqlRow -> IO Response) -> IO Response +-- jsonBodyAction req handler = do +-- parse <- jsonBody req +-- case parse of +-- Left err -> return $ responseLBS status400 [jsonContentType] json +-- where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] +-- Right body -> handler body + + +-- filterByKeys :: Ord a => Map a b -> [a] -> Map a b +-- filterByKeys m keys = +-- if null keys then m else +-- m `intersection` fromList (zip keys $ repeat undefined) + +-- app :: Connection -> Application +-- app conn req respond = +-- respond =<< case (path, verb) of +-- ([], _) -> +-- responseLBS status200 [jsonContentType] <$> printTables ver conn + +-- (["dbapi", "users"], "POST") -> do +-- body <- strictRequestBody req +-- let parse = JSON.eitherDecode body + +-- case parse of +-- Left err -> return $ responseLBS status400 [jsonContentType] json +-- where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] +-- Right u -> do +-- addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) conn +-- return $ responseLBS status201 +-- [ jsonContentType +-- , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) +-- ] "" + +-- ([table], "OPTIONS") -> +-- responseLBS status200 [jsonContentType, allOrigins] <$> +-- printColumns ver (cs table) conn + +-- ([table], "GET") -> +-- if range == Just emptyRange +-- then return $ responseLBS status416 [] "HTTP Range error" +-- else do +-- r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn +-- let canonical = urlEncodeVars $ sort $ +-- map (join (***) cs) $ +-- parseSimpleQuery $ +-- rawQueryString req +-- return $ addHeaders [ +-- ("Content-Location", +-- "/" <> cs table <> if null canonical then "" else "?" <> cs canonical +-- )] r + +-- ([table], "POST") -> +-- jsonBodyAction req (\row -> do +-- allvals <- insert ver table row conn +-- keys <- map cs <$> primaryKeyColumns ver (cs table) conn +-- let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys +-- return $ responseLBS status201 +-- [ jsonContentType +-- , (hLocation, "/" <> cs table <> "?" <> cs params) +-- ] "" +-- ) + +-- ([table], "PUT") -> +-- jsonBodyAction req (\row -> do +-- keys <- primaryKeyColumns ver (cs table) conn +-- let specifiedKeys = map (cs . fst) qq +-- if S.fromList keys /= S.fromList specifiedKeys +-- then return $ responseLBS status405 [] +-- "You must speficy all and only primary keys as params" +-- else +-- if isJust cRange +-- then return $ responseLBS status400 [] +-- "Content-Range is not allowed in PUT request" +-- else do +-- cols <- columns ver (cs table) conn +-- let colNames = S.fromList $ map (cs . colName) cols +-- let specifiedCols = S.fromList $ map fst $ getRow row +-- if colNames == specifiedCols then do +-- _ <- upsert ver table row qq conn +-- return $ responseLBS status204 [ jsonContentType ] "" + +-- else return $ if S.null colNames then responseLBS status404 [] "" +-- else responseLBS status400 [] +-- "You must specify all columns in PUT request" +-- ) + +-- ([table], "PATCH") -> +-- jsonBodyAction req (\row -> do +-- _ <- update ver table row qq conn +-- return $ responseLBS status204 [ jsonContentType ] "" +-- ) + +-- (_, _) -> +-- return $ responseLBS status404 [] "" + +-- where +-- path = pathInfo req +-- verb = requestMethod req +-- qq = queryString req +-- hdrs = requestHeaders req +-- ver = fromMaybe "1" $ requestedVersion hdrs +-- range = requestedRange hdrs +-- cRange = requestedContentRange hdrs +-- allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + +-- defaultCorsPolicy :: CorsResourcePolicy +-- defaultCorsPolicy = CorsResourcePolicy Nothing +-- ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing +-- (Just $ 60*60*24) False False True + +-- corsPolicy :: Request -> Maybe CorsResourcePolicy +-- corsPolicy req = case lookup "origin" headers of +-- Just origin -> Just defaultCorsPolicy { +-- corsOrigins = Just ([origin], True) +-- , corsRequestHeaders = "Authentication":accHeaders +-- } +-- Nothing -> Nothing +-- where +-- headers = requestHeaders req +-- accHeaders = case lookup "access-control-request-headers" headers of +-- Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs +-- Nothing -> [] + + +-- respondWithRangedResult :: RangedResult -> Response +-- respondWithRangedResult rr = +-- responseLBS status [ +-- jsonContentType, +-- ("Content-Range", +-- if total == 0 || from > total +-- then "*/" <> cs (show total) +-- else cs (show from) <> "-" +-- <> cs (show to) <> "/" +-- <> cs (show total) +-- ) +-- ] (rrBody rr) + +-- where +-- from = rrFrom rr +-- to = rrTo rr +-- total = rrTotal rr +-- status +-- | from > total = status416 +-- | (1 + to - from) < total = status206 +-- | otherwise = status200 + + +-- addHeaders :: ResponseHeaders -> Response -> Response +-- addHeaders hdrs (ResponseFile s headers fp m) = +-- ResponseFile s (headers ++ hdrs) fp m +-- addHeaders hdrs (ResponseBuilder s headers b) = +-- ResponseBuilder s (headers ++ hdrs) b +-- addHeaders hdrs (ResponseStream s headers b) = +-- ResponseStream s (headers ++ hdrs) b +-- addHeaders hdrs (ResponseRaw s resp) = +-- ResponseRaw s (addHeaders hdrs resp) diff --git a/src/Auth.hs b/src/Auth.hs index bf75ff20b..ed7410c8a 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -1,6 +1,9 @@ module Auth where +import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as BS +import Control.Monad (mzero) +import Control.Applicative ( (<*>), (<$>) ) import Crypto.BCrypt import Database.PostgreSQL.Simple import GHC.Int @@ -11,6 +14,13 @@ data AuthUser = AuthUser { , userRole :: String } +instance JSON.FromJSON AuthUser where + parseJSON (JSON.Object v) = AuthUser <$> + v JSON..: "id" <*> + v JSON..: "pass" <*> + v JSON..: "role" + parseJSON _ = mzero + type DbRole = BS.ByteString data LoginAttempt = diff --git a/src/Dbapi.hs b/src/Dbapi.hs deleted file mode 100644 index c05d0872a..000000000 --- a/src/Dbapi.hs +++ /dev/null @@ -1,236 +0,0 @@ --- {{{ Imports -module Dbapi where - -import Types (SqlRow, getRow) - -import Control.Monad (join, mzero) -import Control.Arrow ((***)) -import Control.Applicative -import Options.Applicative hiding (columns) - -import Data.Maybe (fromMaybe, isJust) -import Text.Regex.TDFA ((=~)) -import Data.Map (intersection, fromList, toList, Map) -import Data.List (sort) -import qualified Data.Set as S -import Data.Convertible.Base (convert) -import Data.Text (strip, Text) - -import Network.HTTP.Types.Status -import Network.HTTP.Types.Header -import Network.HTTP.Types.URI - -import Network.HTTP.Base (urlEncodeVars) - -import Network.Wai -import Network.Wai.Internal -import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) - -import qualified Data.ByteString.Char8 as BS -import Data.String.Conversions (cs) -import qualified Data.CaseInsensitive as CI - -import PgStructure (printTables, printColumns, primaryKeyColumns, - columns, Column(colName)) - -import qualified Data.Aeson as JSON - -import PgQuery -import RangeQuery -import Data.Ranged.Ranges (emptyRange) - --- }}} - -data AppConfig = AppConfig { - configDbUri :: String - , configPort :: Int - , configAnonRole :: String - , configSecure :: Bool - , configPool :: Int - } - -data AuthUser = AuthUser { - userId :: String - , userPass :: String - , userRole :: String - } - -instance JSON.FromJSON AuthUser where - parseJSON (JSON.Object v) = AuthUser <$> - v JSON..: "id" <*> - v JSON..: "pass" <*> - v JSON..: "role" - parseJSON _ = mzero - -jsonContentType :: (HeaderName, BS.ByteString) -jsonContentType = (hContentType, "application/json") - -jsonBodyAction :: Request -> (SqlRow -> IO Response) -> IO Response -jsonBodyAction req handler = do - parse <- jsonBody req - case parse of - Left err -> return $ responseLBS status400 [jsonContentType] json - where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] - Right body -> handler body - -jsonBody :: Request -> IO (Either String SqlRow) -jsonBody = fmap JSON.eitherDecode . strictRequestBody - -filterByKeys :: Ord a => Map a b -> [a] -> Map a b -filterByKeys m keys = - if null keys then m else - m `intersection` fromList (zip keys $ repeat undefined) - -app :: Connection -> Application -app conn req respond = - respond =<< case (path, verb) of - ([], _) -> - responseLBS status200 [jsonContentType] <$> printTables ver conn - - (["dbapi", "users"], "POST") -> do - body <- strictRequestBody req - let parse = JSON.eitherDecode body - - case parse of - Left err -> return $ responseLBS status400 [jsonContentType] json - where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] - Right u -> do - addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) conn - return $ responseLBS status201 - [ jsonContentType - , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) - ] "" - - ([table], "OPTIONS") -> - responseLBS status200 [jsonContentType, allOrigins] <$> - printColumns ver (cs table) conn - - ([table], "GET") -> - if range == Just emptyRange - then return $ responseLBS status416 [] "HTTP Range error" - else do - r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn - let canonical = urlEncodeVars $ sort $ - map (join (***) cs) $ - parseSimpleQuery $ - rawQueryString req - return $ addHeaders [ - ("Content-Location", - "/" <> cs table <> if null canonical then "" else "?" <> cs canonical - )] r - - ([table], "POST") -> - jsonBodyAction req (\row -> do - allvals <- insert ver table row conn - keys <- map cs <$> primaryKeyColumns ver (cs table) conn - let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys - return $ responseLBS status201 - [ jsonContentType - , (hLocation, "/" <> cs table <> "?" <> cs params) - ] "" - ) - - ([table], "PUT") -> - jsonBodyAction req (\row -> do - keys <- primaryKeyColumns ver (cs table) conn - let specifiedKeys = map (cs . fst) qq - if S.fromList keys /= S.fromList specifiedKeys - then return $ responseLBS status405 [] - "You must speficy all and only primary keys as params" - else - if isJust cRange - then return $ responseLBS status400 [] - "Content-Range is not allowed in PUT request" - else do - cols <- columns ver (cs table) conn - let colNames = S.fromList $ map (cs . colName) cols - let specifiedCols = S.fromList $ map fst $ getRow row - if colNames == specifiedCols then do - _ <- upsert ver table row qq conn - return $ responseLBS status204 [ jsonContentType ] "" - - else return $ if S.null colNames then responseLBS status404 [] "" - else responseLBS status400 [] - "You must specify all columns in PUT request" - ) - - ([table], "PATCH") -> - jsonBodyAction req (\row -> do - _ <- update ver table row qq conn - return $ responseLBS status204 [ jsonContentType ] "" - ) - - (_, _) -> - return $ responseLBS status404 [] "" - - where - path = pathInfo req - verb = requestMethod req - qq = queryString req - hdrs = requestHeaders req - ver = fromMaybe "1" $ requestedVersion hdrs - range = requestedRange hdrs - cRange = requestedContentRange hdrs - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - -defaultCorsPolicy :: CorsResourcePolicy -defaultCorsPolicy = CorsResourcePolicy Nothing - ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing - (Just $ 60*60*24) False False True - -corsPolicy :: Request -> Maybe CorsResourcePolicy -corsPolicy req = case lookup "origin" headers of - Just origin -> Just defaultCorsPolicy { - corsOrigins = Just ([origin], True) - , corsRequestHeaders = "Authentication":accHeaders - } - Nothing -> Nothing - where - headers = requestHeaders req - accHeaders = case lookup "access-control-request-headers" headers of - Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs - Nothing -> [] - - -respondWithRangedResult :: RangedResult -> Response -respondWithRangedResult rr = - responseLBS status [ - jsonContentType, - ("Content-Range", - if total == 0 || from > total - then "*/" <> cs (show total) - else cs (show from) <> "-" - <> cs (show to) <> "/" - <> cs (show total) - ) - ] (rrBody rr) - - where - from = rrFrom rr - to = rrTo rr - total = rrTotal rr - status - | from > total = status416 - | (1 + to - from) < total = status206 - | otherwise = status200 - -requestedVersion :: RequestHeaders -> Maybe Text -requestedVersion hdrs = - case verStr of - Just [[_, ver]] -> Just ver - _ -> Nothing - - where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String - accept = cs <$> lookup hAccept hdrs :: Maybe Text - verStr = (=~ verRegex) <$> accept :: Maybe [[Text]] - - -addHeaders :: ResponseHeaders -> Response -> Response -addHeaders hdrs (ResponseFile s headers fp m) = - ResponseFile s (headers ++ hdrs) fp m -addHeaders hdrs (ResponseBuilder s headers b) = - ResponseBuilder s (headers ++ hdrs) b -addHeaders hdrs (ResponseStream s headers b) = - ResponseStream s (headers ++ hdrs) b -addHeaders hdrs (ResponseRaw s resp) = - ResponseRaw s (addHeaders hdrs resp) diff --git a/src/Main.hs b/src/Main.hs index 2ae275da5..bc12aa7f3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,7 +2,7 @@ module Main where import Paths_dbapi (version) -import Dbapi +import App import Middleware (inTransaction, authenticated, withSavepoint, clientErrors, redirectInsecure, withDBConnection, Environment(..)) import Network.Wai.Handler.Warp hiding (Connection) @@ -19,6 +19,14 @@ import Data.Pool(createPool, destroyAllResources) import Data.List (intercalate) import Data.Version (versionBranch) +data AppConfig = AppConfig { + configDbUri :: String + , configPort :: Int + , configAnonRole :: String + , configSecure :: Bool + , configPool :: Int + } + argParser :: Parser AppConfig argParser = AppConfig <$> strOption (long "db" <> short 'd' <> metavar "URI" diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 41e6a1622..87b79653f 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,13 +1,4 @@ -module PgQuery ( - CompleteQuery -, QualifiedTable(..) -, limitT -, whereT -, orderT -, countRows -, asJsonWithCount -, orderParse -) where +module PgQuery where import RangeQuery import Database.PostgreSQL.Simple @@ -64,6 +55,10 @@ orderT ts q = [EscapeIdentifier (otTerm t), Plain (fromByteString $ otDirection t)] ) +parentheticT :: CompleteQueryT +parentheticT (sql, params) = + (" (" <> sql <> ") ", params) + countRows :: QualifiedTable -> CompleteQuery countRows t = ("select count(1) from ?.?", @@ -75,6 +70,11 @@ asJsonWithCount (sql, params) = ( , params ) +selectStar :: QualifiedTable -> CompleteQuery +selectStar t = + ("select count(1) from ?.?", + [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) + wherePred :: Net.QueryItem -> CompleteQuery wherePred (col, predicate) = (" ? ? ? ", [EscapeIdentifier col, Plain op, toField value]) diff --git a/src/PgStructure.hs b/src/PgStructure.hs index 544ed833f..f2e3cbf20 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -4,17 +4,16 @@ module PgStructure where import PgQuery (QualifiedTable(..)) import Data.Functor ( (<$>) ) import Data.Text hiding (foldl, map, zipWith, concat) +import Data.Aeson import Control.Applicative ( (<*>) ) import qualified Data.List as L -import qualified Data.Aeson as JSON import qualified Data.Map as Map import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.SqlQQ import Database.PostgreSQL.Simple.FromRow -import Data.Aeson ((.=)) foreignKeys :: Connection -> QualifiedTable -> IO (Map.Map Text ForeignKey) foreignKeys c table = do @@ -122,12 +121,6 @@ instance FromRow Column where vanishNull :: [a] -> Maybe [a] vanishNull xs = if L.null xs then Nothing else Just xs -instance JSON.ToJSON Table where - toJSON v = JSON.object [ - "schema" .= tableSchema v - , "name" .= tableName v - , "insertable" .= tableInsertable v ] - toBool :: Text -> Bool toBool = (== "YES") @@ -135,9 +128,6 @@ data ForeignKey = ForeignKey { fkTable::Text, fkCol::Text } deriving (Eq, Show) -instance JSON.ToJSON ForeignKey where - toJSON fk = JSON.object ["table".=fkTable fk, "column".=fkCol fk] - data Column = Column { colSchema :: Text , colTable :: Text @@ -153,8 +143,8 @@ data Column = Column { , colFK :: Maybe ForeignKey } deriving (Show) -instance JSON.ToJSON Column where - toJSON c = JSON.object [ +instance ToJSON Column where + toJSON c = object [ "schema" .= colSchema c , "name" .= colName c , "position" .= colPosition c @@ -166,3 +156,12 @@ instance JSON.ToJSON Column where , "references".= colFK c , "default" .= colDefault c , "enum" .= colEnum c ] + +instance ToJSON ForeignKey where + toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk] + +instance ToJSON Table where + toJSON v = object [ + "schema" .= tableSchema v + , "name" .= tableName v + , "insertable" .= tableInsertable v ] From b5f054d9766d13680c88ca164f808c4aee25d862 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Tue, 11 Nov 2014 19:39:31 -0800 Subject: [PATCH 08/45] WIP: GET route --- src/App.hs | 82 ++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 55 insertions(+), 27 deletions(-) diff --git a/src/App.hs b/src/App.hs index 6c525aad6..28cfe4fd3 100644 --- a/src/App.hs +++ b/src/App.hs @@ -2,24 +2,25 @@ module App where -- import Types (SqlRow, getRow) -import Control.Monad (join, mzero) +import Control.Monad (join) import Data.Monoid ( (<>) ) --- import Control.Arrow ((***)) +import Control.Arrow ((***)) import Control.Applicative -- import Options.Applicative hiding (columns) import Data.Text hiding (map) --- import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (listToMaybe, fromMaybe) import Text.Regex.TDFA ((=~)) +import Data.Ord (comparing) -- import Data.Map (intersection, fromList, toList, Map) --- import Data.List (sort) +import Data.List (sortBy) -- import qualified Data.Set as S -- import Data.Convertible.Base (convert) -- import Data.Text (strip, Text) import Network.HTTP.Types.Status import Network.HTTP.Types.Header --- import Network.HTTP.Types.URI +import Network.HTTP.Types.URI (parseSimpleQuery) import Network.HTTP.Base (urlEncodeVars) @@ -46,7 +47,7 @@ app :: Connection -> Application app conn req respond = respond =<< case (path, verb) of ([], _) -> do - body <- encode <$> (tables conn $ cs schema) + body <- encode <$> tables conn (cs schema) return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do @@ -56,31 +57,42 @@ app conn req respond = return $ responseLBS status200 [jsonH, allOrigins] $ encode (TableOptions cols pkey) - ([table], "GET") -> do + ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else do - let qt = QualifiedTable schema table + let qt = QualifiedTable schema (cs table) let select = - ("select ",[]) <> ( - parentheticT - $ whereT qq $ countRows qt - ) <> commaq <> ( - asJsonWithCount - $ limitT range - $ orderT (orderParse qq) - $ whereT qq - $ selectStar qt - ) - r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn - let canonical = urlEncodeVars $ sort $ - map (join (***) cs) $ - parseSimpleQuery $ - rawQueryString req - return $ addHeaders [ - ("Content-Location", - "/" <> cs table <> if null canonical then "" else "?" <> cs canonical - )] r + ("select ",[]) <> + parentheticT ( + whereT qq $ countRows qt + ) <> commaq <> ( + asJsonWithCount + . limitT range + . orderT (orderParse qq) + . whereT qq + $ selectStar qt + ) + + row <- listToMaybe <$> uncurry (query conn) select + let (tableTotal, queryTotal, body) = + fromMaybe (0, 0, "" :: ByteString) row + from = fromMaybe 0 $ rangeOffset <$> range + to = from+queryTotal + contentRange = contentRangeH from to tableTotal + status = rangeStatus from to tableTotal + canonical = urlEncodeVars + . sortBy (comparing fst) + . map (join (***) cs) + . parseSimpleQuery + $ rawQueryString req + + return $ responseLBS status + [jsonH, contentRange, + ("Content-Location", + "/" <> cs table <> if Prelude.null canonical then "" else "?" <> cs canonical + ) + ] (cs body) (_, _) -> return $ responseLBS status404 [] "" @@ -95,6 +107,22 @@ app conn req respond = allOrigins = ("Access-Control-Allow-Origin", "*") :: Header +rangeStatus :: Int -> Int -> Int -> Status +rangeStatus from to total + | from > total = status416 + | (1 + to - from) < total = status206 + | otherwise = status200 + +contentRangeH :: Int -> Int -> Int -> Header +contentRangeH from to total = + ("Content-Range", + if total == 0 || from > total + then "*/" <> cs (show total) + else cs (show from) <> "-" + <> cs (show to) <> "/" + <> cs (show total) + ) + requestedSchema :: RequestHeaders -> ByteString requestedSchema hdrs = case verStr of From 8894400f5ce38c0fda5b47f58d74f69ed72b7e8c Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Tue, 11 Nov 2014 22:00:40 -0800 Subject: [PATCH 09/45] Add POST handler --- src/App.hs | 72 ++++++++++++++++++++++++-------------------------- src/PgQuery.hs | 17 ++++++++++++ 2 files changed, 51 insertions(+), 38 deletions(-) diff --git a/src/App.hs b/src/App.hs index 28cfe4fd3..4bda3dc6d 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,4 +1,4 @@ -module App where +module App (app) where -- import Types (SqlRow, getRow) @@ -12,6 +12,7 @@ import Data.Text hiding (map) import Data.Maybe (listToMaybe, fromMaybe) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) +import Data.HashMap.Strict (keys, elems, filterWithKey, toList) -- import Data.Map (intersection, fromList, toList, Map) import Data.List (sortBy) -- import qualified Data.Set as S @@ -28,7 +29,7 @@ import Network.Wai -- import Network.Wai.Internal -- import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) -import Data.ByteString.Char8 hiding (zip, map) +import Data.ByteString.Char8 hiding (zip, map, elem) import Data.String.Conversions (cs) -- import qualified Data.CaseInsensitive as CI @@ -73,7 +74,6 @@ app conn req respond = . whereT qq $ selectStar qt ) - row <- listToMaybe <$> uncurry (query conn) select let (tableTotal, queryTotal, body) = fromMaybe (0, 0, "" :: ByteString) row @@ -86,7 +86,6 @@ app conn req respond = . map (join (***) cs) . parseSimpleQuery $ rawQueryString req - return $ responseLBS status [jsonH, contentRange, ("Content-Location", @@ -94,6 +93,22 @@ app conn req respond = ) ] (cs body) + ([table], "POST") -> + handleJsonObj req (\obj -> do + let qt = QualifiedTable schema (cs table) + _ <- uncurry (execute conn) + $ insertInto qt (map cs $ keys obj) (elems obj) + primaryKeys <- map cs <$> primaryKeyColumns conn qt + let primaries = filterWithKey (const . (`elem` primaryKeys)) obj + let params = urlEncodeVars + $ map (\t -> (cs $ fst t, "eq." <> cs (encode $ snd t))) + $ toList primaries + return $ responseLBS status201 + [ jsonH + , (hLocation, "/" <> cs table <> "?" <> cs params) + ] "" + ) + (_, _) -> return $ responseLBS status404 [] "" @@ -133,12 +148,24 @@ requestedSchema hdrs = accept = lookup hAccept hdrs :: Maybe ByteString verStr = (=~ verRegex) <$> accept :: Maybe [[ByteString]] -parsePayload :: FromJSON j => Request -> IO (Either String j) -parsePayload = fmap eitherDecode . strictRequestBody - jsonH :: Header jsonH = (hContentType, "application/json") +handleJsonObj :: Request -> (Object -> IO Response) -> IO Response +handleJsonObj req handler = do + parse <- fmap eitherDecode . strictRequestBody $ req + case parse of + Left err -> + return $ responseLBS status400 [jsonH] jErr + where + jErr = encode . object $ + [("error", String $ "Failed to parse JSON payload. " <> cs err)] + Right (Object o) -> handler o + Right _ -> + return $ responseLBS status400 [jsonH] jErr + where + jErr = encode . object $ + [("error", String "Expecting a JSON object")] data TableOptions = TableOptions { tblOptcolumns :: [Column] @@ -150,19 +177,6 @@ instance ToJSON TableOptions where "columns" .= tblOptcolumns t , "pkey" .= tblOptpkey t ] --- jsonBodyAction :: Request -> (SqlRow -> IO Response) -> IO Response --- jsonBodyAction req handler = do --- parse <- jsonBody req --- case parse of --- Left err -> return $ responseLBS status400 [jsonContentType] json --- where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] --- Right body -> handler body - - --- filterByKeys :: Ord a => Map a b -> [a] -> Map a b --- filterByKeys m keys = --- if null keys then m else --- m `intersection` fromList (zip keys $ repeat undefined) -- app :: Connection -> Application -- app conn req respond = @@ -184,24 +198,6 @@ instance ToJSON TableOptions where -- , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) -- ] "" --- ([table], "OPTIONS") -> --- responseLBS status200 [jsonContentType, allOrigins] <$> --- printColumns ver (cs table) conn - --- ([table], "GET") -> --- if range == Just emptyRange --- then return $ responseLBS status416 [] "HTTP Range error" --- else do --- r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn --- let canonical = urlEncodeVars $ sort $ --- map (join (***) cs) $ --- parseSimpleQuery $ --- rawQueryString req --- return $ addHeaders [ --- ("Content-Location", --- "/" <> cs table <> if null canonical then "" else "?" <> cs canonical --- )] r - -- ([table], "POST") -> -- jsonBodyAction req (\row -> do -- allvals <- insert ver table row conn diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 87b79653f..e62e52e92 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -3,6 +3,7 @@ module PgQuery where import RangeQuery import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.Types (Query(..)) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Search (split) import qualified Network.HTTP.Types.URI as Net @@ -12,6 +13,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Functor ( (<$>) ) import Control.Monad (join) import Data.String.Conversions (cs) +import Data.Aeson.Types (Value) import qualified Data.List as L type CompleteQuery = (Query, [Action]) @@ -75,6 +77,21 @@ selectStar t = ("select count(1) from ?.?", [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) +insertInto :: QualifiedTable -> [BS.ByteString] -> [Value] -> + CompleteQuery +insertInto t [] _ = + ("insert into ?.? default values returning *", + [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) +insertInto t cols vals = + ("insert into ?.? (" <> + Query (BS.intercalate ", " (map (const "?") cols)) <> + ") values (" <> + Query (BS.intercalate ", " (map (const "?") vals)) <> + ") returning *" + , [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)] + ++ map EscapeIdentifier cols ++ map toField vals + ) + wherePred :: Net.QueryItem -> CompleteQuery wherePred (col, predicate) = (" ? ? ? ", [EscapeIdentifier col, Plain op, toField value]) From 361cffc283ed9a61dc90b20658a0a17c71c7056f Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 09:07:24 -0800 Subject: [PATCH 10/45] Add PUT handler --- src/App.hs | 64 ++++++++++++++++++++------------------------------ src/PgQuery.hs | 18 ++++++++++++++ 2 files changed, 44 insertions(+), 38 deletions(-) diff --git a/src/App.hs b/src/App.hs index 4bda3dc6d..6b01eaf6d 100644 --- a/src/App.hs +++ b/src/App.hs @@ -15,7 +15,7 @@ import Data.Ord (comparing) import Data.HashMap.Strict (keys, elems, filterWithKey, toList) -- import Data.Map (intersection, fromList, toList, Map) import Data.List (sortBy) --- import qualified Data.Set as S +import qualified Data.Set as S -- import Data.Convertible.Base (convert) -- import Data.Text (strip, Text) @@ -33,9 +33,6 @@ import Data.ByteString.Char8 hiding (zip, map, elem) import Data.String.Conversions (cs) -- import qualified Data.CaseInsensitive as CI --- import PgStructure (printTables, printColumns, primaryKeyColumns, --- columns, Column(colName)) - import Data.Aeson import Database.PostgreSQL.Simple @@ -109,6 +106,31 @@ app conn req respond = ] "" ) + ([table], "PUT") -> + handleJsonObj req (\obj -> do + let qt = QualifiedTable schema (cs table) + primaryKeys <- primaryKeyColumns conn qt + let specifiedKeys = map (cs . fst) qq + if S.fromList primaryKeys /= S.fromList specifiedKeys + then return $ responseLBS status405 [] + "You must speficy all and only primary keys as params" + else do + tableCols <- map (cs . colName) <$> columns conn qt + let cols = map cs $ keys obj + if S.fromList tableCols == S.fromList cols then do + let vals = elems obj + let upsert = + aIffNotBT (whereT qq $ update qt cols vals) + (insertInto qt cols vals) + _ <- uncurry (execute conn) upsert + return $ responseLBS status204 [ jsonH ] "" + + else return $ if Prelude.null tableCols + then responseLBS status404 [] "" + else responseLBS status400 [] + "You must specify all columns in PUT request" + ) + (_, _) -> return $ responseLBS status404 [] "" @@ -198,40 +220,6 @@ instance ToJSON TableOptions where -- , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) -- ] "" --- ([table], "POST") -> --- jsonBodyAction req (\row -> do --- allvals <- insert ver table row conn --- keys <- map cs <$> primaryKeyColumns ver (cs table) conn --- let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys --- return $ responseLBS status201 --- [ jsonContentType --- , (hLocation, "/" <> cs table <> "?" <> cs params) --- ] "" --- ) - --- ([table], "PUT") -> --- jsonBodyAction req (\row -> do --- keys <- primaryKeyColumns ver (cs table) conn --- let specifiedKeys = map (cs . fst) qq --- if S.fromList keys /= S.fromList specifiedKeys --- then return $ responseLBS status405 [] --- "You must speficy all and only primary keys as params" --- else --- if isJust cRange --- then return $ responseLBS status400 [] --- "Content-Range is not allowed in PUT request" --- else do --- cols <- columns ver (cs table) conn --- let colNames = S.fromList $ map (cs . colName) cols --- let specifiedCols = S.fromList $ map fst $ getRow row --- if colNames == specifiedCols then do --- _ <- upsert ver table row qq conn --- return $ responseLBS status204 [ jsonContentType ] "" - --- else return $ if S.null colNames then responseLBS status404 [] "" --- else responseLBS status400 [] --- "You must specify all columns in PUT request" --- ) -- ([table], "PATCH") -> -- jsonBodyAction req (\row -> do diff --git a/src/PgQuery.hs b/src/PgQuery.hs index e62e52e92..582ac1d77 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -61,6 +61,13 @@ parentheticT :: CompleteQueryT parentheticT (sql, params) = (" (" <> sql <> ") ", params) +aIffNotBT :: CompleteQuery -> CompleteQueryT +aIffNotBT (aq, ap) (bq, bp) = + ("WITH aaa AS (" <> aq <> " returning *) " <> + bq <> "WHERE NOT EXISTS (SELECT * FROM aaa)" + , ap ++ bp + ) + countRows :: QualifiedTable -> CompleteQuery countRows t = ("select count(1) from ?.?", @@ -92,6 +99,17 @@ insertInto t cols vals = ++ map EscapeIdentifier cols ++ map toField vals ) +update :: QualifiedTable -> [BS.ByteString] -> [Value] -> + CompleteQuery +update t cols vals = + ("update ?.? set (" <> + Query (BS.intercalate ", " (map (const "?") cols)) <> + ") = (" <> + Query (BS.intercalate ", " (map (const "?") vals)) <> ")" + , [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)] + ++ map EscapeIdentifier cols ++ map toField vals + ) + wherePred :: Net.QueryItem -> CompleteQuery wherePred (col, predicate) = (" ? ? ? ", [EscapeIdentifier col, Plain op, toField value]) From 8c073cedc64cba1f96bc1c9cb7e2808155df4150 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 09:24:05 -0800 Subject: [PATCH 11/45] Add PATCH handler --- src/App.hs | 15 +++++++++------ src/PgQuery.hs | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/App.hs b/src/App.hs index 6b01eaf6d..b1199e1f3 100644 --- a/src/App.hs +++ b/src/App.hs @@ -131,6 +131,15 @@ app conn req respond = "You must specify all columns in PUT request" ) + ([table], "PATCH") -> + handleJsonObj req (\obj -> do + let qt = QualifiedTable schema (cs table) + _ <- uncurry (execute conn) + $ whereT qq + $ update qt (map cs $ keys obj) (elems obj) + return $ responseLBS status204 [ jsonH ] "" + ) + (_, _) -> return $ responseLBS status404 [] "" @@ -221,12 +230,6 @@ instance ToJSON TableOptions where -- ] "" --- ([table], "PATCH") -> --- jsonBodyAction req (\row -> do --- _ <- update ver table row qq conn --- return $ responseLBS status204 [ jsonContentType ] "" --- ) - -- (_, _) -> -- return $ responseLBS status404 [] "" diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 582ac1d77..1e0de2d66 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -39,7 +39,7 @@ whereT :: Net.Query -> CompleteQueryT whereT params q = if L.null params then q - else q <> conjunction + else q <> (" where ",[]) <> conjunction where cols = [ col | col <- params, fst col `notElem` ["order"] ] conjunction = mconcat $ L.intersperse andq (map wherePred cols) From 61174cfa172ea806869259e6dd8b1ba0fb2de582 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 09:55:25 -0800 Subject: [PATCH 12/45] Add user creation route --- src/App.hs | 92 +++++++++++++------------------------------------- src/PgQuery.hs | 4 +-- 2 files changed, 26 insertions(+), 70 deletions(-) diff --git a/src/App.hs b/src/App.hs index b1199e1f3..3fa152349 100644 --- a/src/App.hs +++ b/src/App.hs @@ -12,6 +12,7 @@ import Data.Text hiding (map) import Data.Maybe (listToMaybe, fromMaybe) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) +import Data.Ranged.Ranges (emptyRange) import Data.HashMap.Strict (keys, elems, filterWithKey, toList) -- import Data.Map (intersection, fromList, toList, Map) import Data.List (sortBy) @@ -39,7 +40,7 @@ import Database.PostgreSQL.Simple import PgQuery import RangeQuery import PgStructure -import Data.Ranged.Ranges (emptyRange) +import Auth app :: Connection -> Application app conn req respond = @@ -86,12 +87,28 @@ app conn req respond = return $ responseLBS status [jsonH, contentRange, ("Content-Location", - "/" <> cs table <> if Prelude.null canonical then "" else "?" <> cs canonical + "/" <> cs table <> + if Prelude.null canonical then "" else "?" <> cs canonical ) ] (cs body) + (["dbapi", "users"], "POST") -> do + body <- strictRequestBody req + let user = decode body :: Maybe AuthUser + + case user of + Nothing -> return $ responseLBS status400 [jsonH] $ + encode . object $ [("error", String "Failed to parse user.")] + Just u -> do + _ <- addUser conn (cs $ userId u) + (cs $ userPass u) (cs $ userRole u) + return $ responseLBS status201 + [ jsonH + , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) + ] "" + ([table], "POST") -> - handleJsonObj req (\obj -> do + handleJsonObj req $ \obj -> do let qt = QualifiedTable schema (cs table) _ <- uncurry (execute conn) $ insertInto qt (map cs $ keys obj) (elems obj) @@ -104,10 +121,9 @@ app conn req respond = [ jsonH , (hLocation, "/" <> cs table <> "?" <> cs params) ] "" - ) ([table], "PUT") -> - handleJsonObj req (\obj -> do + handleJsonObj req $ \obj -> do let qt = QualifiedTable schema (cs table) primaryKeys <- primaryKeyColumns conn qt let specifiedKeys = map (cs . fst) qq @@ -119,26 +135,23 @@ app conn req respond = let cols = map cs $ keys obj if S.fromList tableCols == S.fromList cols then do let vals = elems obj - let upsert = - aIffNotBT (whereT qq $ update qt cols vals) + _ <- uncurry (execute conn) $ iffNotT + (whereT qq $ update qt cols vals) (insertInto qt cols vals) - _ <- uncurry (execute conn) upsert return $ responseLBS status204 [ jsonH ] "" else return $ if Prelude.null tableCols then responseLBS status404 [] "" else responseLBS status400 [] "You must specify all columns in PUT request" - ) ([table], "PATCH") -> - handleJsonObj req (\obj -> do + handleJsonObj req $ \obj -> do let qt = QualifiedTable schema (cs table) _ <- uncurry (execute conn) $ whereT qq $ update qt (map cs $ keys obj) (elems obj) return $ responseLBS status204 [ jsonH ] "" - ) (_, _) -> return $ responseLBS status404 [] "" @@ -209,40 +222,6 @@ instance ToJSON TableOptions where , "pkey" .= tblOptpkey t ] --- app :: Connection -> Application --- app conn req respond = --- respond =<< case (path, verb) of --- ([], _) -> --- responseLBS status200 [jsonContentType] <$> printTables ver conn - --- (["dbapi", "users"], "POST") -> do --- body <- strictRequestBody req --- let parse = JSON.eitherDecode body - --- case parse of --- Left err -> return $ responseLBS status400 [jsonContentType] json --- where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] --- Right u -> do --- addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) conn --- return $ responseLBS status201 --- [ jsonContentType --- , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) --- ] "" - - --- (_, _) -> --- return $ responseLBS status404 [] "" - --- where --- path = pathInfo req --- verb = requestMethod req --- qq = queryString req --- hdrs = requestHeaders req --- ver = fromMaybe "1" $ requestedVersion hdrs --- range = requestedRange hdrs --- cRange = requestedContentRange hdrs --- allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - -- defaultCorsPolicy :: CorsResourcePolicy -- defaultCorsPolicy = CorsResourcePolicy Nothing -- ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing @@ -262,29 +241,6 @@ instance ToJSON TableOptions where -- Nothing -> [] --- respondWithRangedResult :: RangedResult -> Response --- respondWithRangedResult rr = --- responseLBS status [ --- jsonContentType, --- ("Content-Range", --- if total == 0 || from > total --- then "*/" <> cs (show total) --- else cs (show from) <> "-" --- <> cs (show to) <> "/" --- <> cs (show total) --- ) --- ] (rrBody rr) - --- where --- from = rrFrom rr --- to = rrTo rr --- total = rrTotal rr --- status --- | from > total = status416 --- | (1 + to - from) < total = status206 --- | otherwise = status200 - - -- addHeaders :: ResponseHeaders -> Response -> Response -- addHeaders hdrs (ResponseFile s headers fp m) = -- ResponseFile s (headers ++ hdrs) fp m diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 1e0de2d66..1ac961b60 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -61,8 +61,8 @@ parentheticT :: CompleteQueryT parentheticT (sql, params) = (" (" <> sql <> ") ", params) -aIffNotBT :: CompleteQuery -> CompleteQueryT -aIffNotBT (aq, ap) (bq, bp) = +iffNotT :: CompleteQuery -> CompleteQueryT +iffNotT (aq, ap) (bq, bp) = ("WITH aaa AS (" <> aq <> " returning *) " <> bq <> "WHERE NOT EXISTS (SELECT * FROM aaa)" , ap ++ bp From f21559ea812c800eebd2e081124577e07e8412b0 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 10:03:20 -0800 Subject: [PATCH 13/45] Clean up App.hs --- src/App.hs | 46 ++-------------------------------------------- 1 file changed, 2 insertions(+), 44 deletions(-) diff --git a/src/App.hs b/src/App.hs index 3fa152349..009e6c4a2 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,12 +1,9 @@ module App (app) where --- import Types (SqlRow, getRow) - import Control.Monad (join) import Data.Monoid ( (<>) ) import Control.Arrow ((***)) import Control.Applicative --- import Options.Applicative hiding (columns) import Data.Text hiding (map) import Data.Maybe (listToMaybe, fromMaybe) @@ -14,25 +11,16 @@ import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) import Data.HashMap.Strict (keys, elems, filterWithKey, toList) --- import Data.Map (intersection, fromList, toList, Map) +import Data.ByteString.Char8 hiding (zip, map, elem) +import Data.String.Conversions (cs) import Data.List (sortBy) import qualified Data.Set as S --- import Data.Convertible.Base (convert) --- import Data.Text (strip, Text) import Network.HTTP.Types.Status import Network.HTTP.Types.Header import Network.HTTP.Types.URI (parseSimpleQuery) - import Network.HTTP.Base (urlEncodeVars) - import Network.Wai --- import Network.Wai.Internal --- import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) - -import Data.ByteString.Char8 hiding (zip, map, elem) -import Data.String.Conversions (cs) --- import qualified Data.CaseInsensitive as CI import Data.Aeson import Database.PostgreSQL.Simple @@ -220,33 +208,3 @@ instance ToJSON TableOptions where toJSON t = object [ "columns" .= tblOptcolumns t , "pkey" .= tblOptpkey t ] - - --- defaultCorsPolicy :: CorsResourcePolicy --- defaultCorsPolicy = CorsResourcePolicy Nothing --- ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing --- (Just $ 60*60*24) False False True - --- corsPolicy :: Request -> Maybe CorsResourcePolicy --- corsPolicy req = case lookup "origin" headers of --- Just origin -> Just defaultCorsPolicy { --- corsOrigins = Just ([origin], True) --- , corsRequestHeaders = "Authentication":accHeaders --- } --- Nothing -> Nothing --- where --- headers = requestHeaders req --- accHeaders = case lookup "access-control-request-headers" headers of --- Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs --- Nothing -> [] - - --- addHeaders :: ResponseHeaders -> Response -> Response --- addHeaders hdrs (ResponseFile s headers fp m) = --- ResponseFile s (headers ++ hdrs) fp m --- addHeaders hdrs (ResponseBuilder s headers b) = --- ResponseBuilder s (headers ++ hdrs) b --- addHeaders hdrs (ResponseStream s headers b) = --- ResponseStream s (headers ++ hdrs) b --- addHeaders hdrs (ResponseRaw s resp) = --- ResponseRaw s (addHeaders hdrs resp) From 0f849e9bf13de5da3dde0cf2cb6ab7a1cd8915c0 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 17:03:22 -0800 Subject: [PATCH 14/45] Move cors things to Main --- src/Main.hs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/Main.hs b/src/Main.hs index bc12aa7f3..daecf231b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -66,3 +66,22 @@ main = do where describe = progDesc "create a REST API to an existing Postgres database" prettyVersion = intercalate "." $ map show $ versionBranch version + + +defaultCorsPolicy :: CorsResourcePolicy +defaultCorsPolicy = CorsResourcePolicy Nothing + ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing + (Just $ 60*60*24) False False True + +corsPolicy :: Request -> Maybe CorsResourcePolicy +corsPolicy req = case lookup "origin" headers of + Just origin -> Just defaultCorsPolicy { + corsOrigins = Just ([origin], True) + , corsRequestHeaders = "Authentication":accHeaders + } + Nothing -> Nothing + where + headers = requestHeaders req + accHeaders = case lookup "access-control-request-headers" headers of + Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs + Nothing -> [] From 1b8f0f28294e9de0c741b3aaabbd6b8ec8cb015e Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 17:34:44 -0800 Subject: [PATCH 15/45] Main compiles. Still bugs though --- src/Main.hs | 15 ++++++++++----- src/Middleware.hs | 32 +++++++++++++++----------------- 2 files changed, 25 insertions(+), 22 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index daecf231b..886eb132e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,19 +5,24 @@ import Paths_dbapi (version) import App import Middleware (inTransaction, authenticated, withSavepoint, clientErrors, redirectInsecure, withDBConnection, Environment(..)) -import Network.Wai.Handler.Warp hiding (Connection) import Data.String.Conversions (cs) +import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString.Char8 as BS import Control.Monad (unless) import Control.Applicative import Control.Exception(bracket) import Options.Applicative hiding (columns) +import Network.Wai +import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.Gzip (gzip, def) -import Network.Wai.Middleware.Cors (cors) +import Network.Wai.Middleware.Cors (cors, CorsResourcePolicy(..)) import Network.Wai.Middleware.Static (staticPolicy, only) import Data.Pool(createPool, destroyAllResources) import Data.List (intercalate) import Data.Version (versionBranch) +import Data.Text (strip) +import Database.PostgreSQL.Simple data AppConfig = AppConfig { configDbUri :: String @@ -44,8 +49,8 @@ main :: IO () main = do conf <- execParser (info (helper <*> argParser) describe) bracket - (createPool (connectPostgreSQL' (configDbUri conf)) - disconnect 1 600 (configPool conf)) + (createPool (connectPostgreSQL $ cs (configDbUri conf)) + close 1 600 (configPool conf)) destroyAllResources (\pool -> do let port = configPort conf @@ -61,7 +66,7 @@ main = do . gzip def . cors corsPolicy . clientErrors . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) . withDBConnection pool . inTransaction Production - . authenticated (cs $ configAnonRole conf) . withSavepoint Production $ app + . authenticated (cs $ configAnonRole conf) . Middleware.withSavepoint Production $ app ) where describe = progDesc "create a REST API to an existing Postgres database" diff --git a/src/Middleware.hs b/src/Middleware.hs index 533090eae..cfeccd592 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -7,10 +7,10 @@ import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) import Data.Pool(withResource, Pool) +import Database.PostgreSQL.Simple import Data.String.Conversions(cs) import qualified Data.ByteString.Char8 as BS -import Control.Exception (finally, throw, catchJust, catch, SomeException, - bracket_) +import Control.Exception (catchJust, bracket_) import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization, hLocation) @@ -19,7 +19,7 @@ import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, rawQueryString, isSecure, requestMethod, Request) import Network.URI (URI(..), parseURI) -import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole) +import Auth (LoginAttempt(..), signInRole, setRole, resetRole) import Codec.Binary.Base64.String (decode) import Debug.Trace @@ -37,20 +37,17 @@ inTransaction :: Environment -> (Connection -> Application) -> Connection -> Application inTransaction env app conn req respond = if env == Production && safeAction req - then - app conn req respond - else - finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit") + then go + else withTransaction conn go + where go = app conn req respond withSavepoint :: Environment -> (Connection -> Application) -> Connection -> Application withSavepoint env app conn req respond = if env == Production && safeAction req - then app conn req respond - else do - runRaw conn "savepoint req_sp" - catch (app conn req respond) (\e -> let _ = (e::SomeException) in - runRaw conn "rollback to savepoint req_sp" >> throw e) + then go + else Database.PostgreSQL.Simple.withSavepoint conn go + where go = app conn req respond authenticated :: BS.ByteString -> (Connection -> Application) -> Connection -> Application @@ -73,23 +70,24 @@ authenticated anon app conn req respond = do case BS.split ' ' (cs auth) of ("Basic" : b64 : _) -> case BS.split ':' $ cs (decode $ cs b64) of - (u:p:_) -> signInRole u p conn + (u:p:_) -> signInRole conn u p _ -> return MalformedAuth _ -> return NoCredentials instance ToJSON SqlError where toJSON t = object [ "error" .= object [ - "code" .= seNativeError t - , "message" .= seErrorMsg t - , "state" .= seState t + "message" .= (cs $ sqlErrorMsg t :: String) + , "detail" .= (cs $ sqlErrorDetail t :: String) + , "state" .= (cs $ sqlState t :: String) + , "hint" .= (cs $ sqlErrorHint t :: String) ] ] clientErrors :: Application -> Application clientErrors app req respond = catchJust isPgException (app req respond) $ \err -> - respond $ if seState err == "42P01" + respond $ if sqlState err == "42P01" then responseLBS status404 [] "" else responseLBS status400 [(hContentType, "application/json")] (encode err) From f7e0386d1c31d52a8ff951d27e7376568d6f2c42 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 21:50:34 -0800 Subject: [PATCH 16/45] Fix empty results --- src/App.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/App.hs b/src/App.hs index 009e6c4a2..abeb12f39 100644 --- a/src/App.hs +++ b/src/App.hs @@ -62,7 +62,7 @@ app conn req respond = ) row <- listToMaybe <$> uncurry (query conn) select let (tableTotal, queryTotal, body) = - fromMaybe (0, 0, "" :: ByteString) row + fromMaybe (0, 0, Just "" :: Maybe ByteString) row from = fromMaybe 0 $ rangeOffset <$> range to = from+queryTotal contentRange = contentRangeH from to tableTotal @@ -78,7 +78,7 @@ app conn req respond = "/" <> cs table <> if Prelude.null canonical then "" else "?" <> cs canonical ) - ] (cs body) + ] (cs $ fromMaybe "[]" body) (["dbapi", "users"], "POST") -> do body <- strictRequestBody req From d9377fa50a1dfffb9298a88858bf85296e2826a3 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 21:52:41 -0800 Subject: [PATCH 17/45] Fix select star and json stuff --- src/PgQuery.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 1ac961b60..4a33246d2 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -30,9 +30,9 @@ data OrderTerm = OrderTerm { limitT :: Maybe NonnegRange -> CompleteQueryT limitT r q = - q <> (" LIMIT ? OFFSET ? ", [toField limit, toField offset]) + q <> (" LIMIT ? OFFSET ? ", [Plain (fromByteString limit), toField offset]) where - limit = fromMaybe "ALL" $ show . rangeLimit <$> r + limit = cs $ fromMaybe "ALL" $ show . rangeLimit <$> r offset = fromMaybe 0 $ rangeOffset <$> r whereT :: Net.Query -> CompleteQueryT @@ -75,13 +75,13 @@ countRows t = asJsonWithCount :: CompleteQueryT asJsonWithCount (sql, params) = ( - "count(t), array_to_json(array_agg(row_to_json(t))) from (" <> sql <> ") t" + "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t" , params ) selectStar :: QualifiedTable -> CompleteQuery selectStar t = - ("select count(1) from ?.?", + ("select * from ?.?", [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) insertInto :: QualifiedTable -> [BS.ByteString] -> [Value] -> From d791f3939ed6b5f7e811d6be1dc26c16542661ac Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 21:55:35 -0800 Subject: [PATCH 18/45] The Dbapi module is now App --- dbapi.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 39811709d..0865c21e5 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -36,7 +36,7 @@ executable dbapi , network-uri >= 2.6 , resource-pool, process , blaze-builder - Other-Modules: Dbapi + Other-Modules: App , PgStructure , PgQuery , RangeQuery @@ -51,7 +51,7 @@ Test-Suite spec Hs-Source-Dirs: test, src ghc-options: -Wall -W -Werror Main-Is: Main.hs - Other-Modules: Dbapi, Spec, SpecHelper + Other-Modules: App, Spec, SpecHelper Build-Depends: base, hspec2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json , postgresql-simple >= 0.4.7.0 From dd2adf4daab96af1edac6cee2e0c20f8a2a1e0e0 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 13 Nov 2014 10:24:05 -0800 Subject: [PATCH 19/45] Tests compile, run, and fail Temporarily disabled unit tests --- dbapi.cabal | 3 +- src/Config.hs | 49 ++++++++++++++++++ src/Main.hs | 51 ++----------------- test/Main.hs | 10 ++-- test/SpecHelper.hs | 30 ++++++----- test/TestTypes.hs | 30 +++++------ test/Unit/{ErrorsSpec.hs => ErrorsSpec.hx} | 0 test/Unit/{PgQuerySpec.hs => PgQuerySpec.hx} | 0 ...{PgStructureSpec.hs => PgStructureSpec.hx} | 0 test/fixtures/roles.sql | 7 ++- 10 files changed, 93 insertions(+), 87 deletions(-) create mode 100644 src/Config.hs rename test/Unit/{ErrorsSpec.hs => ErrorsSpec.hx} (100%) rename test/Unit/{PgQuerySpec.hs => PgQuerySpec.hx} (100%) rename test/Unit/{PgStructureSpec.hs => PgStructureSpec.hx} (100%) diff --git a/dbapi.cabal b/dbapi.cabal index 0865c21e5..b1ae0a2dd 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -37,6 +37,7 @@ executable dbapi , resource-pool, process , blaze-builder Other-Modules: App + , Config , PgStructure , PgQuery , RangeQuery @@ -51,7 +52,7 @@ Test-Suite spec Hs-Source-Dirs: test, src ghc-options: -Wall -W -Werror Main-Is: Main.hs - Other-Modules: App, Spec, SpecHelper + Other-Modules: App, Config, Spec, SpecHelper Build-Depends: base, hspec2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json , postgresql-simple >= 0.4.7.0 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 000000000..8930dc347 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,49 @@ +module Config where + +import Network.Wai +import Control.Applicative +import Data.Text (strip) +import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString.Char8 as BS +import Data.String.Conversions (cs) +import Options.Applicative hiding (columns) +import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) + +data AppConfig = AppConfig { + configDbUri :: String + , configPort :: Int + , configAnonRole :: String + , configSecure :: Bool + , configPool :: Int + } + +argParser :: Parser AppConfig +argParser = AppConfig + <$> strOption (long "db" <> short 'd' <> metavar "URI" + <> help "database uri to expose, e.g. postgres://user:pass@host:port/database") + <*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000 + <> help "port number on which to run HTTP server") + <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE" + <> help "postgres role to use for non-authenticated requests") + <*> switch (long "secure" <> short 's' + <> help "Redirect all requests to HTTPS") + <*> option (long "db-pool" <> metavar "NUMBER" <> value 10 + <> help "Max connections in database pool") + +defaultCorsPolicy :: CorsResourcePolicy +defaultCorsPolicy = CorsResourcePolicy Nothing + ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing + (Just $ 60*60*24) False False True + +corsPolicy :: Request -> Maybe CorsResourcePolicy +corsPolicy req = case lookup "origin" headers of + Just origin -> Just defaultCorsPolicy { + corsOrigins = Just ([origin], True) + , corsRequestHeaders = "Authentication":accHeaders + } + Nothing -> Nothing + where + headers = requestHeaders req + accHeaders = case lookup "access-control-request-headers" headers of + Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs + Nothing -> [] diff --git a/src/Main.hs b/src/Main.hs index 886eb132e..c877d3b96 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,45 +5,21 @@ import Paths_dbapi (version) import App import Middleware (inTransaction, authenticated, withSavepoint, clientErrors, redirectInsecure, withDBConnection, Environment(..)) -import Data.String.Conversions (cs) -import qualified Data.CaseInsensitive as CI -import qualified Data.ByteString.Char8 as BS import Control.Monad (unless) -import Control.Applicative import Control.Exception(bracket) -import Options.Applicative hiding (columns) -import Network.Wai +import Data.String.Conversions (cs) +import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.Gzip (gzip, def) -import Network.Wai.Middleware.Cors (cors, CorsResourcePolicy(..)) import Network.Wai.Middleware.Static (staticPolicy, only) import Data.Pool(createPool, destroyAllResources) import Data.List (intercalate) import Data.Version (versionBranch) -import Data.Text (strip) import Database.PostgreSQL.Simple +import Options.Applicative hiding (columns) -data AppConfig = AppConfig { - configDbUri :: String - , configPort :: Int - , configAnonRole :: String - , configSecure :: Bool - , configPool :: Int - } - -argParser :: Parser AppConfig -argParser = AppConfig - <$> strOption (long "db" <> short 'd' <> metavar "URI" - <> help "database uri to expose, e.g. postgres://user:pass@host:port/database") - <*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000 - <> help "port number on which to run HTTP server") - <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE" - <> help "postgres role to use for non-authenticated requests") - <*> switch (long "secure" <> short 's' - <> help "Redirect all requests to HTTPS") - <*> option (long "db-pool" <> metavar "NUMBER" <> value 10 - <> help "Max connections in database pool") +import Config (AppConfig(..), argParser, corsPolicy) main :: IO () main = do @@ -71,22 +47,3 @@ main = do where describe = progDesc "create a REST API to an existing Postgres database" prettyVersion = intercalate "." $ map show $ versionBranch version - - -defaultCorsPolicy :: CorsResourcePolicy -defaultCorsPolicy = CorsResourcePolicy Nothing - ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing - (Just $ 60*60*24) False False True - -corsPolicy :: Request -> Maybe CorsResourcePolicy -corsPolicy req = case lookup "origin" headers of - Just origin -> Just defaultCorsPolicy { - corsOrigins = Just ([origin], True) - , corsRequestHeaders = "Authentication":accHeaders - } - Nothing -> Nothing - where - headers = requestHeaders req - accHeaders = case lookup "access-control-request-headers" headers of - Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs - Nothing -> [] diff --git a/test/Main.hs b/test/Main.hs index 6a36d32da..abe226374 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,6 @@ module Main where -import Database.HDBC (runRaw, disconnect) +import Database.PostgreSQL.Simple import Test.Hspec import Spec import SpecHelper (openConnection, loadFixture) @@ -8,10 +8,10 @@ import SpecHelper (openConnection, loadFixture) main :: IO () main = do c <-openConnection - runRaw c "drop schema if exists \"1\" cascade" - runRaw c "drop schema if exists private cascade" - runRaw c "drop schema if exists dbapi cascade" + _ <- execute_ c "drop schema if exists \"1\" cascade" + _ <- execute_ c "drop schema if exists private cascade" + _ <- execute_ c "drop schema if exists dbapi cascade" loadFixture "roles" c loadFixture "schema" c - disconnect c + close c hspec spec diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 65a09bf57..ca42e9092 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -4,11 +4,12 @@ import Network.Wai import Test.Hspec import Test.Hspec.Wai -import Database.HDBC -import Database.HDBC.PostgreSQL +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.Types import Data.String.Conversions (cs) import Control.Exception.Base (bracket, finally) +import Control.Monad (void) import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization) @@ -20,8 +21,9 @@ import Network.Wai.Middleware.Cors (cors) import Middleware(clientErrors, withSavepoint, authenticated, Environment(..)) -import Dbapi (app, corsPolicy, AppConfig(..)) -import PgQuery(addUser) +import App (app) +import Config (corsPolicy, AppConfig(..)) +import Auth (addUser) isLeft :: Either a b -> Bool isLeft (Left _ ) = True @@ -31,41 +33,41 @@ cfg :: AppConfig cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10 openConnection :: IO Connection -openConnection = connectPostgreSQL' $ configDbUri cfg +openConnection = connectPostgreSQL $ cs $ configDbUri cfg withDatabaseConnection :: (Connection -> IO ()) -> IO () -withDatabaseConnection = bracket openConnection disconnect +withDatabaseConnection = bracket openConnection close loadFixture :: String -> Connection -> IO () loadFixture name conn = do sql <- readFile $ "test/fixtures/" ++ name ++ ".sql" - runRaw conn sql + void $ execute_ conn $ Query (cs sql) dbWithSchema :: ActionWith Connection -> IO () dbWithSchema action = withDatabaseConnection $ \c -> do - runRaw c "begin;" + _ <- execute_ c "begin;" action c rollback c withUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> ActionWith Connection -> ActionWith Connection withUser name pass role action conn = do - addUser name pass role conn + _ <- addUser conn name pass role finally (action conn) $ do - _ <- run conn "delete from dbapi.auth where id=?" [toSql name] - runRaw conn "commit" + _ <- execute conn "delete from dbapi.auth where id=?" $ Only name + execute_ conn "commit" withApp :: ActionWith Application -> ActionWith Connection withApp action conn = do - runRaw conn "begin;" + _ <- execute_ conn "begin;" action $ cors corsPolicy $ authenticated "dbapi_anonymous" app conn rollback conn appWithFixture :: ActionWith Application -> IO () appWithFixture action = withDatabaseConnection $ \c -> do - runRaw c "begin;" + _ <- execute_ c "begin;" action $ cors corsPolicy . clientErrors $ - (authenticated "dbapi_anonymous" . withSavepoint Test) app c + (authenticated "dbapi_anonymous" . Middleware.withSavepoint Test) app c rollback c rangeHdrs :: ByteRange -> [Header] diff --git a/test/TestTypes.hs b/test/TestTypes.hs index 95998406d..e5e02bc87 100644 --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -1,18 +1,16 @@ module TestTypes ( IncPK(..) , CompoundPK(..) -, incFromList -, compoundFromList +-- , incFromList +-- , compoundFromList ) where import qualified Data.Aeson as JSON import Data.Aeson ((.:)) -import Data.Maybe (fromJust) +-- import Data.Maybe (fromJust) import Control.Applicative ((<$>), (<*>)) import Control.Monad (mzero) -import Database.HDBC (SqlValue, fromSql) - data IncPK = IncPK { incId :: Int , incNullableStr :: Maybe String @@ -28,12 +26,12 @@ instance JSON.FromJSON IncPK where r .: "inserted_at" parseJSON _ = mzero -incFromList :: [(String, SqlValue)] -> IncPK -incFromList row = IncPK - (fromSql . fromJust $ lookup "id" row) - (fromSql . fromJust $ lookup "nullable_string" row) - (fromSql . fromJust $ lookup "non_nullable_string" row) - (fromSql . fromJust $ lookup "inserted_at" row) +-- incFromList :: [(String, SqlValue)] -> IncPK +-- incFromList row = IncPK +-- (fromSql . fromJust $ lookup "id" row) +-- (fromSql . fromJust $ lookup "nullable_string" row) +-- (fromSql . fromJust $ lookup "non_nullable_string" row) +-- (fromSql . fromJust $ lookup "inserted_at" row) data CompoundPK = CompoundPK { compoundK1 :: Int @@ -48,8 +46,8 @@ instance JSON.FromJSON CompoundPK where r .: "extra" parseJSON _ = mzero -compoundFromList :: [(String, SqlValue)] -> CompoundPK -compoundFromList row = CompoundPK - (fromSql . fromJust $ lookup "k1" row) - (fromSql . fromJust $ lookup "k2" row) - (fromSql . fromJust $ lookup "extra" row) +-- compoundFromList :: [(String, SqlValue)] -> CompoundPK +-- compoundFromList row = CompoundPK +-- (fromSql . fromJust $ lookup "k1" row) +-- (fromSql . fromJust $ lookup "k2" row) +-- (fromSql . fromJust $ lookup "extra" row) diff --git a/test/Unit/ErrorsSpec.hs b/test/Unit/ErrorsSpec.hx similarity index 100% rename from test/Unit/ErrorsSpec.hs rename to test/Unit/ErrorsSpec.hx diff --git a/test/Unit/PgQuerySpec.hs b/test/Unit/PgQuerySpec.hx similarity index 100% rename from test/Unit/PgQuerySpec.hs rename to test/Unit/PgQuerySpec.hx diff --git a/test/Unit/PgStructureSpec.hs b/test/Unit/PgStructureSpec.hx similarity index 100% rename from test/Unit/PgStructureSpec.hs rename to test/Unit/PgStructureSpec.hx diff --git a/test/fixtures/roles.sql b/test/fixtures/roles.sql index ecc1020a8..db8a90f55 100644 --- a/test/fixtures/roles.sql +++ b/test/fixtures/roles.sql @@ -11,7 +11,6 @@ BEGIN END; $$; -select pg_temp.create_role_if_not_exists('dbapi_anonymous', 'with nologin'); -select pg_temp.create_role_if_not_exists('test_default_role', 'with nologin'); - -select pg_temp.create_role_if_not_exists('dbapi_test_author', 'with nologin'); +select pg_temp.create_role_if_not_exists('dbapi_anonymous', 'with nologin') as a + , pg_temp.create_role_if_not_exists('test_default_role', 'with nologin') as b + , pg_temp.create_role_if_not_exists('dbapi_test_author', 'with nologin') into temp shh; From b74b91b1c09943aa01457d302d91c90bdbaa2ce2 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 13 Nov 2014 15:41:02 -0800 Subject: [PATCH 20/45] Interpolate json string values in queries without extra quoting --- src/PgQuery.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 4a33246d2..30659650b 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -13,7 +13,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Functor ( (<$>) ) import Control.Monad (join) import Data.String.Conversions (cs) -import Data.Aeson.Types (Value) +import Data.Aeson (Value(..), encode) import qualified Data.List as L type CompleteQuery = (Query, [Action]) @@ -96,9 +96,13 @@ insertInto t cols vals = Query (BS.intercalate ", " (map (const "?") vals)) <> ") returning *" , [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)] - ++ map EscapeIdentifier cols ++ map toField vals + ++ map EscapeIdentifier cols ++ map (Escape . rawJsonValue) vals ) +rawJsonValue :: Value -> BS.ByteString +rawJsonValue (String s) = cs s +rawJsonValue v = cs $ encode v + update :: QualifiedTable -> [BS.ByteString] -> [Value] -> CompleteQuery update t cols vals = From 8ebfbccd085a6cf3627e26e74f050952518b2104 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 14 Nov 2014 12:39:14 -0800 Subject: [PATCH 21/45] WIP: converting to Hasql --- dbapi.cabal | 4 +- src/App.hs | 2 + src/Auth.hs | 3 +- src/Main.hs | 3 +- src/PgQuery.hs | 122 ++++++++++++++++++++++++++++--------------------- 5 files changed, 79 insertions(+), 55 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index b1ae0a2dd..a86d96440 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -16,7 +16,7 @@ executable dbapi default-extensions: OverloadedStrings other-extensions: QuasiQuotes build-depends: base >=4.6 && <5 - , postgresql-simple >= 0.4.7.0 + , hasql, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 @@ -55,7 +55,7 @@ Test-Suite spec Other-Modules: App, Config, Spec, SpecHelper Build-Depends: base, hspec2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json - , postgresql-simple >= 0.4.7.0 + , hasql, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , HTTP, convertible , case-insensitive diff --git a/src/App.hs b/src/App.hs index abeb12f39..51f99c2d5 100644 --- a/src/App.hs +++ b/src/App.hs @@ -24,6 +24,8 @@ import Network.Wai import Data.Aeson import Database.PostgreSQL.Simple +import qualified Hasql as H +import qualified Hasql.Postgres as H import PgQuery import RangeQuery diff --git a/src/Auth.hs b/src/Auth.hs index ed7410c8a..be905e8fa 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -5,7 +5,8 @@ import qualified Data.ByteString.Char8 as BS import Control.Monad (mzero) import Control.Applicative ( (<*>), (<$>) ) import Crypto.BCrypt -import Database.PostgreSQL.Simple +import qualified Hasql as H +import qualified Hasql.Postgres as H import GHC.Int data AuthUser = AuthUser { diff --git a/src/Main.hs b/src/Main.hs index c877d3b96..f3294f2ef 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -16,7 +16,8 @@ import Network.Wai.Middleware.Static (staticPolicy, only) import Data.Pool(createPool, destroyAllResources) import Data.List (intercalate) import Data.Version (versionBranch) -import Database.PostgreSQL.Simple +import qualified Hasql as H +import qualified Hasql.Postgres as H import Options.Applicative hiding (columns) import Config (AppConfig(..), argParser, corsPolicy) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 30659650b..754209141 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,9 +1,12 @@ module PgQuery where import RangeQuery -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.ToField -import Database.PostgreSQL.Simple.Types (Query(..)) +import qualified Hasql as H +import qualified Hasql.Postgres as H +import qualified Hasql.Backend as H +import Data.Text hiding (map) +import Text.Regex.TDFA +import Text.Regex.TDFA.Text import qualified Data.ByteString.Char8 as BS import Data.ByteString.Search (split) import qualified Network.HTTP.Types.URI as Net @@ -16,8 +19,7 @@ import Data.String.Conversions (cs) import Data.Aeson (Value(..), encode) import qualified Data.List as L -type CompleteQuery = (Query, [Action]) -type CompleteQueryT = CompleteQuery -> CompleteQuery +type StatementT = H.Statement H.Postgres -> H.Statement H.Postgres data QualifiedTable = QualifiedTable { qtSchema :: BS.ByteString , qtName :: BS.ByteString @@ -28,14 +30,14 @@ data OrderTerm = OrderTerm { , otDirection :: BS.ByteString } -limitT :: Maybe NonnegRange -> CompleteQueryT +limitT :: Maybe NonnegRange -> StatementT limitT r q = - q <> (" LIMIT ? OFFSET ? ", [Plain (fromByteString limit), toField offset]) + q <> (" LIMIT " <> limit <> " OFFSET " <> (cs . show) offset <> " ", []) where limit = cs $ fromMaybe "ALL" $ show . rangeLimit <$> r offset = fromMaybe 0 $ rangeOffset <$> r -whereT :: Net.Query -> CompleteQueryT +whereT :: Net.Query -> StatementT whereT params q = if L.null params then q @@ -44,59 +46,54 @@ whereT params q = cols = [ col | col <- params, fst col `notElem` ["order"] ] conjunction = mconcat $ L.intersperse andq (map wherePred cols) -orderT :: [OrderTerm] -> CompleteQueryT +orderT :: [OrderTerm] -> StatementT orderT ts q = if L.null ts then q else q <> (" order by ",[]) <> clause where clause = mconcat $ L.intersperse commaq (map queryTerm ts) - queryTerm :: OrderTerm -> CompleteQuery - queryTerm t = - (" ? ? ", - [EscapeIdentifier (otTerm t), Plain (fromByteString $ otDirection t)] - ) + queryTerm :: OrderTerm -> H.Statement H.Postgres + queryTerm t = (" " <> (pgFmtIdent $ otTerm t) <> " " + <> otDirection t <> " " + , []) -parentheticT :: CompleteQueryT +parentheticT :: StatementT parentheticT (sql, params) = (" (" <> sql <> ") ", params) -iffNotT :: CompleteQuery -> CompleteQueryT +iffNotT :: H.Statement H.Postgres -> StatementT iffNotT (aq, ap) (bq, bp) = ("WITH aaa AS (" <> aq <> " returning *) " <> bq <> "WHERE NOT EXISTS (SELECT * FROM aaa)" , ap ++ bp ) -countRows :: QualifiedTable -> CompleteQuery +countRows :: QualifiedTable -> H.Statement H.Postgres countRows t = - ("select count(1) from ?.?", - [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) + ("select count(1) from " <> fromQt t, []) -asJsonWithCount :: CompleteQueryT +asJsonWithCount :: StatementT asJsonWithCount (sql, params) = ( "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t" , params ) -selectStar :: QualifiedTable -> CompleteQuery +selectStar :: QualifiedTable -> H.Statement H.Postgres selectStar t = - ("select * from ?.?", - [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) + ("select * from " <> fromQt t, []) insertInto :: QualifiedTable -> [BS.ByteString] -> [Value] -> - CompleteQuery + H.Statement H.Postgres insertInto t [] _ = - ("insert into ?.? default values returning *", - [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)]) + ("insert into " <> fromQt t <> " default values returning *", []) insertInto t cols vals = - ("insert into ?.? (" <> - Query (BS.intercalate ", " (map (const "?") cols)) <> + ("insert into " <> fromQt t <> " (" <> + BS.intercalate ", " (map pgFmtIdent cols) <> ") values (" <> - Query (BS.intercalate ", " (map (const "?") vals)) <> + BS.intercalate ", " (map (const "?") vals) <> ") returning *" - , [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)] - ++ map EscapeIdentifier cols ++ map (Escape . rawJsonValue) vals + , vals ) rawJsonValue :: Value -> BS.ByteString @@ -104,41 +101,40 @@ rawJsonValue (String s) = cs s rawJsonValue v = cs $ encode v update :: QualifiedTable -> [BS.ByteString] -> [Value] -> - CompleteQuery + H.Statement H.Postgres update t cols vals = - ("update ?.? set (" <> - Query (BS.intercalate ", " (map (const "?") cols)) <> + ("update " <> fromQt t <> " set (" <> + BS.intercalate ", " (map pgFmtIdent cols) <> ") = (" <> - Query (BS.intercalate ", " (map (const "?") vals)) <> ")" - , [EscapeIdentifier (qtSchema t), EscapeIdentifier (qtName t)] - ++ map EscapeIdentifier cols ++ map toField vals + BS.intercalate ", " (map (const "?") vals) <> ")" + , vals ) -wherePred :: Net.QueryItem -> CompleteQuery +wherePred :: Net.QueryItem -> H.Statement H.Postgres wherePred (col, predicate) = - (" ? ? ? ", [EscapeIdentifier col, Plain op, toField value]) + (" " <> pgFmtIdent col <> " " <> op <> " ? ", [value]) where opCode:rest = BS.split '.' $ fromMaybe "." predicate value = BS.intercalate "." rest - op = fromByteString $ case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - _ -> "=" + op = case opCode of + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + _ -> "=" orderParse :: Net.Query -> [OrderTerm] orderParse q = - mapMaybe orderParseTerm . split "," $ cs order + mapMaybe orderParseTerm . BS.split "," $ cs order where order = fromMaybe "" $ join (lookup "order" q) orderParseTerm :: BS.ByteString -> Maybe OrderTerm orderParseTerm s = - case split "." s of + case BS.split "." s of [d,c] -> if d `elem` ["asc", "desc"] then Just $ OrderTerm (cs c) $ @@ -146,8 +142,32 @@ orderParseTerm s = else Nothing _ -> Nothing -commaq :: CompleteQuery +commaq :: H.Statement H.Postgres commaq = (", ", []) -andq :: CompleteQuery +andq :: H.Statement H.Postgres andq = (" and ", []) + +pgFmtIdent :: BS.ByteString -> BS.ByteString +pgFmtIdent x = + let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in + cs $ if escaped =~ danger + then "\"" <> escaped <> "\"" + else escaped + + where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString + +pgFmtLit :: Text -> Text +pgFmtLit x = + let trimmed = trimNullChars x + escaped = "'" <> replace "'" "''" trimmed <> "'" + slashed = replace "\\" "\\\\" escaped in + if escaped =~ ("\\\\" :: Text) + then "E" <> slashed + else slashed + +trimNullChars :: Text -> Text +trimNullChars = Data.Text.takeWhile (/= '\x0') + +fromQt :: QualifiedTable -> BS.ByteString +fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) From 70d9641e355be1dc0a4179554c1406718d5011f4 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 14 Nov 2014 16:22:30 -0800 Subject: [PATCH 22/45] WIP: More files converted to Hasql --- dbapi.cabal | 5 +- src/App.hs | 1 - src/Auth.hs | 34 ++++++------- src/PgQuery.hs | 41 ++++++++-------- src/PgStructure.hs | 117 ++++++++++++++++++++++++++++----------------- src/Types.hs | 1 - 6 files changed, 117 insertions(+), 82 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index a86d96440..a6d882652 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -36,7 +36,9 @@ executable dbapi , network-uri >= 2.6 , resource-pool, process , blaze-builder + , vector Other-Modules: App + , Auth , Config , PgStructure , PgQuery @@ -52,7 +54,7 @@ Test-Suite spec Hs-Source-Dirs: test, src ghc-options: -Wall -W -Werror Main-Is: Main.hs - Other-Modules: App, Config, Spec, SpecHelper + Other-Modules: App, Auth, Config, Spec, SpecHelper Build-Depends: base, hspec2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json , hasql, hasql-backend, hasql-postgres @@ -78,3 +80,4 @@ Test-Suite spec , network-uri >= 2.6 , resource-pool , blaze-builder + , vector diff --git a/src/App.hs b/src/App.hs index 51f99c2d5..041dd9838 100644 --- a/src/App.hs +++ b/src/App.hs @@ -23,7 +23,6 @@ import Network.HTTP.Base (urlEncodeVars) import Network.Wai import Data.Aeson -import Database.PostgreSQL.Simple import qualified Hasql as H import qualified Hasql.Postgres as H diff --git a/src/Auth.hs b/src/Auth.hs index be905e8fa..ac4675df9 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} module Auth where import qualified Data.Aeson as JSON @@ -7,7 +8,6 @@ import Control.Applicative ( (<*>), (<$>) ) import Crypto.BCrypt import qualified Hasql as H import qualified Hasql.Postgres as H -import GHC.Int data AuthUser = AuthUser { userId :: String @@ -20,7 +20,7 @@ instance JSON.FromJSON AuthUser where v JSON..: "id" <*> v JSON..: "pass" <*> v JSON..: "role" - parseJSON _ = mzero + parseJSON _ = mzero type DbRole = BS.ByteString @@ -34,25 +34,25 @@ data LoginAttempt = checkPass :: BS.ByteString -> BS.ByteString -> Bool checkPass = validatePassword -setRole :: Connection -> DbRole -> IO Int64 -setRole conn role = execute conn "set role ?" (Only role) +setRole :: BS.ByteString -> H.Tx H.Postgres s () +setRole role = H.unit $ [H.q| set role ?|] role -resetRole :: Connection -> IO Int64 -resetRole = flip execute_ "reset role" +resetRole :: H.Tx H.Postgres s () +resetRole = H.unit [H.q|reset role|] -addUser :: Connection -> BS.ByteString -> BS.ByteString -> BS.ByteString -> IO Int64 -addUser c identity pass role = do +addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> IO(H.Tx H.Postgres s ()) +addUser identity pass role = do Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy pass - execute c - "insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)" - (identity, hashed, role) + return $ H.unit $ + [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|] + identity hashed role -signInRole :: Connection -> BS.ByteString -> BS.ByteString -> IO LoginAttempt -signInRole c user pass = do - u <- query c "select pass, rolname from dbapi.auth where id = ?" $ Only user - return $ case u of - [[hashed, role]] -> +signInRole :: BS.ByteString -> BS.ByteString -> H.Tx H.Postgres s LoginAttempt +signInRole user pass = do + u <- H.single $ [H.q|select pass, rolname from dbapi.auth where id = ?|] user + return $ maybe LoginFailed (\r -> + let (hashed, role) = r in if checkPass hashed pass then LoginSuccess role else LoginFailed - _ -> LoginFailed + ) u diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 754209141..fa8050728 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,22 +1,21 @@ module PgQuery where import RangeQuery -import qualified Hasql as H + import qualified Hasql.Postgres as H import qualified Hasql.Backend as H + import Data.Text hiding (map) -import Text.Regex.TDFA -import Text.Regex.TDFA.Text +import Text.Regex.TDFA ( (=~) ) +import Text.Regex.TDFA.Text () import qualified Data.ByteString.Char8 as BS -import Data.ByteString.Search (split) import qualified Network.HTTP.Types.URI as Net -import Blaze.ByteString.Builder.ByteString (fromByteString) import Data.Monoid import Data.Maybe (fromMaybe, mapMaybe) import Data.Functor ( (<$>) ) import Control.Monad (join) import Data.String.Conversions (cs) -import Data.Aeson (Value(..), encode) +import qualified Data.Aeson as JSON import qualified Data.List as L type StatementT = H.Statement H.Postgres -> H.Statement H.Postgres @@ -54,8 +53,8 @@ orderT ts q = where clause = mconcat $ L.intersperse commaq (map queryTerm ts) queryTerm :: OrderTerm -> H.Statement H.Postgres - queryTerm t = (" " <> (pgFmtIdent $ otTerm t) <> " " - <> otDirection t <> " " + queryTerm t = (" " <> pgFmtIdent (otTerm t) <> " " + <> otDirection t <> " " , []) parentheticT :: StatementT @@ -83,7 +82,7 @@ selectStar :: QualifiedTable -> H.Statement H.Postgres selectStar t = ("select * from " <> fromQt t, []) -insertInto :: QualifiedTable -> [BS.ByteString] -> [Value] -> +insertInto :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] -> H.Statement H.Postgres insertInto t [] _ = ("insert into " <> fromQt t <> " default values returning *", []) @@ -93,26 +92,22 @@ insertInto t cols vals = ") values (" <> BS.intercalate ", " (map (const "?") vals) <> ") returning *" - , vals + , map pgParam vals ) -rawJsonValue :: Value -> BS.ByteString -rawJsonValue (String s) = cs s -rawJsonValue v = cs $ encode v - -update :: QualifiedTable -> [BS.ByteString] -> [Value] -> +update :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] -> H.Statement H.Postgres update t cols vals = ("update " <> fromQt t <> " set (" <> BS.intercalate ", " (map pgFmtIdent cols) <> ") = (" <> BS.intercalate ", " (map (const "?") vals) <> ")" - , vals + , map pgParam vals ) wherePred :: Net.QueryItem -> H.Statement H.Postgres wherePred (col, predicate) = - (" " <> pgFmtIdent col <> " " <> op <> " ? ", [value]) + (" " <> pgFmtIdent col <> " " <> op <> " ? ", [H.renderValue value]) where opCode:rest = BS.split '.' $ fromMaybe "." predicate @@ -128,13 +123,13 @@ wherePred (col, predicate) = orderParse :: Net.Query -> [OrderTerm] orderParse q = - mapMaybe orderParseTerm . BS.split "," $ cs order + mapMaybe orderParseTerm . BS.split ',' $ cs order where order = fromMaybe "" $ join (lookup "order" q) orderParseTerm :: BS.ByteString -> Maybe OrderTerm orderParseTerm s = - case BS.split "." s of + case BS.split '.' s of [d,c] -> if d `elem` ["asc", "desc"] then Just $ OrderTerm (cs c) $ @@ -171,3 +166,11 @@ trimNullChars = Data.Text.takeWhile (/= '\x0') fromQt :: QualifiedTable -> BS.ByteString fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) + +pgParam :: JSON.Value -> H.StatementArgument H.Postgres +pgParam (JSON.Number n) = H.renderValue n +pgParam (JSON.String s) = H.renderValue s +pgParam (JSON.Bool b) = H.renderValue b +pgParam JSON.Null = H.renderValue (Nothing :: Maybe String) +pgParam (JSON.Object o) = H.renderValue $ JSON.encode o +pgParam (JSON.Array a) = H.renderValue $ JSON.encode a diff --git a/src/PgStructure.hs b/src/PgStructure.hs index f2e3cbf20..0ba1cfaf7 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -1,23 +1,27 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes, MultiParamTypeClasses, ScopedTypeVariables #-} module PgStructure where import PgQuery (QualifiedTable(..)) import Data.Functor ( (<$>) ) import Data.Text hiding (foldl, map, zipWith, concat) import Data.Aeson +import Data.Functor.Identity +import qualified Data.Vector as V +import qualified Data.ByteString.Char8 as BS +import Data.String.Conversions (cs) import Control.Applicative ( (<*>) ) import qualified Data.List as L import qualified Data.Map as Map -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.SqlQQ -import Database.PostgreSQL.Simple.FromRow +import qualified Hasql as H +import qualified Hasql.Backend as H +import qualified Hasql.Postgres as H -foreignKeys :: Connection -> QualifiedTable -> IO (Map.Map Text ForeignKey) -foreignKeys c table = do - r <- query c [sql| +foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map BS.ByteString ForeignKey) +foreignKeys table = do + r :: [(BS.ByteString, BS.ByteString, BS.ByteString)] <- H.list $ [H.q| select kcu.column_name, ccu.table_name AS foreign_table_name, ccu.column_name AS foreign_column_name from information_schema.table_constraints AS tc @@ -28,29 +32,27 @@ foreignKeys c table = do where constraint_type = 'FOREIGN KEY' and tc.table_name=? and tc.table_schema = ? order by kcu.column_name - |] - (qtName table, qtSchema table) + |] (qtName table) (qtSchema table) return $ foldl addKey Map.empty r where - addKey m [col, ftab, fcol] = Map.insert col (ForeignKey ftab fcol) m - addKey _ _ = error "foreignKeys: should never happen" + addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m -tables :: Connection -> Text -> IO [Table] -tables c schema = - query c [sql| +tables :: BS.ByteString -> H.Tx H.Postgres s [Table] +tables schema = + H.list $ [H.q| select table_schema, table_name, is_insertable_into from information_schema.tables where table_schema = ? order by table_name - |] $ Only schema + |] schema -columns :: Connection -> QualifiedTable -> IO [Column] -columns c table = do - cols <- query c [sql| +columns :: QualifiedTable -> H.Tx H.Postgres s [Column] +columns table = do + cols <- H.list $ [H.q| select info.table_schema as schema, info.table_name as table_name, info.column_name as name, info.ordinal_position as position, info.is_nullable as nullable, info.data_type as col_type, @@ -77,15 +79,15 @@ columns c table = do group by s, n ) as enum_info on (info.udt_name = enum_info.n) - order by position |] (qtSchema table, qtName table) + order by position |] (qtSchema table) (qtName table) - fks <- foreignKeys c table - return $ map (\col -> col { colFK = Map.lookup (colName col) fks }) cols + fks <- foreignKeys table + return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols -primaryKeyColumns :: Connection -> QualifiedTable -> IO [Text] -primaryKeyColumns c table = do - r <- query c [sql| +primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [BS.ByteString] +primaryKeyColumns table = do + r :: [Identity BS.ByteString] <- H.list $ [H.q| select kc.column_name from information_schema.table_constraints tc, @@ -95,28 +97,22 @@ primaryKeyColumns c table = do and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema and kc.constraint_name = tc.constraint_name and kc.table_schema = ? - and kc.table_name = ? |] (qtSchema table, qtName table) - return $ concat r + and kc.table_name = ? |] (qtSchema table) (qtName table) + return $ map runIdentity r -data Table = Table { - tableSchema :: Text -, tableName :: Text -, tableInsertable :: Bool -} deriving (Show) +-- instance FromRow Table where +-- fromRow = Table <$> field <*> field <*> (toBool <$> field) -instance FromRow Table where - fromRow = Table <$> field <*> field <*> (toBool <$> field) - -instance FromRow Column where - fromRow = Column <$> - field <*> field <*> field <*> field - <*> (toBool <$> field) - <*> field - <*> (toBool <$> field) - <*> field <*> field <*> field - <*> (vanishNull . splitOn "," <$> field) - <*> return Nothing +-- instance FromRow Column where +-- fromRow = Column <$> +-- field <*> field <*> field <*> field +-- <*> (toBool <$> field) +-- <*> field +-- <*> (toBool <$> field) +-- <*> field <*> field <*> field +-- <*> (vanishNull . splitOn "," <$> field) +-- <*> return Nothing vanishNull :: [a] -> Maybe [a] vanishNull xs = if L.null xs then Nothing else Just xs @@ -124,6 +120,12 @@ vanishNull xs = if L.null xs then Nothing else Just xs toBool :: Text -> Bool toBool = (== "YES") +data Table = Table { + tableSchema :: Text +, tableName :: Text +, tableInsertable :: Bool +} deriving (Show) + data ForeignKey = ForeignKey { fkTable::Text, fkCol::Text } deriving (Eq, Show) @@ -143,6 +145,35 @@ data Column = Column { , colFK :: Maybe ForeignKey } deriving (Show) +instance H.RowParser H.Postgres Column where + parseRow r = + let schema = H.parseResult $ r V.! 0 + table = H.parseResult $ r V.! 1 + name = H.parseResult $ r V.! 2 + position = H.parseResult $ r V.! 3 + nullable = H.parseResult $ r V.! 4 + typ = H.parseResult $ r V.! 5 + updatable = H.parseResult $ r V.! 6 + maxLen = H.parseResult $ r V.! 7 + precision = H.parseResult $ r V.! 8 + defValue = H.parseResult $ r V.! 9 + enum = H.parseResult $ r V.! 10 in + if V.length r /= 11 + then Left "Wrong number of fields in Column" + else Column <$> schema <*> table <*> name <*> position <*> nullable + <*> typ <*> updatable <*> maxLen <*> precision + <*> defValue <*> enum <*> return Nothing + + +instance H.RowParser H.Postgres Table where + parseRow r = + let schema = H.parseResult $ r V.! 0 + name = H.parseResult $ r V.! 2 + insertable = H.parseResult $ r V.! 3 in + if V.length r /= 3 + then Left "Wrong number of fields in Table" + else Table <$> schema <*> name <*> insertable + instance ToJSON Column where toJSON c = object [ "schema" .= colSchema c diff --git a/src/Types.hs b/src/Types.hs index 350f022cf..27e323357 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -9,7 +9,6 @@ import Data.HashMap.Strict (foldlWithKey') import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) import Data.Time.Calendar (showGregorian) - import Control.Monad (mzero) instance JSON.FromJSON SqlValue where From ae9fe506be035ffd456e95366a97d6a9780350b2 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 14 Nov 2014 17:35:54 -0800 Subject: [PATCH 23/45] App.hs typechecks --- src/App.hs | 50 ++++++++++++++++++++++++++------------------------ 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/App.hs b/src/App.hs index 041dd9838..34644bcb0 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE FlexibleContexts #-} module App (app) where import Control.Monad (join) import Data.Monoid ( (<>) ) import Control.Arrow ((***)) import Control.Applicative +import Control.Monad.IO.Class (liftIO, MonadIO) import Data.Text hiding (map) import Data.Maybe (listToMaybe, fromMaybe) @@ -31,19 +33,20 @@ import RangeQuery import PgStructure import Auth -app :: Connection -> Application -app conn req respond = - respond =<< case (path, verb) of +app :: Request -> H.Session H.Postgres IO Response +app req = + case (path, verb) of ([], _) -> do - body <- encode <$> tables conn (cs schema) + body <- H.tx Nothing $ encode <$> tables (cs schema) return $ responseLBS status200 [jsonH] $ cs body ([table], "OPTIONS") -> do let t = QualifiedTable schema (cs table) - cols <- columns conn t - pkey <- map cs <$> primaryKeyColumns conn t - return $ responseLBS status200 [jsonH, allOrigins] - $ encode (TableOptions cols pkey) + H.tx Nothing $ do + cols <- columns t + pkey <- map cs <$> primaryKeyColumns t + return $ responseLBS status200 [jsonH, allOrigins] + $ encode (TableOptions cols pkey) ([table], "GET") -> if range == Just emptyRange @@ -61,7 +64,7 @@ app conn req respond = . whereT qq $ selectStar qt ) - row <- listToMaybe <$> uncurry (query conn) select + row <- H.tx Nothing $ listToMaybe <$> H.list select let (tableTotal, queryTotal, body) = fromMaybe (0, 0, Just "" :: Maybe ByteString) row from = fromMaybe 0 $ rangeOffset <$> range @@ -82,26 +85,25 @@ app conn req respond = ] (cs $ fromMaybe "[]" body) (["dbapi", "users"], "POST") -> do - body <- strictRequestBody req + body <- liftIO $ strictRequestBody req let user = decode body :: Maybe AuthUser case user of Nothing -> return $ responseLBS status400 [jsonH] $ encode . object $ [("error", String "Failed to parse user.")] Just u -> do - _ <- addUser conn (cs $ userId u) - (cs $ userPass u) (cs $ userRole u) + _ <- liftIO $ addUser (cs $ userId u) + (cs $ userPass u) (cs $ userRole u) return $ responseLBS status201 [ jsonH , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) ] "" ([table], "POST") -> - handleJsonObj req $ \obj -> do + handleJsonObj req $ \obj -> H.tx Nothing $ do let qt = QualifiedTable schema (cs table) - _ <- uncurry (execute conn) - $ insertInto qt (map cs $ keys obj) (elems obj) - primaryKeys <- map cs <$> primaryKeyColumns conn qt + H.unit $ insertInto qt (map cs $ keys obj) (elems obj) + primaryKeys <- map cs <$> primaryKeyColumns qt let primaries = filterWithKey (const . (`elem` primaryKeys)) obj let params = urlEncodeVars $ map (\t -> (cs $ fst t, "eq." <> cs (encode $ snd t))) @@ -112,19 +114,19 @@ app conn req respond = ] "" ([table], "PUT") -> - handleJsonObj req $ \obj -> do + handleJsonObj req $ \obj -> H.tx Nothing $ do let qt = QualifiedTable schema (cs table) - primaryKeys <- primaryKeyColumns conn qt + primaryKeys <- primaryKeyColumns qt let specifiedKeys = map (cs . fst) qq if S.fromList primaryKeys /= S.fromList specifiedKeys then return $ responseLBS status405 [] "You must speficy all and only primary keys as params" else do - tableCols <- map (cs . colName) <$> columns conn qt + tableCols <- map (cs . colName) <$> columns qt let cols = map cs $ keys obj if S.fromList tableCols == S.fromList cols then do let vals = elems obj - _ <- uncurry (execute conn) $ iffNotT + H.unit $ iffNotT (whereT qq $ update qt cols vals) (insertInto qt cols vals) return $ responseLBS status204 [ jsonH ] "" @@ -135,9 +137,9 @@ app conn req respond = "You must specify all columns in PUT request" ([table], "PATCH") -> - handleJsonObj req $ \obj -> do + handleJsonObj req $ \obj -> H.tx Nothing $ do let qt = QualifiedTable schema (cs table) - _ <- uncurry (execute conn) + H.unit $ whereT qq $ update qt (map cs $ keys obj) (elems obj) return $ responseLBS status204 [ jsonH ] "" @@ -184,9 +186,9 @@ requestedSchema hdrs = jsonH :: Header jsonH = (hContentType, "application/json") -handleJsonObj :: Request -> (Object -> IO Response) -> IO Response +handleJsonObj :: MonadIO m => Request -> (Object -> m Response) -> m Response handleJsonObj req handler = do - parse <- fmap eitherDecode . strictRequestBody $ req + parse <- liftIO $ fmap eitherDecode . strictRequestBody $ req case parse of Left err -> return $ responseLBS status400 [jsonH] jErr From dcbecf085fd684fec445af9a125ae95b9ce593fc Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 15 Nov 2014 09:33:21 -0800 Subject: [PATCH 24/45] Program compiles but without auth, uri parsing, or json error reporting --- src/Main.hs | 49 ++++++++++-------- src/Middleware.hs | 129 +++++++++++++++++++++------------------------- 2 files changed, 87 insertions(+), 91 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index f3294f2ef..d3d1a0836 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,17 +3,16 @@ module Main where import Paths_dbapi (version) import App -import Middleware (inTransaction, authenticated, withSavepoint, clientErrors, - redirectInsecure, withDBConnection, Environment(..)) +--import Auth +import Middleware import Control.Monad (unless) -import Control.Exception(bracket) import Data.String.Conversions (cs) +import Network.Wai import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.Gzip (gzip, def) import Network.Wai.Middleware.Static (staticPolicy, only) -import Data.Pool(createPool, destroyAllResources) import Data.List (intercalate) import Data.Version (versionBranch) import qualified Hasql as H @@ -25,26 +24,34 @@ import Config (AppConfig(..), argParser, corsPolicy) main :: IO () main = do conf <- execParser (info (helper <*> argParser) describe) - bracket - (createPool (connectPostgreSQL $ cs (configDbUri conf)) - close 1 600 (configPool conf)) - destroyAllResources - (\pool -> do - let port = configPort conf + let port = configPort conf - unless (configSecure conf) $ - putStrLn "WARNING, running in insecure mode, auth will be in plaintext" + unless (configSecure conf) $ + putStrLn "WARNING, running in insecure mode, auth will be in plaintext" - Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) - let settings = setPort port - . setServerName (cs $ "dbapi/" <> prettyVersion) - $ defaultSettings - runSettings settings $ (if configSecure conf then redirectInsecure else id) + Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) + + + let pgSettings = H.Postgres "localhost" 5432 "postgres" "" "postgres" + + sessSettings <- maybe (fail "Improper session settings") return $ + H.sessionSettings 6 30 + + let settings = setPort port + . setServerName (cs $ "dbapi/" <> prettyVersion) + $ defaultSettings + middle = + (if configSecure conf then redirectInsecure else id) . gzip def . cors corsPolicy . clientErrors - . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) - . withDBConnection pool . inTransaction Production - . authenticated (cs $ configAnonRole conf) . Middleware.withSavepoint Production $ app - ) + . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in + + runSettings settings $ middle (runApp pgSettings sessSettings) + -- . authenticated (cs $ configAnonRole conf) $ app + where describe = progDesc "create a REST API to an existing Postgres database" prettyVersion = intercalate "." $ map show $ versionBranch version + +runApp :: H.Postgres -> H.SessionSettings -> Application +runApp pg sess req respond = + respond =<< H.session pg sess (app req) diff --git a/src/Middleware.hs b/src/Middleware.hs index cfeccd592..519984964 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -2,97 +2,86 @@ module Middleware where -import Data.Aeson ((.=), toJSON, ToJSON, object, encode) -import Data.Maybe (fromMaybe) +--import Data.Aeson ((.=), toJSON, ToJSON, object, encode) +-- import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) -import Data.Pool(withResource, Pool) +-- import Data.Pool(withResource, Pool) -import Database.PostgreSQL.Simple +import qualified Hasql as H import Data.String.Conversions(cs) -import qualified Data.ByteString.Char8 as BS -import Control.Exception (catchJust, bracket_) +--import qualified Data.ByteString.Char8 as BS +import Control.Exception (catchJust) -import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization, - hLocation) -import Network.HTTP.Types.Status (status400, status401, status404, status301) +import Network.HTTP.Types.Header (hLocation, hContentType) +import Network.HTTP.Types.Status (status400, status301) import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, - rawQueryString, isSecure, requestMethod, Request) + rawQueryString, isSecure) import Network.URI (URI(..), parseURI) -import Auth (LoginAttempt(..), signInRole, setRole, resetRole) -import Codec.Binary.Base64.String (decode) +-- import Auth (LoginAttempt(..), signInRole, setRole, resetRole) +-- import Codec.Binary.Base64.String (decode) import Debug.Trace -data Environment = Test | Production deriving (Eq) +-- data Environment = Test | Production deriving (Eq) -withDBConnection :: Pool Connection -> (Connection -> Application) -> Application -withDBConnection pool app req respond = - withResource pool (\c -> app c req respond) +-- safeAction :: Request -> Bool +-- safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod -safeAction :: Request -> Bool -safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod +-- withSavepoint :: Environment -> (Connection -> Application) -> +-- Connection -> Application +-- withSavepoint env app conn req respond = +-- if env == Production && safeAction req +-- then go +-- else Database.PostgreSQL.Simple.withSavepoint conn go +-- where go = app conn req respond -inTransaction :: Environment -> (Connection -> Application) -> - Connection -> Application -inTransaction env app conn req respond = - if env == Production && safeAction req - then go - else withTransaction conn go - where go = app conn req respond +-- authenticated :: BS.ByteString -> (Connection -> Application) -> +-- Connection -> Application +-- authenticated anon app conn req respond = do +-- attempt <- httpRequesterRole (requestHeaders req) +-- case attempt of +-- MalformedAuth -> +-- respond $ responseLBS status400 [] "Malformed basic auth header" +-- LoginFailed -> +-- respond $ responseLBS status401 [] "Invalid username or password" +-- LoginSuccess role -> +-- bracket_ (setRole conn role) (resetRole conn) $ app conn req respond +-- NoCredentials -> +-- bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond -withSavepoint :: Environment -> (Connection -> Application) -> - Connection -> Application -withSavepoint env app conn req respond = - if env == Production && safeAction req - then go - else Database.PostgreSQL.Simple.withSavepoint conn go - where go = app conn req respond +-- where +-- httpRequesterRole :: RequestHeaders -> IO LoginAttempt +-- httpRequesterRole hdrs = do +-- let auth = fromMaybe "" $ lookup hAuthorization hdrs +-- case BS.split ' ' (cs auth) of +-- ("Basic" : b64 : _) -> +-- case BS.split ':' $ cs (decode $ cs b64) of +-- (u:p:_) -> signInRole conn u p +-- _ -> return MalformedAuth +-- _ -> return NoCredentials -authenticated :: BS.ByteString -> (Connection -> Application) -> - Connection -> Application -authenticated anon app conn req respond = do - attempt <- httpRequesterRole (requestHeaders req) - case attempt of - MalformedAuth -> - respond $ responseLBS status400 [] "Malformed basic auth header" - LoginFailed -> - respond $ responseLBS status401 [] "Invalid username or password" - LoginSuccess role -> - bracket_ (setRole conn role) (resetRole conn) $ app conn req respond - NoCredentials -> - bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond - - where - httpRequesterRole :: RequestHeaders -> IO LoginAttempt - httpRequesterRole hdrs = do - let auth = fromMaybe "" $ lookup hAuthorization hdrs - case BS.split ' ' (cs auth) of - ("Basic" : b64 : _) -> - case BS.split ':' $ cs (decode $ cs b64) of - (u:p:_) -> signInRole conn u p - _ -> return MalformedAuth - _ -> return NoCredentials - -instance ToJSON SqlError where - toJSON t = object [ - "error" .= object [ - "message" .= (cs $ sqlErrorMsg t :: String) - , "detail" .= (cs $ sqlErrorDetail t :: String) - , "state" .= (cs $ sqlState t :: String) - , "hint" .= (cs $ sqlErrorHint t :: String) - ] - ] +-- instance ToJSON SqlError where +-- toJSON t = object [ +-- "error" .= object [ +-- "message" .= (cs $ sqlErrorMsg t :: String) +-- , "detail" .= (cs $ sqlErrorDetail t :: String) +-- , "state" .= (cs $ sqlState t :: String) +-- , "hint" .= (cs $ sqlErrorHint t :: String) +-- ] +-- ] clientErrors :: Application -> Application clientErrors app req respond = catchJust isPgException (app req respond) $ \err -> - respond $ if sqlState err == "42P01" - then responseLBS status404 [] "" - else responseLBS status400 [(hContentType, "application/json")] (encode err) + respond $ + responseLBS status400 [(hContentType, "application/json")] (cs $ show err) + -- if sqlState err == "42P01" + -- then responseLBS status404 [] "" + -- else responseLBS status400 [(hContentType, "application/json")] (encode err) where - isPgException :: SqlError -> Maybe SqlError + isPgException :: H.Error -> Maybe H.Error isPgException x = Just (traceShow x x) From d2888c62f14dce17530a5115b6c2c9603a45415c Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 15 Nov 2014 11:13:58 -0800 Subject: [PATCH 25/45] hasql wants to rowParse text not bytestring --- src/App.hs | 12 ++++++++---- src/Main.hs | 17 ++++++----------- src/PgQuery.hs | 2 +- 3 files changed, 15 insertions(+), 16 deletions(-) diff --git a/src/App.hs b/src/App.hs index 34644bcb0..14376087b 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -module App (app) where +module App (runApp, app) where import Control.Monad (join) import Data.Monoid ( (<>) ) @@ -8,7 +8,7 @@ import Control.Applicative import Control.Monad.IO.Class (liftIO, MonadIO) import Data.Text hiding (map) -import Data.Maybe (listToMaybe, fromMaybe) +import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) @@ -33,6 +33,10 @@ import RangeQuery import PgStructure import Auth +runApp :: H.Postgres -> H.SessionSettings -> Application +runApp pg sess req respond = + respond =<< H.session pg sess (app req) + app :: Request -> H.Session H.Postgres IO Response app req = case (path, verb) of @@ -64,9 +68,9 @@ app req = . whereT qq $ selectStar qt ) - row <- H.tx Nothing $ listToMaybe <$> H.list select + row <- H.tx Nothing $ H.single select let (tableTotal, queryTotal, body) = - fromMaybe (0, 0, Just "" :: Maybe ByteString) row + fromMaybe (0, 0, Just "" :: Maybe Text) row from = fromMaybe 0 $ rangeOffset <$> range to = from+queryTotal contentRange = contentRangeH from to tableTotal diff --git a/src/Main.hs b/src/Main.hs index d3d1a0836..dbe80247a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,7 +8,6 @@ import Middleware import Control.Monad (unless) import Data.String.Conversions (cs) -import Network.Wai import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.Gzip (gzip, def) @@ -32,26 +31,22 @@ main = do Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) - let pgSettings = H.Postgres "localhost" 5432 "postgres" "" "postgres" + let pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test" sessSettings <- maybe (fail "Improper session settings") return $ - H.sessionSettings 6 30 + H.sessionSettings 95 30 - let settings = setPort port - . setServerName (cs $ "dbapi/" <> prettyVersion) - $ defaultSettings + let appSettings = setPort port + . setServerName (cs $ "dbapi/" <> prettyVersion) + $ defaultSettings middle = (if configSecure conf then redirectInsecure else id) . gzip def . cors corsPolicy . clientErrors . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in - runSettings settings $ middle (runApp pgSettings sessSettings) + runSettings appSettings $ middle (runApp pgSettings sessSettings) -- . authenticated (cs $ configAnonRole conf) $ app where describe = progDesc "create a REST API to an existing Postgres database" prettyVersion = intercalate "." $ map show $ versionBranch version - -runApp :: H.Postgres -> H.SessionSettings -> Application -runApp pg sess req respond = - respond =<< H.session pg sess (app req) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index fa8050728..a0147dde6 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -74,7 +74,7 @@ countRows t = asJsonWithCount :: StatementT asJsonWithCount (sql, params) = ( - "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t" + "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t" , params ) From da79f6cea13926a57b1a7faeab9ef0c82dc0774d Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 16 Nov 2014 12:33:36 -0800 Subject: [PATCH 26/45] Share connection pool with all http clients --- dbapi.cabal | 2 ++ src/App.hs | 6 +----- src/Main.hs | 8 +++++++- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index a6d882652..a100bf093 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -37,6 +37,7 @@ executable dbapi , resource-pool, process , blaze-builder , vector + , mtl Other-Modules: App , Auth , Config @@ -81,3 +82,4 @@ Test-Suite spec , resource-pool , blaze-builder , vector + , mtl diff --git a/src/App.hs b/src/App.hs index 14376087b..317d11835 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -module App (runApp, app) where +module App (app) where import Control.Monad (join) import Data.Monoid ( (<>) ) @@ -33,10 +33,6 @@ import RangeQuery import PgStructure import Auth -runApp :: H.Postgres -> H.SessionSettings -> Application -runApp pg sess req respond = - respond =<< H.session pg sess (app req) - app :: Request -> H.Session H.Postgres IO Response app req = case (path, verb) of diff --git a/src/Main.hs b/src/Main.hs index dbe80247a..bc6ec3c8d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,6 +7,8 @@ import App import Middleware import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (runReaderT, ask) import Data.String.Conversions (cs) import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) @@ -44,7 +46,11 @@ main = do . gzip def . cors corsPolicy . clientErrors . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in - runSettings appSettings $ middle (runApp pgSettings sessSettings) + H.session pgSettings sessSettings $ do + session' <- flip runReaderT <$> ask + let runApp req respond = respond =<< session' (app req) in + + liftIO $ runSettings appSettings $ middle runApp -- . authenticated (cs $ configAnonRole conf) $ app where From f6b7b42d75adffc666d75030e3bafd7d76ee1914 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 17 Nov 2014 09:07:42 -0800 Subject: [PATCH 27/45] Feature specs compile --- dbapi.cabal | 2 +- test/Feature/AuthSpec.hs | 2 +- test/Feature/CorsSpec.hs | 2 +- test/Feature/InsertSpec.hs | 2 +- test/Feature/QuerySpec.hs | 15 +++- test/Feature/RangeSpec.hs | 2 +- .../{StructureSpec.hs => StructureSpec.hx} | 0 test/Main.hs | 30 +++++--- test/SpecHelper.hs | 72 +++++++------------ 9 files changed, 64 insertions(+), 63 deletions(-) rename test/Feature/{StructureSpec.hs => StructureSpec.hx} (100%) diff --git a/dbapi.cabal b/dbapi.cabal index a100bf093..14f0b90b0 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -56,7 +56,7 @@ Test-Suite spec ghc-options: -Wall -W -Werror Main-Is: Main.hs Other-Modules: App, Auth, Config, Spec, SpecHelper - Build-Depends: base, hspec2, QuickCheck + Build-Depends: base, hspec >= 2.0, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json , hasql, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index 55e754d9c..91198be1b 100644 --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -11,7 +11,7 @@ import SpecHelper -- }}} spec :: Spec -spec = around appWithFixture $ +spec = around withApp $ describe "authorization" $ do it "hides tables that anonymous does not own" $ get "/authors_only" `shouldRespondWith` 400 -- TODO: should be 404 diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs index 4d25b04aa..a08a64d9f 100644 --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -12,7 +12,7 @@ import Network.HTTP.Types -- }}} spec :: Spec -spec = around appWithFixture $ +spec = around withApp $ describe "CORS" $ do let preflightHeaders = [ ("Accept", "*/*"), diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 8f047dc69..df5d56593 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -20,7 +20,7 @@ import TestTypes(IncPK(..), CompoundPK(..)) -- }}} spec :: Spec -spec = around appWithFixture $ do +spec = around withApp $ do describe "Posting new record" $ do it "accepts disparate json types" $ post "/menagerie" diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 06328b685..5de26a271 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -5,8 +5,21 @@ import Test.Hspec.Wai import SpecHelper +-- around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec +-- type Spec = SpecWith () +-- type ActionWith a = a -> IO () +-- +-- get :: ByteString -> WaiSession SResponse +-- newtype WaiSession a = WaiSession {unWaiSession :: Session a} +-- type Session = ReaderT Application (StateT ClientState IO) +-- +-- type Application = +-- Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived +-- +-- runApp :: Request -> (Response -> IO Postgres) -> IO Postgres + spec :: Spec -spec = around appWithFixture $ do +spec = around withApp $ do describe "Querying a nonexistent table" $ it "causes a 404" $ get "/faketable" `shouldRespondWith` 404 diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index 8beba88bb..e9909556f 100644 --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -8,7 +8,7 @@ import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus)) import SpecHelper spec :: Spec -spec = around appWithFixture $ +spec = around withApp $ describe "GET /items" $ do context "without range headers" $ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hx similarity index 100% rename from test/Feature/StructureSpec.hs rename to test/Feature/StructureSpec.hx diff --git a/test/Main.hs b/test/Main.hs index abe226374..a3380388c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,17 +1,29 @@ +{-# LANGUAGE QuasiQuotes #-} module Main where -import Database.PostgreSQL.Simple +import qualified Hasql as H +import qualified Hasql.Backend as H +import qualified Hasql.Postgres as H +import qualified Data.ByteString.Char8 as BS import Test.Hspec +import SpecHelper import Spec -import SpecHelper (openConnection, loadFixture) main :: IO () main = do - c <-openConnection - _ <- execute_ c "drop schema if exists \"1\" cascade" - _ <- execute_ c "drop schema if exists private cascade" - _ <- execute_ c "drop schema if exists dbapi cascade" - loadFixture "roles" c - loadFixture "schema" c - close c + roles <- loadFixture "roles" + schema <- loadFixture "schema" + H.session pgSettings testSettings $ do + H.tx Nothing $ do + H.unit [H.q| drop schema if exists "1" cascade |] + H.unit [H.q| drop schema if exists private cascade |] + H.unit [H.q| drop schema if exists dbapi cascade |] + H.unit roles + H.unit schema + hspec spec + +loadFixture :: FilePath -> IO(H.Statement H.Postgres) +loadFixture name = do + query <- BS.readFile $ "test/fixtures/" ++ name ++ ".sql" + return (query, []) diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index ca42e9092..a86d7c567 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -4,71 +4,47 @@ import Network.Wai import Test.Hspec import Test.Hspec.Wai -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.Types +import Hasql as H +import Hasql.Postgres as H import Data.String.Conversions (cs) -import Control.Exception.Base (bracket, finally) -import Control.Monad (void) +-- import Control.Exception.Base (bracket, finally) +import Control.Monad.Reader (runReaderT, ask) +-- import Control.Monad (void) +import Control.Applicative ( (<$>) ) import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization) import Codec.Binary.Base64.String (encode) import Data.CaseInsensitive (CI(..)) +import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS -import Network.Wai.Middleware.Cors (cors) - -import Middleware(clientErrors, withSavepoint, authenticated, Environment(..)) +-- import Network.Wai.Middleware.Cors (cors) import App (app) -import Config (corsPolicy, AppConfig(..)) -import Auth (addUser) +-- import Config (corsPolicy, AppConfig(..)) +-- import Auth (addUser) isLeft :: Either a b -> Bool isLeft (Left _ ) = True isLeft _ = False -cfg :: AppConfig -cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10 +-- cfg :: AppConfig +-- cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10 -openConnection :: IO Connection -openConnection = connectPostgreSQL $ cs $ configDbUri cfg +testSettings :: SessionSettings +testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30 -withDatabaseConnection :: (Connection -> IO ()) -> IO () -withDatabaseConnection = bracket openConnection close +pgSettings :: Postgres +pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test" -loadFixture :: String -> Connection -> IO () -loadFixture name conn = do - sql <- readFile $ "test/fixtures/" ++ name ++ ".sql" - void $ execute_ conn $ Query (cs sql) - -dbWithSchema :: ActionWith Connection -> IO () -dbWithSchema action = withDatabaseConnection $ \c -> do - _ <- execute_ c "begin;" - action c - rollback c - -withUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> - ActionWith Connection -> ActionWith Connection -withUser name pass role action conn = do - _ <- addUser conn name pass role - finally (action conn) $ do - _ <- execute conn "delete from dbapi.auth where id=?" $ Only name - execute_ conn "commit" - -withApp :: ActionWith Application -> ActionWith Connection -withApp action conn = do - _ <- execute_ conn "begin;" - action $ cors corsPolicy $ authenticated "dbapi_anonymous" app conn - rollback conn - -appWithFixture :: ActionWith Application -> IO () -appWithFixture action = withDatabaseConnection $ \c -> do - _ <- execute_ c "begin;" - action $ cors corsPolicy . clientErrors $ - (authenticated "dbapi_anonymous" . Middleware.withSavepoint Test) app c - rollback c +withApp :: ActionWith Application -> IO () +withApp perform = + perform $ \req resp -> + H.session pgSettings testSettings $ do + session' <- flip runReaderT <$> ask + liftIO $ resp =<< session' (app req) rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] @@ -81,8 +57,8 @@ matchHeader name valRegex headers = maybe False (=~ valRegex) $ lookup name headers authHeader :: String -> String -> Header -authHeader user pass = - (hAuthorization, cs $ "Basic " ++ encode (user ++ ":" ++ pass)) +authHeader u p = + (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p)) -- for hspec-wai pending_ :: WaiSession () From d6e3526bfffef3b896b2acee644c5119cdf0b1e0 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 20 Nov 2014 22:06:51 -0800 Subject: [PATCH 28/45] Use Text for textual data Also upgrade Hasql --- dbapi.cabal | 6 +-- src/App.hs | 19 ++++---- src/Auth.hs | 17 +++---- src/PgQuery.hs | 107 ++++++++++++++++++++++++--------------------- src/PgStructure.hs | 30 ++++--------- test/Main.hs | 4 +- 6 files changed, 88 insertions(+), 95 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 14f0b90b0..9250400fa 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -16,7 +16,7 @@ executable dbapi default-extensions: OverloadedStrings other-extensions: QuasiQuotes build-depends: base >=4.6 && <5 - , hasql, hasql-backend, hasql-postgres + , hasql >= 0.2.0, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 @@ -34,7 +34,7 @@ executable dbapi , transformers , bcrypt, base64-string , network-uri >= 2.6 - , resource-pool, process + , resource-pool , blaze-builder , vector , mtl @@ -58,7 +58,7 @@ Test-Suite spec Other-Modules: App, Auth, Config, Spec, SpecHelper Build-Depends: base, hspec >= 2.0, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json - , hasql, hasql-backend, hasql-postgres + , hasql >= 0.2.0, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , HTTP, convertible , case-insensitive diff --git a/src/App.hs b/src/App.hs index 317d11835..0f4db393a 100644 --- a/src/App.hs +++ b/src/App.hs @@ -2,7 +2,6 @@ module App (app) where import Control.Monad (join) -import Data.Monoid ( (<>) ) import Control.Arrow ((***)) import Control.Applicative import Control.Monad.IO.Class (liftIO, MonadIO) @@ -13,7 +12,6 @@ import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) import Data.HashMap.Strict (keys, elems, filterWithKey, toList) -import Data.ByteString.Char8 hiding (zip, map, elem) import Data.String.Conversions (cs) import Data.List (sortBy) import qualified Data.Set as S @@ -25,6 +23,8 @@ import Network.HTTP.Base (urlEncodeVars) import Network.Wai import Data.Aeson +import Data.Coerce +import Data.Monoid import qualified Hasql as H import qualified Hasql.Postgres as H @@ -53,8 +53,8 @@ app req = then return $ responseLBS status416 [] "HTTP Range error" else do let qt = QualifiedTable schema (cs table) - let select = - ("select ",[]) <> + let select = coerce $ + ("select ",[],mempty) <> parentheticT ( whereT qq $ countRows qt ) <> commaq <> ( @@ -102,7 +102,7 @@ app req = ([table], "POST") -> handleJsonObj req $ \obj -> H.tx Nothing $ do let qt = QualifiedTable schema (cs table) - H.unit $ insertInto qt (map cs $ keys obj) (elems obj) + H.unit . coerce $ insertInto qt (map cs $ keys obj) (elems obj) primaryKeys <- map cs <$> primaryKeyColumns qt let primaries = filterWithKey (const . (`elem` primaryKeys)) obj let params = urlEncodeVars @@ -126,7 +126,7 @@ app req = let cols = map cs $ keys obj if S.fromList tableCols == S.fromList cols then do let vals = elems obj - H.unit $ iffNotT + H.unit . coerce $ iffNotT (whereT qq $ update qt cols vals) (insertInto qt cols vals) return $ responseLBS status204 [ jsonH ] "" @@ -140,6 +140,7 @@ app req = handleJsonObj req $ \obj -> H.tx Nothing $ do let qt = QualifiedTable schema (cs table) H.unit + $ coerce $ whereT qq $ update qt (map cs $ keys obj) (elems obj) return $ responseLBS status204 [ jsonH ] "" @@ -173,15 +174,15 @@ contentRangeH from to total = <> cs (show total) ) -requestedSchema :: RequestHeaders -> ByteString +requestedSchema :: RequestHeaders -> Text requestedSchema hdrs = case verStr of Just [[_, ver]] -> ver _ -> "1" where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String - accept = lookup hAccept hdrs :: Maybe ByteString - verStr = (=~ verRegex) <$> accept :: Maybe [[ByteString]] + accept = cs <$> lookup hAccept hdrs :: Maybe Text + verStr = (=~ verRegex) <$> accept :: Maybe [[Text]] jsonH :: Header jsonH = (hContentType, "application/json") diff --git a/src/Auth.hs b/src/Auth.hs index ac4675df9..4b87243b5 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -2,12 +2,13 @@ module Auth where import qualified Data.Aeson as JSON -import qualified Data.ByteString.Char8 as BS import Control.Monad (mzero) import Control.Applicative ( (<*>), (<$>) ) import Crypto.BCrypt +import Data.Text import qualified Hasql as H import qualified Hasql.Postgres as H +import Data.String.Conversions (cs) data AuthUser = AuthUser { userId :: String @@ -22,7 +23,7 @@ instance JSON.FromJSON AuthUser where v JSON..: "role" parseJSON _ = mzero -type DbRole = BS.ByteString +type DbRole = Text data LoginAttempt = NoCredentials @@ -31,23 +32,23 @@ data LoginAttempt = | LoginSuccess DbRole deriving (Eq, Show) -checkPass :: BS.ByteString -> BS.ByteString -> Bool -checkPass = validatePassword +checkPass :: Text -> Text -> Bool +checkPass = (. cs) . validatePassword . cs -setRole :: BS.ByteString -> H.Tx H.Postgres s () +setRole :: Text -> H.Tx H.Postgres s () setRole role = H.unit $ [H.q| set role ?|] role resetRole :: H.Tx H.Postgres s () resetRole = H.unit [H.q|reset role|] -addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> IO(H.Tx H.Postgres s ()) +addUser :: Text -> Text -> Text -> IO(H.Tx H.Postgres s ()) addUser identity pass role = do - Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy pass + Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) return $ H.unit $ [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|] identity hashed role -signInRole :: BS.ByteString -> BS.ByteString -> H.Tx H.Postgres s LoginAttempt +signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt signInRole user pass = do u <- H.single $ [H.q|select pass, rolname from dbapi.auth where id = ?|] user return $ maybe LoginFailed (\r -> diff --git a/src/PgQuery.hs b/src/PgQuery.hs index a0147dde6..14070ccf6 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module PgQuery where import RangeQuery @@ -8,8 +9,8 @@ import qualified Hasql.Backend as H import Data.Text hiding (map) import Text.Regex.TDFA ( (=~) ) import Text.Regex.TDFA.Text () -import qualified Data.ByteString.Char8 as BS import qualified Network.HTTP.Types.URI as Net +import qualified Data.ByteString.Char8 as BS import Data.Monoid import Data.Maybe (fromMaybe, mapMaybe) import Data.Functor ( (<$>) ) @@ -18,29 +19,32 @@ import Data.String.Conversions (cs) import qualified Data.Aeson as JSON import qualified Data.List as L -type StatementT = H.Statement H.Postgres -> H.Statement H.Postgres +type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All) + +type StatementT = DynamicSQL -> DynamicSQL + data QualifiedTable = QualifiedTable { - qtSchema :: BS.ByteString -, qtName :: BS.ByteString + qtSchema :: Text +, qtName :: Text } deriving (Show) data OrderTerm = OrderTerm { - otTerm :: BS.ByteString + otTerm :: Text , otDirection :: BS.ByteString } limitT :: Maybe NonnegRange -> StatementT limitT r q = - q <> (" LIMIT " <> limit <> " OFFSET " <> (cs . show) offset <> " ", []) + q <> (" LIMIT " <> limit <> " OFFSET " <> offset <> " ", [], mempty) where - limit = cs $ fromMaybe "ALL" $ show . rangeLimit <$> r - offset = fromMaybe 0 $ rangeOffset <$> r + limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r + offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r whereT :: Net.Query -> StatementT whereT params q = if L.null params then q - else q <> (" where ",[]) <> conjunction + else q <> (" where ",[],mempty) <> conjunction where cols = [ col | col <- params, fst col `notElem` ["order"] ] conjunction = mconcat $ L.intersperse andq (map wherePred cols) @@ -49,69 +53,70 @@ orderT :: [OrderTerm] -> StatementT orderT ts q = if L.null ts then q - else q <> (" order by ",[]) <> clause + else q <> (" order by ",[],mempty) <> clause where clause = mconcat $ L.intersperse commaq (map queryTerm ts) - queryTerm :: OrderTerm -> H.Statement H.Postgres - queryTerm t = (" " <> pgFmtIdent (otTerm t) <> " " - <> otDirection t <> " " - , []) + queryTerm :: OrderTerm -> DynamicSQL + queryTerm t = (" " <> cs (pgFmtIdent $ otTerm t) <> " " + <> otDirection t <> " " + , [], mempty) parentheticT :: StatementT -parentheticT (sql, params) = - (" (" <> sql <> ") ", params) +parentheticT (sql, params, pre) = + (" (" <> sql <> ") ", params, pre) -iffNotT :: H.Statement H.Postgres -> StatementT -iffNotT (aq, ap) (bq, bp) = +iffNotT :: DynamicSQL -> StatementT +iffNotT (aq, ap, apre) (bq, bp, bpre) = ("WITH aaa AS (" <> aq <> " returning *) " <> bq <> "WHERE NOT EXISTS (SELECT * FROM aaa)" , ap ++ bp + , All $ getAll apre && getAll bpre ) -countRows :: QualifiedTable -> H.Statement H.Postgres +countRows :: QualifiedTable -> DynamicSQL countRows t = - ("select count(1) from " <> fromQt t, []) + ("select count(1) from " <> fromQt t, [], mempty) asJsonWithCount :: StatementT -asJsonWithCount (sql, params) = ( +asJsonWithCount (sql, params, pre) = ( "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t" - , params + , params, pre ) -selectStar :: QualifiedTable -> H.Statement H.Postgres +selectStar :: QualifiedTable -> DynamicSQL selectStar t = - ("select * from " <> fromQt t, []) + ("select * from " <> fromQt t, [], mempty) -insertInto :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] -> - H.Statement H.Postgres +insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL insertInto t [] _ = - ("insert into " <> fromQt t <> " default values returning *", []) + ("insert into " <> fromQt t <> " default values returning *", [], mempty) insertInto t cols vals = ("insert into " <> fromQt t <> " (" <> - BS.intercalate ", " (map pgFmtIdent cols) <> + cs (intercalate ", " (map pgFmtIdent cols)) <> ") values (" <> - BS.intercalate ", " (map (const "?") vals) <> - ") returning *" + cs (intercalate ", " (map (const "?") vals)) <> + ")" , map pgParam vals + , mempty ) -update :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] -> - H.Statement H.Postgres +update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL update t cols vals = ("update " <> fromQt t <> " set (" <> - BS.intercalate ", " (map pgFmtIdent cols) <> + cs (intercalate ", " (map pgFmtIdent cols)) <> ") = (" <> - BS.intercalate ", " (map (const "?") vals) <> ")" + cs (intercalate ", " (map (const "?") vals)) <> ")" , map pgParam vals + , mempty ) -wherePred :: Net.QueryItem -> H.Statement H.Postgres +wherePred :: Net.QueryItem -> DynamicSQL wherePred (col, predicate) = - (" " <> pgFmtIdent col <> " " <> op <> " ? ", [H.renderValue value]) + (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> " ", [], mempty) where - opCode:rest = BS.split '.' $ fromMaybe "." predicate - value = BS.intercalate "." rest + opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate + value = intercalate "." rest op = case opCode of "eq" -> "=" "gt" -> ">" @@ -123,41 +128,41 @@ wherePred (col, predicate) = orderParse :: Net.Query -> [OrderTerm] orderParse q = - mapMaybe orderParseTerm . BS.split ',' $ cs order + mapMaybe orderParseTerm . split (==',') $ cs order where order = fromMaybe "" $ join (lookup "order" q) -orderParseTerm :: BS.ByteString -> Maybe OrderTerm +orderParseTerm :: Text -> Maybe OrderTerm orderParseTerm s = - case BS.split '.' s of + case split (=='.') s of [d,c] -> if d `elem` ["asc", "desc"] - then Just $ OrderTerm (cs c) $ + then Just $ OrderTerm c $ if d == "asc" then "asc" else "desc" else Nothing _ -> Nothing -commaq :: H.Statement H.Postgres -commaq = (", ", []) +commaq :: DynamicSQL +commaq = (", ", [], mempty) -andq :: H.Statement H.Postgres -andq = (" and ", []) +andq :: DynamicSQL +andq = (" and ", [], mempty) -pgFmtIdent :: BS.ByteString -> BS.ByteString +pgFmtIdent :: Text -> Text pgFmtIdent x = let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in - cs $ if escaped =~ danger + if escaped =~ danger then "\"" <> escaped <> "\"" else escaped - where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString + where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: Text pgFmtLit :: Text -> Text pgFmtLit x = let trimmed = trimNullChars x escaped = "'" <> replace "'" "''" trimmed <> "'" slashed = replace "\\" "\\\\" escaped in - if escaped =~ ("\\\\" :: Text) + cs $ if escaped =~ ("\\\\" :: Text) then "E" <> slashed else slashed @@ -165,7 +170,7 @@ trimNullChars :: Text -> Text trimNullChars = Data.Text.takeWhile (/= '\x0') fromQt :: QualifiedTable -> BS.ByteString -fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) +fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) pgParam :: JSON.Value -> H.StatementArgument H.Postgres pgParam (JSON.Number n) = H.renderValue n diff --git a/src/PgStructure.hs b/src/PgStructure.hs index 0ba1cfaf7..89e85c58c 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -7,7 +7,6 @@ import Data.Text hiding (foldl, map, zipWith, concat) import Data.Aeson import Data.Functor.Identity import qualified Data.Vector as V -import qualified Data.ByteString.Char8 as BS import Data.String.Conversions (cs) import Control.Applicative ( (<*>) ) @@ -19,9 +18,9 @@ import qualified Hasql as H import qualified Hasql.Backend as H import qualified Hasql.Postgres as H -foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map BS.ByteString ForeignKey) +foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey) foreignKeys table = do - r :: [(BS.ByteString, BS.ByteString, BS.ByteString)] <- H.list $ [H.q| + r :: [(Text, Text, Text)] <- H.list $ [H.q| select kcu.column_name, ccu.table_name AS foreign_table_name, ccu.column_name AS foreign_column_name from information_schema.table_constraints AS tc @@ -39,7 +38,7 @@ foreignKeys table = do addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m -tables :: BS.ByteString -> H.Tx H.Postgres s [Table] +tables :: Text -> H.Tx H.Postgres s [Table] tables schema = H.list $ [H.q| select table_schema, table_name, @@ -85,9 +84,9 @@ columns table = do return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols -primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [BS.ByteString] +primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text] primaryKeyColumns table = do - r :: [Identity BS.ByteString] <- H.list $ [H.q| + r :: [Identity Text] <- H.list $ [H.q| select kc.column_name from information_schema.table_constraints tc, @@ -101,19 +100,6 @@ primaryKeyColumns table = do return $ map runIdentity r --- instance FromRow Table where --- fromRow = Table <$> field <*> field <*> (toBool <$> field) - --- instance FromRow Column where --- fromRow = Column <$> --- field <*> field <*> field <*> field --- <*> (toBool <$> field) --- <*> field --- <*> (toBool <$> field) --- <*> field <*> field <*> field --- <*> (vanishNull . splitOn "," <$> field) --- <*> return Nothing - vanishNull :: [a] -> Maybe [a] vanishNull xs = if L.null xs then Nothing else Just xs @@ -151,9 +137,9 @@ instance H.RowParser H.Postgres Column where table = H.parseResult $ r V.! 1 name = H.parseResult $ r V.! 2 position = H.parseResult $ r V.! 3 - nullable = H.parseResult $ r V.! 4 + nullable = toBool <$> (H.parseResult $ r V.! 4 :: Either Text Text) typ = H.parseResult $ r V.! 5 - updatable = H.parseResult $ r V.! 6 + updatable = toBool <$> (H.parseResult $ r V.! 6 :: Either Text Text) maxLen = H.parseResult $ r V.! 7 precision = H.parseResult $ r V.! 8 defValue = H.parseResult $ r V.! 9 @@ -169,7 +155,7 @@ instance H.RowParser H.Postgres Table where parseRow r = let schema = H.parseResult $ r V.! 0 name = H.parseResult $ r V.! 2 - insertable = H.parseResult $ r V.! 3 in + insertable = toBool <$> (H.parseResult $ r V.! 3 :: Either Text Text) in if V.length r /= 3 then Left "Wrong number of fields in Table" else Table <$> schema <*> name <*> insertable diff --git a/test/Main.hs b/test/Main.hs index a3380388c..115171702 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -13,7 +13,7 @@ main :: IO () main = do roles <- loadFixture "roles" schema <- loadFixture "schema" - H.session pgSettings testSettings $ do + H.session pgSettings testSettings $ H.tx Nothing $ do H.unit [H.q| drop schema if exists "1" cascade |] H.unit [H.q| drop schema if exists private cascade |] @@ -26,4 +26,4 @@ main = do loadFixture :: FilePath -> IO(H.Statement H.Postgres) loadFixture name = do query <- BS.readFile $ "test/fixtures/" ++ name ++ ".sql" - return (query, []) + return (query, [], False) From dba17b895ed8c46372b1ede0104678cc66a67a19 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 20 Nov 2014 22:27:19 -0800 Subject: [PATCH 29/45] Bye Travis, hi Circle --- .travis.yml | 20 -------------------- circle.yml | 3 +++ 2 files changed, 3 insertions(+), 20 deletions(-) delete mode 100644 .travis.yml create mode 100644 circle.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 149eb2dd3..000000000 --- a/.travis.yml +++ /dev/null @@ -1,20 +0,0 @@ -language: haskell -ghc: 7.8 -addons: - postgresql: "9.3" -before_install: - - createuser --superuser --no-password dbapi_test - - createdb -O dbapi_test -U postgres dbapi_test - - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - - travis_retry sudo apt-get update - - travis_retry sudo apt-get install --force-yes happy-1.19.3 alex-3.1.3 - - export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.3/bin:$PATH -install: - - travis_retry curl http://bin.begriffs.com/dbapi/cabal-sandbox.tar.xz | tar xJ - - chmod a+x .cabal-sandbox/bin/* - - cabal sandbox init - - cabal install --enable-test --dependencies-only - - cabal install --enable-test -script: - - cabal test --show-details=always --test-options="--color" - - .cabal-sandbox/bin/hlint src/*.hs test/**/*.hs diff --git a/circle.yml b/circle.yml new file mode 100644 index 000000000..85a4f567f --- /dev/null +++ b/circle.yml @@ -0,0 +1,3 @@ +machine: + ghc: + version: 7.8.3 From 21b0b02c03b7572fe43ef44200cf4320f26b506d Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 20 Nov 2014 23:13:48 -0800 Subject: [PATCH 30/45] Temporarily use psql to load schemas --- dbapi.cabal | 1 + test/Main.hs | 18 +++++++----------- 2 files changed, 8 insertions(+), 11 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 9250400fa..a1d446709 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -83,3 +83,4 @@ Test-Suite spec , blaze-builder , vector , mtl + , process diff --git a/test/Main.hs b/test/Main.hs index 115171702..934732564 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,28 +2,24 @@ module Main where import qualified Hasql as H -import qualified Hasql.Backend as H -import qualified Hasql.Postgres as H -import qualified Data.ByteString.Char8 as BS +import System.Process import Test.Hspec import SpecHelper import Spec main :: IO () main = do - roles <- loadFixture "roles" - schema <- loadFixture "schema" H.session pgSettings testSettings $ H.tx Nothing $ do H.unit [H.q| drop schema if exists "1" cascade |] H.unit [H.q| drop schema if exists private cascade |] H.unit [H.q| drop schema if exists dbapi cascade |] - H.unit roles - H.unit schema + + loadFixture "roles" + loadFixture "schema" hspec spec -loadFixture :: FilePath -> IO(H.Statement H.Postgres) -loadFixture name = do - query <- BS.readFile $ "test/fixtures/" ++ name ++ ".sql" - return (query, [], False) +loadFixture :: FilePath -> IO() +loadFixture name = + callProcess "psql" ["-U", "postgres", "-d", "dbapi_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] From eb7e9586abed06cb253045fc120f6162a2f1cf22 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 21 Nov 2014 21:49:54 -0800 Subject: [PATCH 31/45] Handle missing table sql errors with 404 --- src/App.hs | 15 ++++++++++++++- src/Main.hs | 12 +++++++----- test/SpecHelper.hs | 6 ++++-- 3 files changed, 25 insertions(+), 8 deletions(-) diff --git a/src/App.hs b/src/App.hs index 0f4db393a..ad8721cd3 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} -module App (app) where +module App (app, sqlErrHandler, isSqlError) where import Control.Monad (join) import Control.Arrow ((***)) import Control.Applicative import Control.Monad.IO.Class (liftIO, MonadIO) +-- import Control.Exception.Base import Data.Text hiding (map) import Data.Maybe (fromMaybe) @@ -26,6 +27,7 @@ import Data.Aeson import Data.Coerce import Data.Monoid import qualified Hasql as H +import qualified Hasql.Backend as HB import qualified Hasql.Postgres as H import PgQuery @@ -158,6 +160,17 @@ app req = allOrigins = ("Access-Control-Allow-Origin", "*") :: Header +isSqlError :: HB.Error -> Maybe HB.Error +isSqlError (HB.ErroneousResult x) = Just $ HB.ErroneousResult x +isSqlError _ = Nothing + +sqlErrHandler :: HB.Error -> IO Response +sqlErrHandler (HB.ErroneousResult err) = do + return $ if "42P01" `isInfixOf` err + then responseLBS status404 [] "" + else responseLBS status400 [] (cs err) +sqlErrHandler _ = error "just for debugging" + rangeStatus :: Int -> Int -> Int -> Status rangeStatus from to total | from > total = status416 diff --git a/src/Main.hs b/src/Main.hs index bc6ec3c8d..bd4decb9c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,6 +9,7 @@ import Middleware import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (runReaderT, ask) +import Control.Exception import Data.String.Conversions (cs) import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) @@ -44,13 +45,14 @@ main = do middle = (if configSecure conf then redirectInsecure else id) . gzip def . cors corsPolicy . clientErrors - . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in + . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) - H.session pgSettings sessSettings $ do - session' <- flip runReaderT <$> ask - let runApp req respond = respond =<< session' (app req) in + H.session pgSettings sessSettings $ do + session' <- flip runReaderT <$> ask + let runApp req respond = + respond =<< catchJust isSqlError (session' $ app req) sqlErrHandler - liftIO $ runSettings appSettings $ middle runApp + liftIO $ runSettings appSettings $ middle runApp -- . authenticated (cs $ configAnonRole conf) $ app where diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index a86d7c567..0c966ad64 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -12,6 +12,7 @@ import Data.String.Conversions (cs) import Control.Monad.Reader (runReaderT, ask) -- import Control.Monad (void) import Control.Applicative ( (<$>) ) +import Control.Exception import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization) @@ -22,7 +23,7 @@ import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS -- import Network.Wai.Middleware.Cors (cors) -import App (app) +import App (app, sqlErrHandler, isSqlError) -- import Config (corsPolicy, AppConfig(..)) -- import Auth (addUser) @@ -44,7 +45,8 @@ withApp perform = perform $ \req resp -> H.session pgSettings testSettings $ do session' <- flip runReaderT <$> ask - liftIO $ resp =<< session' (app req) + liftIO $ resp =<< catchJust isSqlError (session' $ app req) + sqlErrHandler rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] From 8e9bbe6dcb00165daeeea5afd3ea987ed3db7181 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 21 Nov 2014 23:44:38 -0800 Subject: [PATCH 32/45] Fix insert --- src/App.hs | 2 +- src/PgQuery.hs | 14 +++++++++++++- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/src/App.hs b/src/App.hs index ad8721cd3..8e2130132 100644 --- a/src/App.hs +++ b/src/App.hs @@ -130,7 +130,7 @@ app req = let vals = elems obj H.unit . coerce $ iffNotT (whereT qq $ update qt cols vals) - (insertInto qt cols vals) + (insertSelect qt cols vals) return $ responseLBS status204 [ jsonH ] "" else return $ if Prelude.null tableCols diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 14070ccf6..24c04da31 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -68,7 +68,7 @@ parentheticT (sql, params, pre) = iffNotT :: DynamicSQL -> StatementT iffNotT (aq, ap, apre) (bq, bp, bpre) = ("WITH aaa AS (" <> aq <> " returning *) " <> - bq <> "WHERE NOT EXISTS (SELECT * FROM aaa)" + bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)" , ap ++ bp , All $ getAll apre && getAll bpre ) @@ -100,6 +100,18 @@ insertInto t cols vals = , mempty ) +insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL +insertSelect t [] _ = + ("insert into " <> fromQt t <> " default values returning *", [], mempty) +insertSelect t cols vals = + ("insert into " <> fromQt t <> " (" <> + cs (intercalate ", " (map pgFmtIdent cols)) <> + ") select " <> + cs (intercalate ", " (map (const "?") vals)) + , map pgParam vals + , mempty + ) + update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL update t cols vals = ("update " <> fromQt t <> " set (" <> From dc43bcbca9c03d1c113a25e374b0d63f58162c98 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 22 Nov 2014 09:52:35 -0800 Subject: [PATCH 33/45] Silence the database fixture output from stdout --- test/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/Main.hs b/test/Main.hs index 934732564..55ce390a6 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} module Main where +import Control.Monad (void) import qualified Hasql as H import System.Process import Test.Hspec @@ -22,4 +23,4 @@ main = do loadFixture :: FilePath -> IO() loadFixture name = - callProcess "psql" ["-U", "postgres", "-d", "dbapi_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] + void $ readProcess "psql" ["-U", "postgres", "-d", "dbapi_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] From 0ebb83de3a03fe203629090cbb7c4959c26bc0a7 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 22 Nov 2014 09:52:44 -0800 Subject: [PATCH 34/45] Include cors middleware in test --- test/SpecHelper.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 0c966ad64..6be7d9157 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -21,10 +21,10 @@ import Data.CaseInsensitive (CI(..)) import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS --- import Network.Wai.Middleware.Cors (cors) +import Network.Wai.Middleware.Cors (cors) import App (app, sqlErrHandler, isSqlError) --- import Config (corsPolicy, AppConfig(..)) +import Config (corsPolicy) -- import Auth (addUser) isLeft :: Either a b -> Bool @@ -42,12 +42,14 @@ pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test" withApp :: ActionWith Application -> IO () withApp perform = - perform $ \req resp -> + perform $ middle $ \req resp -> H.session pgSettings testSettings $ do session' <- flip runReaderT <$> ask liftIO $ resp =<< catchJust isSqlError (session' $ app req) sqlErrHandler + where middle = cors corsPolicy + rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] From ca4138df2aee0549c67dbbd59a7015917fca46de Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 22 Nov 2014 17:50:49 -0800 Subject: [PATCH 35/45] Send back Location header on insert --- src/App.hs | 14 ++++++++++---- src/PgQuery.hs | 7 ++++++- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/src/App.hs b/src/App.hs index 8e2130132..6d29b5513 100644 --- a/src/App.hs +++ b/src/App.hs @@ -15,6 +15,7 @@ import Data.Ranged.Ranges (emptyRange) import Data.HashMap.Strict (keys, elems, filterWithKey, toList) import Data.String.Conversions (cs) import Data.List (sortBy) +import Data.Functor.Identity import qualified Data.Set as S import Network.HTTP.Types.Status @@ -104,12 +105,17 @@ app req = ([table], "POST") -> handleJsonObj req $ \obj -> H.tx Nothing $ do let qt = QualifiedTable schema (cs table) - H.unit . coerce $ insertInto qt (map cs $ keys obj) (elems obj) + query = coerce $ + insertInto qt (map cs $ keys obj) (elems obj) + row <- H.single query + let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row + Just inserted = decode (cs insertedJson) :: Maybe Object + primaryKeys <- map cs <$> primaryKeyColumns qt - let primaries = filterWithKey (const . (`elem` primaryKeys)) obj + let primaries = filterWithKey (const . (`elem` primaryKeys)) inserted let params = urlEncodeVars $ map (\t -> (cs $ fst t, "eq." <> cs (encode $ snd t))) - $ toList primaries + $ sortBy (comparing fst) $ toList primaries return $ responseLBS status201 [ jsonH , (hLocation, "/" <> cs table <> "?" <> cs params) @@ -165,7 +171,7 @@ isSqlError (HB.ErroneousResult x) = Just $ HB.ErroneousResult x isSqlError _ = Nothing sqlErrHandler :: HB.Error -> IO Response -sqlErrHandler (HB.ErroneousResult err) = do +sqlErrHandler (HB.ErroneousResult err) = return $ if "42P01" `isInfixOf` err then responseLBS status404 [] "" else responseLBS status400 [] (cs err) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 24c04da31..0651029ac 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -83,6 +83,11 @@ asJsonWithCount (sql, params, pre) = ( , params, pre ) +asJsonRow :: StatementT +asJsonRow (sql, params, pre) = ( + "row_to_json(t) from (" <> sql <> ") t", params, pre + ) + selectStar :: QualifiedTable -> DynamicSQL selectStar t = ("select * from " <> fromQt t, [], mempty) @@ -95,7 +100,7 @@ insertInto t cols vals = cs (intercalate ", " (map pgFmtIdent cols)) <> ") values (" <> cs (intercalate ", " (map (const "?") vals)) <> - ")" + ") returning row_to_json(" <> fromQt t <> ".*)" , map pgParam vals , mempty ) From e3d3a07d14b99bd626206c707f8b03430ba0db50 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 22 Nov 2014 18:52:19 -0800 Subject: [PATCH 36/45] Fun, fun, offbyone --- src/App.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/App.hs b/src/App.hs index 6d29b5513..13aed805c 100644 --- a/src/App.hs +++ b/src/App.hs @@ -71,7 +71,7 @@ app req = let (tableTotal, queryTotal, body) = fromMaybe (0, 0, Just "" :: Maybe Text) row from = fromMaybe 0 $ rangeOffset <$> range - to = from+queryTotal + to = from+queryTotal-1 contentRange = contentRangeH from to tableTotal status = rangeStatus from to tableTotal canonical = urlEncodeVars From 42faaa97c96b856ef93b67e7735051a5ba1f897d Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 22 Nov 2014 22:06:39 -0800 Subject: [PATCH 37/45] Include all fields in Location header when no primary keys defined --- src/App.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/App.hs b/src/App.hs index 13aed805c..d46466671 100644 --- a/src/App.hs +++ b/src/App.hs @@ -112,7 +112,9 @@ app req = Just inserted = decode (cs insertedJson) :: Maybe Object primaryKeys <- map cs <$> primaryKeyColumns qt - let primaries = filterWithKey (const . (`elem` primaryKeys)) inserted + let primaries = if Prelude.null primaryKeys + then inserted + else filterWithKey (const . (`elem` primaryKeys)) inserted let params = urlEncodeVars $ map (\t -> (cs $ fst t, "eq." <> cs (encode $ snd t))) $ sortBy (comparing fst) $ toList primaries From f1ecbec543610e47cd9ec86a0796a5a5d5807754 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 26 Nov 2014 21:36:26 -0800 Subject: [PATCH 38/45] Do not quote params in Location header Also treat the enum field in OPTIONS as an array uniformly --- src/App.hs | 8 ++++- src/Auth.hs | 18 ++++++++---- src/PgStructure.hs | 16 ++++++---- test/Feature/QuerySpec.hs | 13 --------- .../{StructureSpec.hx => StructureSpec.hs} | 29 +++++++++---------- test/Main.hs | 2 +- 6 files changed, 44 insertions(+), 42 deletions(-) rename test/Feature/{StructureSpec.hx => StructureSpec.hs} (90%) diff --git a/src/App.hs b/src/App.hs index d46466671..785367f12 100644 --- a/src/App.hs +++ b/src/App.hs @@ -116,7 +116,7 @@ app req = then inserted else filterWithKey (const . (`elem` primaryKeys)) inserted let params = urlEncodeVars - $ map (\t -> (cs $ fst t, "eq." <> cs (encode $ snd t))) + $ map (\t -> (cs $ fst t, "eq." <> cs (unquoted $ snd t))) $ sortBy (comparing fst) $ toList primaries return $ responseLBS status201 [ jsonH @@ -224,6 +224,12 @@ handleJsonObj req handler = do jErr = encode . object $ [("error", String "Expecting a JSON object")] +unquoted :: Value -> Text +unquoted (String t) = t +unquoted (Number n) = cs . show $ n +unquoted (Bool b) = cs . show $ b +unquoted _ = "" + data TableOptions = TableOptions { tblOptcolumns :: [Column] , tblOptpkey :: [Text] diff --git a/src/Auth.hs b/src/Auth.hs index 4b87243b5..4e86d31fd 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} module Auth where -import qualified Data.Aeson as JSON +import Data.Aeson import Control.Monad (mzero) import Control.Applicative ( (<*>), (<$>) ) import Crypto.BCrypt @@ -16,13 +16,19 @@ data AuthUser = AuthUser { , userRole :: String } -instance JSON.FromJSON AuthUser where - parseJSON (JSON.Object v) = AuthUser <$> - v JSON..: "id" <*> - v JSON..: "pass" <*> - v JSON..: "role" +instance FromJSON AuthUser where + parseJSON (Object v) = AuthUser <$> + v .: "id" <*> + v .: "pass" <*> + v .: "role" parseJSON _ = mzero +instance ToJSON AuthUser where + toJSON u = object [ + "id" .= userId u + , "pass" .= userPass u + , "role" .= userRole u ] + type DbRole = Text data LoginAttempt = diff --git a/src/PgStructure.hs b/src/PgStructure.hs index 89e85c58c..cff646428 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE QuasiQuotes, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes, OverloadedStrings, + MultiParamTypeClasses, ScopedTypeVariables #-} module PgStructure where import PgQuery (QualifiedTable(..)) @@ -127,7 +128,7 @@ data Column = Column { , colMaxLen :: Maybe Int , colPrecision :: Maybe Int , colDefault :: Maybe Text -, colEnum :: Maybe [Text] +, colEnum :: [Text] , colFK :: Maybe ForeignKey } deriving (Show) @@ -143,19 +144,22 @@ instance H.RowParser H.Postgres Column where maxLen = H.parseResult $ r V.! 7 precision = H.parseResult $ r V.! 8 defValue = H.parseResult $ r V.! 9 - enum = H.parseResult $ r V.! 10 in + enum = either (const $ Right []) (Right . split (==',')) + (H.parseResult $ r V.! 10 :: Either Text Text) + in if V.length r /= 11 then Left "Wrong number of fields in Column" else Column <$> schema <*> table <*> name <*> position <*> nullable <*> typ <*> updatable <*> maxLen <*> precision - <*> defValue <*> enum <*> return Nothing + <*> defValue <*> enum + <*> return Nothing instance H.RowParser H.Postgres Table where parseRow r = let schema = H.parseResult $ r V.! 0 - name = H.parseResult $ r V.! 2 - insertable = toBool <$> (H.parseResult $ r V.! 3 :: Either Text Text) in + name = H.parseResult $ r V.! 1 + insertable = toBool <$> (H.parseResult $ r V.! 2 :: Either Text Text) in if V.length r /= 3 then Left "Wrong number of fields in Table" else Table <$> schema <*> name <*> insertable diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 5de26a271..f423486cc 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -5,19 +5,6 @@ import Test.Hspec.Wai import SpecHelper --- around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec --- type Spec = SpecWith () --- type ActionWith a = a -> IO () --- --- get :: ByteString -> WaiSession SResponse --- newtype WaiSession a = WaiSession {unWaiSession :: Session a} --- type Session = ReaderT Application (StateT ClientState IO) --- --- type Application = --- Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived --- --- runApp :: Request -> (Response -> IO Postgres) -> IO Postgres - spec :: Spec spec = around withApp $ do describe "Querying a nonexistent table" $ diff --git a/test/Feature/StructureSpec.hx b/test/Feature/StructureSpec.hs similarity index 90% rename from test/Feature/StructureSpec.hx rename to test/Feature/StructureSpec.hs index 7ef6471f3..73b0c139f 100644 --- a/test/Feature/StructureSpec.hx +++ b/test/Feature/StructureSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} module Feature.StructureSpec where import Test.Hspec @@ -13,14 +13,13 @@ import Data.Monoid ((<>)) import Data.String.Conversions (cs) spec :: Spec -spec = let {uName = "a user"; uPass = "nobody can ever know"; -uRole = "dbapi_test"} in - around withDatabaseConnection $ - aroundWith (withUser uName uPass uRole) $ aroundWith withApp $ do +spec = around withApp $ do + let uName = "a user" + uPass = "nobody can ever know" describe "GET /" $ it "lists views in schema" $ request methodGet "/" - [("Authorization", "Basic "<>(cs.encode $ cs uName<>":"<>cs uPass))] "" + [("Authorization", "Basic "<>(uName<>":"<>uPass))] "" `shouldRespondWith` [json| [ {"schema":"1","name":"authors_only","insertable":true} , {"schema":"1","name":"auto_incrementing_pk","insertable":true} @@ -48,7 +47,7 @@ uRole = "dbapi_test"} in "name": "integer", "type": "integer", "maxLen": null, - "enum": null, + "enum": [], "nullable": false, "position": 1, "references": null, @@ -61,7 +60,7 @@ uRole = "dbapi_test"} in "name": "double", "type": "double precision", "maxLen": null, - "enum": null, + "enum": [], "nullable": false, "references": null, "position": 2 @@ -73,7 +72,7 @@ uRole = "dbapi_test"} in "name": "varchar", "type": "character varying", "maxLen": null, - "enum": null, + "enum": [], "nullable": false, "position": 3, "references": null, @@ -86,7 +85,7 @@ uRole = "dbapi_test"} in "name": "boolean", "type": "boolean", "maxLen": null, - "enum": null, + "enum": [], "nullable": false, "references": null, "position": 4 @@ -98,7 +97,7 @@ uRole = "dbapi_test"} in "name": "date", "type": "date", "maxLen": null, - "enum": null, + "enum": [], "nullable": false, "references": null, "position": 5 @@ -110,7 +109,7 @@ uRole = "dbapi_test"} in "name": "money", "type": "money", "maxLen": null, - "enum": null, + "enum": [], "nullable": false, "position": 6, "references": null, @@ -153,7 +152,7 @@ uRole = "dbapi_test"} in "maxLen": null, "nullable": false, "position": 1, - "enum": null, + "enum": [], "references": null }, { "default": null, @@ -165,7 +164,7 @@ uRole = "dbapi_test"} in "maxLen": null, "nullable": true, "position": 2, - "enum": null, + "enum": [], "references": {"table": "auto_incrementing_pk", "column": "id"} }, { "default": null, @@ -177,7 +176,7 @@ uRole = "dbapi_test"} in "maxLen": 255, "nullable": true, "position": 3, - "enum": null, + "enum": [], "references": {"table": "simple_pk", "column": "k"} } ] diff --git a/test/Main.hs b/test/Main.hs index 55ce390a6..ac0a2cf82 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -23,4 +23,4 @@ main = do loadFixture :: FilePath -> IO() loadFixture name = - void $ readProcess "psql" ["-U", "postgres", "-d", "dbapi_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] + void $ readProcess "psql" ["-U", "dbapi_test", "-d", "dbapi_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] From 4eb4d8da1e68041263627bc54dd613b358e158b5 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 26 Nov 2014 21:41:51 -0800 Subject: [PATCH 39/45] Removed test for RFC compliance Who would send Content-Range anyway, that is weird in this context --- test/Feature/InsertSpec.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index df5d56593..a70e565f6 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -94,13 +94,6 @@ spec = around withApp $ do context "with a fully-specified primary key" $ do - context "with Content-Range header" $ - it "fails as per RFC7231" $ - request methodPut "/compound_pk?k1=eq.1&k2=eq.2" - [("Content-Range", "0-0")] - [json| { "k1":1, "k2":2, "extra":3 } |] - `shouldRespondWith` 400 - context "not specifying every column in the table" $ it "is rejected for lack of idempotence" $ request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] From 5900475460e2a1792d53b832a1a725a749daa41f Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 29 Nov 2014 13:26:26 -0800 Subject: [PATCH 40/45] Reset db between tests rather than using transactions to accomodate Hasql limitation --- dbapi.cabal | 2 +- test/Feature/InsertSpec.hs | 5 +---- test/Main.hs | 26 -------------------------- test/Spec.hs | 2 +- test/SpecHelper.hs | 23 ++++++++++++++++++++++- 5 files changed, 25 insertions(+), 33 deletions(-) delete mode 100644 test/Main.hs diff --git a/dbapi.cabal b/dbapi.cabal index a1d446709..5f8ec1a63 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -54,7 +54,7 @@ Test-Suite spec other-extensions: QuasiQuotes Hs-Source-Dirs: test, src ghc-options: -Wall -W -Werror - Main-Is: Main.hs + Main-Is: Spec.hs Other-Modules: App, Auth, Config, Spec, SpecHelper Build-Depends: base, hspec >= 2.0, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index a70e565f6..f0d1133fc 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} module Feature.InsertSpec where --- {{{ Imports import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON @@ -17,10 +16,8 @@ import Control.Monad (replicateM_) import TestTypes(IncPK(..), CompoundPK(..)) --- }}} - spec :: Spec -spec = around withApp $ do +spec = before resetDb $ around withApp $ do describe "Posting new record" $ do it "accepts disparate json types" $ post "/menagerie" diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 index ac0a2cf82..000000000 --- a/test/Main.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Main where - -import Control.Monad (void) -import qualified Hasql as H -import System.Process -import Test.Hspec -import SpecHelper -import Spec - -main :: IO () -main = do - H.session pgSettings testSettings $ - H.tx Nothing $ do - H.unit [H.q| drop schema if exists "1" cascade |] - H.unit [H.q| drop schema if exists private cascade |] - H.unit [H.q| drop schema if exists dbapi cascade |] - - loadFixture "roles" - loadFixture "schema" - - hspec spec - -loadFixture :: FilePath -> IO() -loadFixture name = - void $ readProcess "psql" ["-U", "dbapi_test", "-d", "dbapi_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] diff --git a/test/Spec.hs b/test/Spec.hs index b4e92e756..a824f8c30 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1 +1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 6be7d9157..88331e21f 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} + module SpecHelper where import Network.Wai @@ -10,7 +12,7 @@ import Hasql.Postgres as H import Data.String.Conversions (cs) -- import Control.Exception.Base (bracket, finally) import Control.Monad.Reader (runReaderT, ask) --- import Control.Monad (void) +import Control.Monad (void) import Control.Applicative ( (<$>) ) import Control.Exception @@ -22,6 +24,7 @@ import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import Network.Wai.Middleware.Cors (cors) +import System.Process (readProcess) import App (app, sqlErrHandler, isSqlError) import Config (corsPolicy) @@ -50,6 +53,24 @@ withApp perform = where middle = cors corsPolicy + +resetDb :: IO () +resetDb = do + H.session pgSettings testSettings $ + H.tx Nothing $ do + H.unit [H.q| drop schema if exists "1" cascade |] + H.unit [H.q| drop schema if exists private cascade |] + H.unit [H.q| drop schema if exists dbapi cascade |] + + loadFixture "roles" + loadFixture "schema" + + +loadFixture :: FilePath -> IO() +loadFixture name = + void $ readProcess "psql" ["-U", "dbapi_test", "-d", "dbapi_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] + + rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] From fb6e297e8850114a3fb860454c3a8354d0483bbf Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 29 Nov 2014 14:21:56 -0800 Subject: [PATCH 41/45] Do not include .0 on integers in generated links --- src/App.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/App.hs b/src/App.hs index 785367f12..bf1359c7c 100644 --- a/src/App.hs +++ b/src/App.hs @@ -16,6 +16,7 @@ import Data.HashMap.Strict (keys, elems, filterWithKey, toList) import Data.String.Conversions (cs) import Data.List (sortBy) import Data.Functor.Identity +import Data.Scientific (isInteger, formatScientific, FPFormat(..)) import qualified Data.Set as S import Network.HTTP.Types.Status @@ -226,7 +227,8 @@ handleJsonObj req handler = do unquoted :: Value -> Text unquoted (String t) = t -unquoted (Number n) = cs . show $ n +unquoted (Number n) = + cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n unquoted (Bool b) = cs . show $ b unquoted _ = "" From 13bc9a45103dd26678bab629168d0f08c45ec57a Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Tue, 2 Dec 2014 19:18:02 -0800 Subject: [PATCH 42/45] Lock hasql version for now --- dbapi.cabal | 4 ++-- test/Feature/InsertSpec.hs | 10 +++++++--- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 5f8ec1a63..e3009fc98 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -16,7 +16,7 @@ executable dbapi default-extensions: OverloadedStrings other-extensions: QuasiQuotes build-depends: base >=4.6 && <5 - , hasql >= 0.2.0, hasql-backend, hasql-postgres + , hasql >= 0.2.3 && < 0.3.0, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 @@ -58,7 +58,7 @@ Test-Suite spec Other-Modules: App, Auth, Config, Spec, SpecHelper Build-Depends: base, hspec >= 2.0, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json - , hasql >= 0.2.0, hasql-backend, hasql-postgres + , hasql >= 0.2.3 && < 0.3.0, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , HTTP, convertible , case-insensitive diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index f0d1133fc..f27223779 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -16,17 +16,21 @@ import Control.Monad (replicateM_) import TestTypes(IncPK(..), CompoundPK(..)) +--import Debug.Trace + spec :: Spec spec = before resetDb $ around withApp $ do describe "Posting new record" $ do - it "accepts disparate json types" $ - post "/menagerie" + it "accepts disparate json types" $ do + p <- post "/menagerie" [json| { "integer": 13, "double": 3.14159, "varchar": "testing!" , "boolean": false, "date": "01/01/1900", "money": "$3.99" , "enum": "foo" } |] - `shouldRespondWith` 201 + liftIO $ do + simpleBody p `shouldBe` "" + simpleStatus p `shouldBe` created201 context "with no pk supplied" $ do context "into a table with auto-incrementing pk" $ From a45718e9926eb2db762df395f0bc21560257d161 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Tue, 2 Dec 2014 22:14:01 -0800 Subject: [PATCH 43/45] Re-enable authentication --- src/App.hs | 2 +- src/Auth.hs | 17 +++++---- src/Main.hs | 5 +-- src/Middleware.hs | 67 +++++++++++++++++++---------------- test/Feature/StructureSpec.hs | 19 ++++------ test/SpecHelper.hs | 12 ++++--- 6 files changed, 65 insertions(+), 57 deletions(-) diff --git a/src/App.hs b/src/App.hs index bf1359c7c..fa589da77 100644 --- a/src/App.hs +++ b/src/App.hs @@ -96,7 +96,7 @@ app req = Nothing -> return $ responseLBS status400 [jsonH] $ encode . object $ [("error", String "Failed to parse user.")] Just u -> do - _ <- liftIO $ addUser (cs $ userId u) + _ <- addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) return $ responseLBS status201 [ jsonH diff --git a/src/Auth.hs b/src/Auth.hs index 4e86d31fd..87add40f0 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -1,20 +1,23 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} module Auth where import Data.Aeson import Control.Monad (mzero) import Control.Applicative ( (<*>), (<$>) ) +import Control.Monad.IO.Class (liftIO) import Crypto.BCrypt import Data.Text +import Data.Monoid import qualified Hasql as H import qualified Hasql.Postgres as H import Data.String.Conversions (cs) +import PgQuery (pgFmtLit) data AuthUser = AuthUser { userId :: String , userPass :: String , userRole :: String - } + } deriving (Show) instance FromJSON AuthUser where parseJSON (Object v) = AuthUser <$> @@ -42,17 +45,17 @@ checkPass :: Text -> Text -> Bool checkPass = (. cs) . validatePassword . cs setRole :: Text -> H.Tx H.Postgres s () -setRole role = H.unit $ [H.q| set role ?|] role +setRole role = H.unit ("set role " <> cs (pgFmtLit role), [], True) resetRole :: H.Tx H.Postgres s () resetRole = H.unit [H.q|reset role|] -addUser :: Text -> Text -> Text -> IO(H.Tx H.Postgres s ()) +addUser :: Text -> Text -> Text -> H.Session H.Postgres IO () addUser identity pass role = do - Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) - return $ H.unit $ + Just hashed <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) + H.tx Nothing $ H.unit $ [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|] - identity hashed role + identity (cs hashed :: Text) role signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt signInRole user pass = do diff --git a/src/Main.hs b/src/Main.hs index bd4decb9c..890f2a567 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,6 @@ module Main where import Paths_dbapi (version) import App ---import Auth import Middleware import Control.Monad (unless) @@ -50,7 +49,9 @@ main = do H.session pgSettings sessSettings $ do session' <- flip runReaderT <$> ask let runApp req respond = - respond =<< catchJust isSqlError (session' $ app req) sqlErrHandler + respond =<< catchJust isSqlError + (session' $ authenticated (cs $ configAnonRole conf) app req) + sqlErrHandler liftIO $ runSettings appSettings $ middle runApp -- . authenticated (cs $ configAnonRole conf) $ app diff --git a/src/Middleware.hs b/src/Middleware.hs index 519984964..85529de2d 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -3,23 +3,25 @@ module Middleware where --import Data.Aeson ((.=), toJSON, ToJSON, object, encode) --- import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) +import Data.Text -- import Data.Pool(withResource, Pool) import qualified Hasql as H +import qualified Hasql.Postgres as H import Data.String.Conversions(cs) ---import qualified Data.ByteString.Char8 as BS import Control.Exception (catchJust) -import Network.HTTP.Types.Header (hLocation, hContentType) -import Network.HTTP.Types.Status (status400, status301) +import Network.HTTP.Types.Header (hLocation, hContentType, hAuthorization) +import Network.HTTP.Types (RequestHeaders) +import Network.HTTP.Types.Status (status400, status401, status301) import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, - rawQueryString, isSecure) + rawQueryString, isSecure, Request(..), Response) import Network.URI (URI(..), parseURI) --- import Auth (LoginAttempt(..), signInRole, setRole, resetRole) --- import Codec.Binary.Base64.String (decode) +import Auth (LoginAttempt(..), signInRole, setRole, resetRole) +import Codec.Binary.Base64.String (decode) import Debug.Trace @@ -36,30 +38,35 @@ import Debug.Trace -- else Database.PostgreSQL.Simple.withSavepoint conn go -- where go = app conn req respond --- authenticated :: BS.ByteString -> (Connection -> Application) -> --- Connection -> Application --- authenticated anon app conn req respond = do --- attempt <- httpRequesterRole (requestHeaders req) --- case attempt of --- MalformedAuth -> --- respond $ responseLBS status400 [] "Malformed basic auth header" --- LoginFailed -> --- respond $ responseLBS status401 [] "Invalid username or password" --- LoginSuccess role -> --- bracket_ (setRole conn role) (resetRole conn) $ app conn req respond --- NoCredentials -> --- bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond +authenticated :: Text -> (Request -> H.Session H.Postgres IO Response) -> + Request -> H.Session H.Postgres IO Response +authenticated anon app req = do + attempt <- httpRequesterRole (requestHeaders req) + case attempt of + MalformedAuth -> + return $ responseLBS status400 [] "Malformed basic auth header" + LoginFailed -> + return $ responseLBS status401 [] "Invalid username or password" + LoginSuccess role -> runInRole role + NoCredentials -> runInRole anon --- where --- httpRequesterRole :: RequestHeaders -> IO LoginAttempt --- httpRequesterRole hdrs = do --- let auth = fromMaybe "" $ lookup hAuthorization hdrs --- case BS.split ' ' (cs auth) of --- ("Basic" : b64 : _) -> --- case BS.split ':' $ cs (decode $ cs b64) of --- (u:p:_) -> signInRole conn u p --- _ -> return MalformedAuth --- _ -> return NoCredentials + where + httpRequesterRole :: RequestHeaders -> H.Session H.Postgres IO LoginAttempt + httpRequesterRole hdrs = do + let auth = fromMaybe "" $ lookup hAuthorization hdrs + case split (==' ') (cs auth) of + ("Basic" : b64 : _) -> + case split (==':') (cs . decode . cs $ b64) of + (u:p:_) -> H.tx Nothing $ signInRole u p + _ -> return MalformedAuth + _ -> return NoCredentials + + runInRole :: Text -> H.Session H.Postgres IO Response + runInRole r = do + H.tx Nothing $ setRole r + resp <- app req + H.tx Nothing resetRole + return resp -- instance ToJSON SqlError where -- toJSON t = object [ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 73b0c139f..17998e0e1 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -8,21 +8,17 @@ import Test.Hspec.Wai.JSON import SpecHelper import Network.HTTP.Types -import Codec.Binary.Base64.String (encode) -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) spec :: Spec spec = around withApp $ do - let uName = "a user" - uPass = "nobody can ever know" describe "GET /" $ - it "lists views in schema" $ - request methodGet "/" - [("Authorization", "Basic "<>(uName<>":"<>uPass))] "" + it "lists views in schema" $ do + _ <- post "/dbapi/users" [json| { "id":"jdoe", "pass": "1234", "role": "dbapi_test_author" } |] + let auth = authHeader "jdoe" "1234" + + request methodGet "/" [auth] "" `shouldRespondWith` [json| [ - {"schema":"1","name":"authors_only","insertable":true} - , {"schema":"1","name":"auto_incrementing_pk","insertable":true} + {"schema":"1","name":"auto_incrementing_pk","insertable":true} , {"schema":"1","name":"compound_pk","insertable":true} , {"schema":"1","name":"has_fk","insertable":true} , {"schema":"1","name":"items","insertable":true} @@ -136,8 +132,7 @@ spec = around withApp $ do |] it "includes foreign key data" $ - request methodOptions "/has_fk" - [("Authorization", "Basic "<>(cs.encode $ cs uName<>":"<>cs uPass))] "" + request methodOptions "/has_fk" [] "" `shouldRespondWith` [json| { "pkey": ["id"], diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 88331e21f..12fd93049 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -27,15 +27,16 @@ import Network.Wai.Middleware.Cors (cors) import System.Process (readProcess) import App (app, sqlErrHandler, isSqlError) -import Config (corsPolicy) +import Config (AppConfig(..), corsPolicy) +import Middleware -- import Auth (addUser) isLeft :: Either a b -> Bool isLeft (Left _ ) = True isLeft _ = False --- cfg :: AppConfig --- cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10 +cfg :: AppConfig +cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10 testSettings :: SessionSettings testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30 @@ -48,8 +49,9 @@ withApp perform = perform $ middle $ \req resp -> H.session pgSettings testSettings $ do session' <- flip runReaderT <$> ask - liftIO $ resp =<< catchJust isSqlError (session' $ app req) - sqlErrHandler + liftIO $ resp =<< catchJust isSqlError + (session' $ authenticated (cs $ configAnonRole cfg) app req) + sqlErrHandler where middle = cors corsPolicy From 7d58097449f2624c394fd7a653a507abae13b41c Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 6 Dec 2014 14:37:46 -0800 Subject: [PATCH 44/45] Be sure to reset db before ALL tests --- README.md | 2 +- circle.yml | 3 +++ dbapi.cabal | 2 +- test/Feature/AuthSpec.hs | 2 +- test/Feature/CorsSpec.hs | 2 +- test/Feature/QuerySpec.hs | 2 +- test/Feature/RangeSpec.hs | 2 +- test/Feature/StructureSpec.hs | 2 +- test/SpecHelper.hs | 2 +- 9 files changed, 11 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 1ad9b7ac6..370ab8a82 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ ## Serve a RESTful API from any Postgres database -[![Build Status](https://travis-ci.org/begriffs/postrest.svg?branch=master)](https://travis-ci.org/begriffs/dbapi) +![Build Status](https://circleci.com/gh/begriffs/postgrest.png?circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2) ### Installation diff --git a/circle.yml b/circle.yml index 85a4f567f..fd146bd94 100644 --- a/circle.yml +++ b/circle.yml @@ -1,3 +1,6 @@ machine: + pre: + - createuser --superuser --no-password dbapi_test + - createdb -O dbapi_test -U ubuntu dbapi_test ghc: version: 7.8.3 diff --git a/dbapi.cabal b/dbapi.cabal index e3009fc98..02737d805 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -1,5 +1,5 @@ name: dbapi -version: 0.2.4.5 +version: 0.2.4.6 synopsis: The database is your api license: MIT license-file: LICENSE diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index 91198be1b..f2e4cf38d 100644 --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -11,7 +11,7 @@ import SpecHelper -- }}} spec :: Spec -spec = around withApp $ +spec = before resetDb $ around withApp $ describe "authorization" $ do it "hides tables that anonymous does not own" $ get "/authors_only" `shouldRespondWith` 400 -- TODO: should be 404 diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs index a08a64d9f..33c518cd5 100644 --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -12,7 +12,7 @@ import Network.HTTP.Types -- }}} spec :: Spec -spec = around withApp $ +spec = before resetDb $ around withApp $ describe "CORS" $ do let preflightHeaders = [ ("Accept", "*/*"), diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index f423486cc..1d477b3de 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -6,7 +6,7 @@ import Test.Hspec.Wai import SpecHelper spec :: Spec -spec = around withApp $ do +spec = before resetDb $ around withApp $ do describe "Querying a nonexistent table" $ it "causes a 404" $ get "/faketable" `shouldRespondWith` 404 diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index e9909556f..dc31279da 100644 --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -8,7 +8,7 @@ import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus)) import SpecHelper spec :: Spec -spec = around withApp $ +spec = before resetDb $ around withApp $ describe "GET /items" $ do context "without range headers" $ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 17998e0e1..f27a7e046 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -10,7 +10,7 @@ import SpecHelper import Network.HTTP.Types spec :: Spec -spec = around withApp $ do +spec = before resetDb $ around withApp $ do describe "GET /" $ it "lists views in schema" $ do _ <- post "/dbapi/users" [json| { "id":"jdoe", "pass": "1234", "role": "dbapi_test_author" } |] diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 12fd93049..74eb9bfa7 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} module SpecHelper where From 605372f8298d570e0d70ce1beed911495bae059d Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 6 Dec 2014 16:17:50 -0800 Subject: [PATCH 45/45] Set permissions correctly for structure spec --- test/Feature/StructureSpec.hs | 20 ++++++++++++++------ test/fixtures/schema.sql | 5 +++++ 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index f27a7e046..d9393dac9 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -11,12 +11,9 @@ import Network.HTTP.Types spec :: Spec spec = before resetDb $ around withApp $ do - describe "GET /" $ - it "lists views in schema" $ do - _ <- post "/dbapi/users" [json| { "id":"jdoe", "pass": "1234", "role": "dbapi_test_author" } |] - let auth = authHeader "jdoe" "1234" - - request methodGet "/" [auth] "" + describe "GET /" $ do + it "lists views in schema" $ + request methodGet "/" [] "" `shouldRespondWith` [json| [ {"schema":"1","name":"auto_incrementing_pk","insertable":true} , {"schema":"1","name":"compound_pk","insertable":true} @@ -28,6 +25,17 @@ spec = before resetDb $ around withApp $ do ] |] {matchStatus = 200} + it "lists only views user has permission to see" $ do + _ <- post "/dbapi/users" [json| { "id":"jdoe", "pass": "1234", "role": "dbapi_test_author" } |] + let auth = authHeader "jdoe" "1234" + + request methodGet "/" [auth] "" + `shouldRespondWith` [json| [ + {"schema":"1","name":"authors_only","insertable":true} + ] |] + {matchStatus = 200} + + describe "Table info" $ do it "is available with OPTIONS verb" $ request methodOptions "/menagerie" [] "" `shouldRespondWith` diff --git a/test/fixtures/schema.sql b/test/fixtures/schema.sql index 556fdf802..44a90c2aa 100755 --- a/test/fixtures/schema.sql +++ b/test/fixtures/schema.sql @@ -741,6 +741,11 @@ GRANT ALL ON TABLE compound_pk TO dbapi_test; GRANT ALL ON TABLE compound_pk TO dbapi_anonymous; +REVOKE ALL ON TABLE has_fk FROM PUBLIC; +REVOKE ALL ON TABLE has_fk FROM dbapi_test; +GRANT ALL ON TABLE has_fk TO dbapi_test; +GRANT ALL ON TABLE has_fk TO dbapi_anonymous; + -- -- TOC entry 2328 (class 0 OID 0) -- Dependencies: 197