jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Use Text for textual data

Browse Source 
Also upgrade Hasql
This commit is contained in:
Joe Nelson
2014-12-06 17:42:20 -08:00
parent f6b7b42d75
commit d6e3526bff
6 changed files with 88 additions and 95 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dbapi.cabal
+3 -3
View File
@@ -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
src/App.hs
+10 -9
View File
@@ -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")
src/Auth.hs
+9 -8
View File
@@ -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 ->
src/PgQuery.hs
+56 -51
View File
@@ -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
src/PgStructure.hs
+8 -22
View File
@@ -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
test/Main.hs
+2 -2
View File
@@ -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)