From 780c9d7c0f25ece246ba81b7b89094d1e938601c Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 25 Aug 2014 11:31:27 -0700 Subject: [PATCH] Include location header in post response --- dbapi.cabal | 7 ++++++- src/Dbapi.hs | 30 +++++++++++++++++++++--------- src/PgQuery.hs | 22 ++++++++++------------ src/PgStructure.hs | 2 +- test/Feature/RangeSpec.hs | 17 +++++++---------- 5 files changed, 45 insertions(+), 33 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index f500ab93f..59eef5e40 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -14,9 +14,11 @@ library , HDBC, HDBC-postgresql , warp, wai >= 3.0.1 && < 3.0.2 , http-types, scientific, time + , HTTP, convertible , bytestring, aeson, network , text, optparse-applicative , unordered-containers + , containers , regex-base , http-media, regex-tdfa , Ranged-sets @@ -34,9 +36,11 @@ executable dbapi build-depends: base >=4.6 && <5 , HDBC, HDBC-postgresql , warp, wai >= 3.0.1 && < 3.0.2 + , HTTP, convertible , http-types, scientific, time , bytestring, aeson, network , text, optparse-applicative + , containers , unordered-containers , regex-base , http-media, regex-tdfa @@ -57,7 +61,8 @@ Test-Suite spec , hspec-wai , HDBC, HDBC-postgresql , warp, wai >= 3.0.1 && < 3.0.2 - , wai-extra + , HTTP, convertible + , wai-extra, containers , http-types, scientific, time , bytestring, aeson, network , text, optparse-applicative diff --git a/src/Dbapi.hs b/src/Dbapi.hs index 6b147e071..ce052dda9 100644 --- a/src/Dbapi.hs +++ b/src/Dbapi.hs @@ -12,7 +12,10 @@ import Options.Applicative hiding (columns) import Data.Maybe (fromMaybe) import Text.Read (readMaybe) import Text.Regex.TDFA ((=~)) +import Data.Map (intersection, fromList, toList) +import Data.Convertible.Base (convert) +import Network.HTTP.Base (urlEncodeVars) import Network.HTTP.Types.Status import Network.HTTP.Types.Header @@ -23,10 +26,12 @@ import qualified Data.ByteString.Char8 as BS import Database.HDBC.PostgreSQL (Connection) import Database.HDBC.Types (SqlError, seErrorMsg) -import PgStructure (printTables, printColumns) +import Database.HDBC.SqlValue (SqlValue(..)) +import PgStructure (printTables, printColumns, primaryKeyColumns) import qualified Data.Aeson as JSON import Data.Text (pack, unpack) +import Data.Text.Encoding (encodeUtf8) import PgQuery import RangeQuery @@ -50,26 +55,33 @@ jsonBodyAction req handler = do Right body -> handler body jsonBody :: Request -> IO (Either String SqlRow) -jsonBody = (fmap JSON.eitherDecode) . strictRequestBody +jsonBody = fmap JSON.eitherDecode . strictRequestBody app :: Connection -> Application app conn req respond = do r <- try $ case (path, verb) of ([], _) -> - responseLBS status200 [jsonContentType] <$> (printTables ver conn) + responseLBS status200 [jsonContentType] <$> printTables ver conn ([table], "OPTIONS") -> - responseLBS status200 [jsonContentType] <$> ( - printColumns ver (unpack table) conn) + responseLBS status200 [jsonContentType] <$> + printColumns ver (unpack table) conn ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else respondWithRangedResult <$> - (getRows (show ver) (unpack table) qq range conn) + getRows (show ver) (unpack table) qq range conn ([table], "POST") -> - jsonBodyAction req (\row -> - responseLBS status201 [jsonContentType] <$> ( - insert ver table row conn)) + jsonBodyAction req (\row -> do + allvals <- insert ver table row conn + keys <- primaryKeyColumns ver (unpack table) conn + let keyvals = allvals `intersection` fromList (zip keys $ repeat SqlNull) + let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList keyvals + return $ responseLBS status201 + [ jsonContentType + , (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params) + ] "" + ) (_, _) -> return $ responseLBS status404 [] "" diff --git a/src/PgQuery.hs b/src/PgQuery.hs index f4bb5aaf2..67007d314 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -9,8 +9,7 @@ import Data.Functor ( (<$>) ) import Data.Maybe (fromMaybe) import Data.List (intersperse, intercalate) import Data.Monoid ((<>), mconcat) -import Data.HashMap.Strict (fromList) -import qualified Data.Aeson as JSON +import qualified Data.Map as M import qualified RangeQuery as R import qualified Data.ByteString.Char8 as BS @@ -66,8 +65,8 @@ wherePred (column, predicate) = ("%I " <> op <> "%L", map toSql [column, value]) where - opCode:rest = BS.split ':' $ fromMaybe ":" predicate - value = BS.intercalate ":" rest + opCode:rest = BS.split '.' $ fromMaybe "." predicate + value = BS.intercalate "." rest op = case opCode of "eq" -> "=" "gt" -> ">" @@ -104,15 +103,14 @@ jsonArrayRows :: QuotedSql -> QuotedSql jsonArrayRows q = ("array_to_json(array_agg(row_to_json(t))) from (", []) <> q <> (") t", []) -insert :: Int -> Text -> SqlRow -> Connection -> IO BL.ByteString +insert :: Int -> Text -> SqlRow -> Connection -> IO (M.Map String SqlValue) insert schema table row conn = do - query <- populateSql conn ("insert into %I.%I ("++colIds++")", map toSql $ (pack . show $ schema):table:cols) - stmt <- prepare conn (query ++ " values ("++phs++") returning *") - _ <- execute stmt values - keys <- getColumnNames stmt - Just vals <- fetchRow stmt - let rowMap = fromList $ zip keys vals - return $ JSON.encode rowMap + query <- populateSql conn ("insert into %I.%I ("++colIds++")", + map toSql $ (pack . show $ schema):table:cols) + stmt <- prepare conn (query ++ " values ("++phs++") returning *") + _ <- execute stmt values + Just m <- fetchRowMap stmt + return m where (cols, values) = unzip . getRow $ row colIds = intercalate ", " $ map (const "%I") cols diff --git a/src/PgStructure.hs b/src/PgStructure.hs index bf46b2dfa..8152b8c76 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -69,7 +69,7 @@ data TableOptions = TableOptions { instance JSON.ToJSON TableOptions where toJSON t = JSON.object [ "columns" .= tblOptcolumns t - , "pkey" .= tblOptpkey t ] + , "pkey" .= tblOptpkey t ] tables :: String -> Connection -> IO [Table] tables s conn = do diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index 3285fadb7..072abe103 100644 --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -8,11 +8,9 @@ import Test.Hspec.Wai.JSON import SpecHelper import Network.HTTP.Types -import Network.Wai.Test (SResponse(..)) import qualified Data.Aeson as JSON import Data.Aeson ((.:)) -import Data.Maybe (fromJust) import Control.Applicative ((<$>), (<*>)) import Control.Monad (mzero) @@ -102,12 +100,11 @@ spec = around appWithFixture $ do { "non_nullable_string":"not null"} |] `shouldRespondWith` 201 - it "responds with the created row" $ do - r <- post "/auto_incrementing_pk" [json| + it "links to the created resource" $ do + post "/auto_incrementing_pk" [json| { "non_nullable_string":"not null"} |] - let row = fromJust (JSON.decode $ simpleBody r :: Maybe IncPK) - liftIO $ do - incStr row `shouldBe` "not null" - incNullableStr row `shouldBe` Nothing - -- Add assertions to check timestamp and id - -- OR: change behavior to return no body at all + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing, + matchStatus = 201, + matchHeaders = [("Location", "/auto_incrementing_pk?id=eq.2")] + }