From c278a78edf2a913f429a9f2c494e3f541840ebb8 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 2 Aug 2014 21:04:58 -0700 Subject: [PATCH] Create grammar to manipulate query monoids --- Main.hs | 11 +++--- PgQuery.hs | 95 +++++++++++++++++++++++++++++--------------------- PgStructure.hs | 7 ++-- 3 files changed, 63 insertions(+), 50 deletions(-) diff --git a/Main.hs b/Main.hs index 4eff8e2af..9b75cae5f 100644 --- a/Main.hs +++ b/Main.hs @@ -21,13 +21,13 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BS import PgStructure (printTables, printColumns) -import PgQuery (selectWhere) +import PgQuery import RangeQuery import Data.Maybe (fromMaybe) -import qualified Data.Text as T import Text.Regex.TDFA ((=~)) import Text.Read (readMaybe) +import Data.Text (unpack) import Data.Ranged.Ranges (emptyRange) @@ -66,13 +66,12 @@ app config req respond = do ([], _) -> responseLBS status200 [json] <$> (printTables ver =<< conn) ([table], "OPTIONS") -> - responseLBS status200 [json] <$> (printColumns ver table =<< conn) + responseLBS status200 [json] <$> (printColumns ver (unpack table) =<< conn) ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" - else responseLBS status200 [json] <$> ( - selectWhere (T.pack $ show ver) table qq range =<< conn - ) + else responseLBS status200 [json] . rrBody <$> + (getRows (show ver) (unpack table) qq range =<< conn) (_, _) -> return $ responseLBS status404 [] "" diff --git a/PgQuery.hs b/PgQuery.hs index cd1ba0ebc..1560d8173 100644 --- a/PgQuery.hs +++ b/PgQuery.hs @@ -1,21 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} +-- {{{ Imports + module PgQuery where import Data.Functor ( (<$>) ) import Data.Maybe (fromMaybe) -import Data.List (intercalate) -import Data.Monoid ((<>)) +import Data.List (intersperse, intercalate) +import Data.Monoid ((<>), mconcat) import qualified RangeQuery as R -import qualified Data.Text as T -import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL import Database.HDBC hiding (colType, colNullable) import Database.HDBC.PostgreSQL -import Network.HTTP.Types.URI +import qualified Network.HTTP.Types.URI as Net + +-- }}} data RangedResult = RangedResult { rrFrom :: Int @@ -24,43 +27,35 @@ data RangedResult = RangedResult { , rrBody :: BL.ByteString } -selectWhere :: T.Text -> T.Text -> Query -> Maybe R.NonnegRange -> Connection -> IO BL.ByteString -selectWhere ver table qq range conn = do - s <- selectSql - w <- whereClause conn qq - r <- quickQuery conn (BS.unpack $ s <> w) [] +type QuotedSql = (String, [SqlValue]) + +getRows :: String -> String -> Net.Query -> Maybe R.NonnegRange -> Connection -> IO RangedResult +getRows schema table qq range conn = do + query <- populateSql conn + $ jsonArrayRows + $ selectStarClause schema table + <> whereClause qq + <> limitClause range + r <- quickQuery conn query [] let body = case r of - [[SqlNull]] -> "[]"::BL.ByteString - [[json]] -> fromSql json - _ -> "" :: BL.ByteString - return body + [[SqlNull]] -> "[]" + [[json]] -> fromSql json + _ -> "" + return $ RangedResult 0 0 0 body + + +whereClause :: Net.Query -> QuotedSql +whereClause qs = + if null qs then ("", []) else (" where ", []) <> conjunction where - limit = fromMaybe "ALL" $ show <$> (R.limit =<< range) - offset = fromMaybe 0 (R.offset <$> range) - selectSql = pgFormat conn - "select array_to_json(array_agg(row_to_json(t)))\ - \ from (select * from %I.%I LIMIT %s OFFSET %s) t" - [toSql ver, toSql table, toSql limit, toSql offset] + conjunction = mconcat $ intersperse (" and ", []) (map wherePred qs) -whereClause :: Connection -> Query -> IO BS.ByteString -whereClause _ [] = return "" -whereClause conn qs = - (" where " <>) <$> clause - - where - clause :: IO BS.ByteString - clause = BS.intercalate " and " <$> preds - - preds :: IO [BS.ByteString] - preds = mapM (wherePred conn) qs - - -wherePred :: Connection -> QueryItem -> IO BS.ByteString -wherePred conn (column, predicate) = - pgFormat conn ("t.%I " <> op <> "%L") $ map toSql [column, value] +wherePred :: Net.QueryItem -> QuotedSql +wherePred (column, predicate) = + ("t.%I " <> op <> "%L", map toSql [column, value]) where opCode:rest = BS.split ':' $ fromMaybe "" predicate @@ -75,13 +70,33 @@ wherePred conn (column, predicate) = _ -> "=" -pgFormat :: Connection -> String -> [SqlValue] -> IO BS.ByteString -pgFormat conn sql args = do - [[escaped]] <- quickQuery conn q args +limitClause :: Maybe R.NonnegRange -> QuotedSql +limitClause range = + (" LIMIT %s OFFSET %s ", [toSql limit, toSql offset]) + + where + limit = fromMaybe "ALL" $ show <$> (R.limit =<< range) + offset = fromMaybe 0 $ R.offset <$> range + +selectStarClause :: String -> String -> QuotedSql +selectStarClause schema table = + (" select * from %I.%I ", map toSql [schema, table]) + +selectCountClause :: String -> String -> QuotedSql +selectCountClause schema table = + (" select count(1) from %I.%I ", map toSql [schema, table]) + +jsonArrayRows :: QuotedSql -> QuotedSql +jsonArrayRows q = + ("select array_to_json(array_agg(row_to_json(t))) from (", []) <> q <> (") t", []) + +populateSql :: Connection -> QuotedSql -> IO String +populateSql conn sql = do + [[escaped]] <- quickQuery conn q (snd sql) return $ fromSql escaped where - q = concat [ "select format('", sql, "', ", placeholders args, ")" ] + q = concat [ "select format('", fst sql, "', ", placeholders (snd sql), ")" ] placeholders :: [a] -> String placeholders = intercalate ", " . map (const "?::varchar") diff --git a/PgStructure.hs b/PgStructure.hs index 1a0d03a26..6eaecb18d 100644 --- a/PgStructure.hs +++ b/PgStructure.hs @@ -9,7 +9,6 @@ import Control.Applicative ( (<*>) ) import Data.HashMap.Strict hiding (map) -import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL import qualified Data.Aeson as JSON @@ -83,7 +82,7 @@ tables s conn = do (toBool (fromSql insertable)) mkTable _ = Nothing -columns :: Int -> T.Text -> Connection -> IO [Column] +columns :: Int -> String -> Connection -> IO [Column] columns s t conn = do r <- quickQuery conn "select table_schema, table_name, column_name, ordinal_position,\ @@ -113,7 +112,7 @@ namedColumnHash = fromList . (Prelude.zip =<< Prelude.map colName) printTables :: Int -> Connection -> IO BL.ByteString printTables schema conn = JSON.encode <$> tables (show schema) conn -printColumns :: Int -> T.Text -> Connection -> IO BL.ByteString +printColumns :: Int -> String -> Connection -> IO BL.ByteString printColumns schema table conn = JSON.encode <$> (TableOptions <$> cols <*> pkey) where @@ -122,7 +121,7 @@ printColumns schema table conn = pkey :: IO [String] pkey = primaryKeyColumns schema table conn -primaryKeyColumns :: Int -> T.Text -> Connection -> IO [String] +primaryKeyColumns :: Int -> String -> Connection -> IO [String] primaryKeyColumns s t conn = do r <- quickQuery conn "select kc.column_name \