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

One string conversion to rule them all

Browse Source
This commit is contained in:
Joe Nelson
2014-09-28 10:41:37 -07:00
parent 37f2aef212
commit 29d278f6bd
5 changed files with 32 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dbapi.cabal
+2
View File
@@ -24,6 +24,7 @@ executable dbapi
, optparse-applicative >= 0.9.1 && < 0.10 , optparse-applicative >= 0.9.1 && < 0.10
, unordered-containers , unordered-containers
, regex-base , regex-base
, string-conversions
, http-media, regex-tdfa , http-media, regex-tdfa
, Ranged-sets , Ranged-sets
, transformers , transformers
@@ -53,6 +54,7 @@ Test-Suite spec
, text, optparse-applicative , text, optparse-applicative
, unordered-containers , unordered-containers
, regex-base , regex-base
, string-conversions
, http-media, regex-tdfa , http-media, regex-tdfa
, Ranged-sets , Ranged-sets
, transformers , transformers
src/Dbapi.hs
+19 -21
View File
@@ -27,8 +27,8 @@ import Network.HTTP.Base (urlEncodeVars)
import Network.Wai import Network.Wai
import Network.Wai.Internal import Network.Wai.Internal
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.String.Conversions (cs)
import Database.HDBC.PostgreSQL (Connection) import Database.HDBC.PostgreSQL (Connection)
import Database.HDBC.Types (SqlError, seErrorMsg) import Database.HDBC.Types (SqlError, seErrorMsg)
@@ -36,8 +36,6 @@ import PgStructure (printTables, printColumns, primaryKeyColumns,
columns, Column(colName)) columns, Column(colName))
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
import Data.Text (pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import PgQuery import PgQuery
import RangeQuery import RangeQuery
@@ -57,7 +55,7 @@ jsonBodyAction req handler = do
parse <- jsonBody req parse <- jsonBody req
case parse of case parse of
Left err -> return $ responseLBS status400 [jsonContentType] json Left err -> return $ responseLBS status400 [jsonContentType] json
where json = JSON.encode . JSON.object $ [("error", JSON.String $ pack err)] where json = JSON.encode . JSON.object $ [("error", JSON.String $ cs err)]
Right body -> handler body Right body -> handler body
jsonBody :: Request -> IO (Either String SqlRow) jsonBody :: Request -> IO (Either String SqlRow)
@@ -77,37 +75,37 @@ app conn req respond = do
([table], "OPTIONS") -> ([table], "OPTIONS") ->
responseLBS status200 [jsonContentType] <$> responseLBS status200 [jsonContentType] <$>
printColumns ver (unpack table) conn printColumns ver (cs table) conn
([table], "GET") -> ([table], "GET") ->
if range == Just emptyRange if range == Just emptyRange
then return $ responseLBS status416 [] "HTTP Range error" then return $ responseLBS status416 [] "HTTP Range error"
else do else do
r <- respondWithRangedResult <$> getRows ver (unpack table) qq range conn r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn
let canonical = urlEncodeVars $ sort $ let canonical = urlEncodeVars $ sort $
map (join (***) BS.unpack) $ map (join (***) cs) $
parseSimpleQuery $ parseSimpleQuery $
rawQueryString req rawQueryString req
return $ addHeaders [ return $ addHeaders [
("Content-Location", ("Content-Location",
"/" <> encodeUtf8 table <> "?" <> BS.pack canonical "/" <> cs table <> "?" <> cs canonical
)] r )] r
([table], "POST") -> ([table], "POST") ->
jsonBodyAction req (\row -> do jsonBodyAction req (\row -> do
allvals <- insert ver table row conn allvals <- insert ver table row conn
keys <- primaryKeyColumns ver (unpack table) conn keys <- primaryKeyColumns ver (cs table) conn
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
return $ responseLBS status201 return $ responseLBS status201
[ jsonContentType [ jsonContentType
, (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params) , (hLocation, "/" <> cs table <> "?" <> cs params)
] "" ] ""
) )
([table], "PUT") -> ([table], "PUT") ->
jsonBodyAction req (\row -> do jsonBodyAction req (\row -> do
keys <- primaryKeyColumns ver (unpack table) conn keys <- primaryKeyColumns ver (cs table) conn
let specifiedKeys = map (BS.unpack . fst) qq let specifiedKeys = map (cs . fst) qq
if S.fromList keys /= S.fromList specifiedKeys if S.fromList keys /= S.fromList specifiedKeys
then return $ responseLBS status405 [] then return $ responseLBS status405 []
"You must speficy all and only primary keys as params" "You must speficy all and only primary keys as params"
@@ -116,15 +114,15 @@ app conn req respond = do
then return $ responseLBS status400 [] then return $ responseLBS status400 []
"Content-Range is not allowed in PUT request" "Content-Range is not allowed in PUT request"
else do else do
cols <- columns ver (unpack table) conn cols <- columns ver (cs table) conn
let colNames = S.fromList $ map (pack . colName) cols let colNames = S.fromList $ map (cs . colName) cols
let specifiedCols = S.fromList $ map fst $ getRow row let specifiedCols = S.fromList $ map fst $ getRow row
if colNames == specifiedCols then do if colNames == specifiedCols then do
allvals <- upsert ver table row qq conn allvals <- upsert ver table row qq conn
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
return $ responseLBS status201 return $ responseLBS status201
[ jsonContentType [ jsonContentType
, (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params) , (hLocation, "/" <> cs table <> "?" <> cs params)
] "" ] ""
else return $ if S.null colNames then responseLBS status404 [] "" else return $ if S.null colNames then responseLBS status404 [] ""
@@ -151,10 +149,10 @@ respondWithRangedResult rr =
jsonContentType, jsonContentType,
("Content-Range", ("Content-Range",
if total == 0 || from > total if total == 0 || from > total
then "*/" <> BS.pack (show total) then "*/" <> cs (show total)
else BS.pack (show from) <> "-" else cs (show from) <> "-"
<> BS.pack (show to) <> "/" <> cs (show to) <> "/"
<> BS.pack (show total) <> cs (show total)
) )
] (rrBody rr) ] (rrBody rr)
@@ -175,12 +173,12 @@ requestedVersion hdrs =
_ -> Nothing _ -> Nothing
where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
accept = BS.unpack <$> lookup hAccept hdrs :: Maybe String accept = cs <$> lookup hAccept hdrs :: Maybe String
verStr = (=~ verRegex) <$> accept :: Maybe [[String]] verStr = (=~ verRegex) <$> accept :: Maybe [[String]]
sqlErrorHandler :: SqlError -> Response sqlErrorHandler :: SqlError -> Response
sqlErrorHandler e = sqlErrorHandler e =
responseLBS status400 [] $ BL.fromChunks [BS.pack (seErrorMsg e)] responseLBS status400 [] $ cs (seErrorMsg e)
addHeaders :: ResponseHeaders -> Response -> Response addHeaders :: ResponseHeaders -> Response -> Response
addHeaders hdrs (ResponseFile s headers fp m) = addHeaders hdrs (ResponseFile s headers fp m) =
src/PgQuery.hs
+5 -4
View File
@@ -9,7 +9,8 @@ module PgQuery (
RangedResult(..), RangedResult(..),
) where ) where
import Data.Text (Text, pack) import Data.Text (Text)
import Data.String.Conversions (cs)
import Data.Functor ( (<$>) ) import Data.Functor ( (<$>) )
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List (intersperse, intercalate) import Data.List (intersperse, intercalate)
@@ -135,20 +136,20 @@ placeholders symbol = intercalate ", " . map (const symbol) . getRow
insertClause :: Schema -> Text -> SqlRow -> QuotedSql insertClause :: Schema -> Text -> SqlRow -> QuotedSql
insertClause schema table row = insertClause schema table row =
("insert into %I.%I (" ++ placeholders "%I" row ++ ")", ("insert into %I.%I (" ++ placeholders "%I" row ++ ")",
map toSql $ (pack schema) : table : sqlRowColumns row) map toSql $ cs schema : table : sqlRowColumns row)
<> (" values (" ++ placeholders "?" row ++ ") returning *", sqlRowValues row) <> (" values (" ++ placeholders "?" row ++ ") returning *", sqlRowValues row)
insertClauseViaSelect :: Schema -> Text -> SqlRow -> QuotedSql insertClauseViaSelect :: Schema -> Text -> SqlRow -> QuotedSql
insertClauseViaSelect schema table row = insertClauseViaSelect schema table row =
("insert into %I.%I (" ++ placeholders "%I" row ++ ")", ("insert into %I.%I (" ++ placeholders "%I" row ++ ")",
map toSql $ (pack schema) : table : sqlRowColumns row) map toSql $ cs schema : table : sqlRowColumns row)
<> (" select " ++ placeholders "?" row, sqlRowValues row) <> (" select " ++ placeholders "?" row, sqlRowValues row)
updateClause :: Schema -> Text -> SqlRow -> QuotedSql updateClause :: Schema -> Text -> SqlRow -> QuotedSql
updateClause schema table row = updateClause schema table row =
("update %I.%I set (" ++ placeholders "%I" row ++ ")", ("update %I.%I set (" ++ placeholders "%I" row ++ ")",
map toSql $ (pack schema) : table : sqlRowColumns row) map toSql $ cs schema : table : sqlRowColumns row)
<> (" = (" ++ placeholders "?" row ++ ")", []) <> (" = (" ++ placeholders "?" row ++ ")", [])
upsertClause :: Schema -> Text -> SqlRow -> Net.Query -> QuotedSql upsertClause :: Schema -> Text -> SqlRow -> Net.Query -> QuotedSql
src/RangeQuery.hs
+3 -3
View File
@@ -8,7 +8,7 @@ import Network.HTTP.Types.Header
import Data.Ranged.Boundaries import Data.Ranged.Boundaries
import Data.Ranged.Ranges import Data.Ranged.Ranges
import qualified Data.ByteString.Char8 as BS import Data.String.Conversions (cs)
import Text.Regex.TDFA ((=~)) import Text.Regex.TDFA ((=~))
import Text.Read (readMaybe) import Text.Read (readMaybe)
@@ -37,10 +37,10 @@ parseRange range = do
return $ rangeIntersection lower upper return $ rangeIntersection lower upper
requestedRange :: RequestHeaders -> Maybe NonnegRange requestedRange :: RequestHeaders -> Maybe NonnegRange
requestedRange hdrs = parseRange =<< BS.unpack <$> lookup hRange hdrs requestedRange hdrs = parseRange =<< cs <$> lookup hRange hdrs
requestedContentRange :: RequestHeaders -> Maybe NonnegRange requestedContentRange :: RequestHeaders -> Maybe NonnegRange
requestedContentRange hdrs = parseRange =<< BS.unpack <$> lookup "Content-Range" hdrs requestedContentRange hdrs = parseRange =<< cs <$> lookup "Content-Range" hdrs
limit :: NonnegRange -> Maybe Int limit :: NonnegRange -> Maybe Int
limit range = limit range =
test/Unit/PgQuerySpec.hs
+3 -2
View File
@@ -11,7 +11,8 @@ import PgQuery (insert)
import Types (SqlRow(SqlRow)) import Types (SqlRow(SqlRow))
import TestTypes (fromList, incStr, incNullableStr, incInsert, incId) import TestTypes (fromList, incStr, incNullableStr, incInsert, incId)
import Data.Map (toList) import Data.Map (toList)
import Data.Text(pack) import Data.String.Conversions (cs)
import Control.Arrow
import SpecHelper(dbWithSchema) import SpecHelper(dbWithSchema)
@@ -39,7 +40,7 @@ spec = around dbWithSchema $ do
it "throws an exception if the PK is not unique" $ \conn -> do it "throws an exception if the PK is not unique" $ \conn -> do
r <- insert "1" "auto_incrementing_pk" (SqlRow [ r <- insert "1" "auto_incrementing_pk" (SqlRow [
("non_nullable_string", toSql ("a string"::String))]) conn ("non_nullable_string", toSql ("a string"::String))]) conn
let row = SqlRow . map (\(k, v) -> (pack k, v)) . toList $ r let row = SqlRow . map (Control.Arrow.first cs) . toList $ r
insert "1" "auto_incrementing_pk" row conn `shouldThrow` \e -> insert "1" "auto_incrementing_pk" row conn `shouldThrow` \e ->
seState e == "23505" -- uniqueness violation code seState e == "23505" -- uniqueness violation code