From 29d278f6bdbb2f68f5f5a29c44e80f0410a4f86e Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 28 Sep 2014 10:41:37 -0700 Subject: [PATCH] One string conversion to rule them all --- dbapi.cabal | 2 ++ src/Dbapi.hs | 40 +++++++++++++++++++--------------------- src/PgQuery.hs | 9 +++++---- src/RangeQuery.hs | 6 +++--- test/Unit/PgQuerySpec.hs | 5 +++-- 5 files changed, 32 insertions(+), 30 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index d0ccd9eca..60d80701f 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -24,6 +24,7 @@ executable dbapi , optparse-applicative >= 0.9.1 && < 0.10 , unordered-containers , regex-base + , string-conversions , http-media, regex-tdfa , Ranged-sets , transformers @@ -53,6 +54,7 @@ Test-Suite spec , text, optparse-applicative , unordered-containers , regex-base + , string-conversions , http-media, regex-tdfa , Ranged-sets , transformers diff --git a/src/Dbapi.hs b/src/Dbapi.hs index e5c93df1e..3fb82d718 100644 --- a/src/Dbapi.hs +++ b/src/Dbapi.hs @@ -27,8 +27,8 @@ import Network.HTTP.Base (urlEncodeVars) import Network.Wai import Network.Wai.Internal -import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BS +import Data.String.Conversions (cs) import Database.HDBC.PostgreSQL (Connection) import Database.HDBC.Types (SqlError, seErrorMsg) @@ -36,8 +36,6 @@ import PgStructure (printTables, printColumns, primaryKeyColumns, columns, Column(colName)) import qualified Data.Aeson as JSON -import Data.Text (pack, unpack) -import Data.Text.Encoding (encodeUtf8) import PgQuery import RangeQuery @@ -57,7 +55,7 @@ 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 $ pack err)] + where json = JSON.encode . JSON.object $ [("error", JSON.String $ cs err)] Right body -> handler body jsonBody :: Request -> IO (Either String SqlRow) @@ -77,37 +75,37 @@ app conn req respond = do ([table], "OPTIONS") -> responseLBS status200 [jsonContentType] <$> - printColumns ver (unpack table) conn + printColumns ver (cs table) conn ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else do - r <- respondWithRangedResult <$> getRows ver (unpack table) qq range conn + r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn let canonical = urlEncodeVars $ sort $ - map (join (***) BS.unpack) $ + map (join (***) cs) $ parseSimpleQuery $ rawQueryString req return $ addHeaders [ ("Content-Location", - "/" <> encodeUtf8 table <> "?" <> BS.pack canonical + "/" <> cs table <> "?" <> cs canonical )] r ([table], "POST") -> jsonBodyAction req (\row -> do 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 return $ responseLBS status201 [ jsonContentType - , (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params) + , (hLocation, "/" <> cs table <> "?" <> cs params) ] "" ) ([table], "PUT") -> jsonBodyAction req (\row -> do - keys <- primaryKeyColumns ver (unpack table) conn - let specifiedKeys = map (BS.unpack . fst) qq + 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" @@ -116,15 +114,15 @@ app conn req respond = do then return $ responseLBS status400 [] "Content-Range is not allowed in PUT request" else do - cols <- columns ver (unpack table) conn - let colNames = S.fromList $ map (pack . colName) cols + 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 allvals <- upsert ver table row qq conn let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys return $ responseLBS status201 [ jsonContentType - , (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params) + , (hLocation, "/" <> cs table <> "?" <> cs params) ] "" else return $ if S.null colNames then responseLBS status404 [] "" @@ -151,10 +149,10 @@ respondWithRangedResult rr = jsonContentType, ("Content-Range", if total == 0 || from > total - then "*/" <> BS.pack (show total) - else BS.pack (show from) <> "-" - <> BS.pack (show to) <> "/" - <> BS.pack (show total) + then "*/" <> cs (show total) + else cs (show from) <> "-" + <> cs (show to) <> "/" + <> cs (show total) ) ] (rrBody rr) @@ -175,12 +173,12 @@ requestedVersion hdrs = _ -> Nothing 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]] sqlErrorHandler :: SqlError -> Response sqlErrorHandler e = - responseLBS status400 [] $ BL.fromChunks [BS.pack (seErrorMsg e)] + responseLBS status400 [] $ cs (seErrorMsg e) addHeaders :: ResponseHeaders -> Response -> Response addHeaders hdrs (ResponseFile s headers fp m) = diff --git a/src/PgQuery.hs b/src/PgQuery.hs index b8002ae6f..5e1e431e8 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -9,7 +9,8 @@ module PgQuery ( RangedResult(..), ) where -import Data.Text (Text, pack) +import Data.Text (Text) +import Data.String.Conversions (cs) import Data.Functor ( (<$>) ) import Data.Maybe (fromMaybe) import Data.List (intersperse, intercalate) @@ -135,20 +136,20 @@ placeholders symbol = intercalate ", " . map (const symbol) . getRow insertClause :: Schema -> Text -> SqlRow -> QuotedSql insertClause schema table 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) insertClauseViaSelect :: Schema -> Text -> SqlRow -> QuotedSql insertClauseViaSelect schema table 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) updateClause :: Schema -> Text -> SqlRow -> QuotedSql updateClause schema table row = ("update %I.%I set (" ++ placeholders "%I" row ++ ")", - map toSql $ (pack schema) : table : sqlRowColumns row) + map toSql $ cs schema : table : sqlRowColumns row) <> (" = (" ++ placeholders "?" row ++ ")", []) upsertClause :: Schema -> Text -> SqlRow -> Net.Query -> QuotedSql diff --git a/src/RangeQuery.hs b/src/RangeQuery.hs index cbd220d13..9daabe995 100644 --- a/src/RangeQuery.hs +++ b/src/RangeQuery.hs @@ -8,7 +8,7 @@ import Network.HTTP.Types.Header import Data.Ranged.Boundaries import Data.Ranged.Ranges -import qualified Data.ByteString.Char8 as BS +import Data.String.Conversions (cs) import Text.Regex.TDFA ((=~)) import Text.Read (readMaybe) @@ -37,10 +37,10 @@ parseRange range = do return $ rangeIntersection lower upper requestedRange :: RequestHeaders -> Maybe NonnegRange -requestedRange hdrs = parseRange =<< BS.unpack <$> lookup hRange hdrs +requestedRange hdrs = parseRange =<< cs <$> lookup hRange hdrs 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 range = diff --git a/test/Unit/PgQuerySpec.hs b/test/Unit/PgQuerySpec.hs index df47c3366..dde03c47e 100644 --- a/test/Unit/PgQuerySpec.hs +++ b/test/Unit/PgQuerySpec.hs @@ -11,7 +11,8 @@ import PgQuery (insert) import Types (SqlRow(SqlRow)) import TestTypes (fromList, incStr, incNullableStr, incInsert, incId) import Data.Map (toList) -import Data.Text(pack) +import Data.String.Conversions (cs) +import Control.Arrow import SpecHelper(dbWithSchema) @@ -39,7 +40,7 @@ spec = around dbWithSchema $ do it "throws an exception if the PK is not unique" $ \conn -> do r <- insert "1" "auto_incrementing_pk" (SqlRow [ ("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 -> seState e == "23505" -- uniqueness violation code