Create grammar to manipulate query monoids

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] <$> (
+        else responseLBS status200 [json] . rrBody <$>
-          selectWhere (T.pack $ show ver) table qq range =<< conn
+          (getRows (show ver) (unpack table) qq range =<< conn)
-        )
       (_, _) ->
         return $ responseLBS status404 [] ""
 

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.List (intersperse, intercalate)
-import Data.Monoid ((<>))
+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
+type QuotedSql = (String, [SqlValue])
-selectWhere ver table qq range conn = do
+
-  s <- selectSql
+getRows :: String -> String -> Net.Query -> Maybe R.NonnegRange -> Connection -> IO RangedResult
-  w <- whereClause conn qq
+getRows schema table qq range conn = do
-  r <- quickQuery conn (BS.unpack $ s <> w) []
+  query <- populateSql conn
+    $ jsonArrayRows
+    $ selectStarClause schema table
+      <> whereClause qq
+      <> limitClause range
+  r <- quickQuery conn query []
 
   let body = case r of
-             [[SqlNull]] -> "[]"::BL.ByteString
+             [[SqlNull]] -> "[]"
              [[json]]    -> fromSql json
-             _        -> "" :: BL.ByteString
+             _           -> ""
-  return body
+  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)
+    conjunction = mconcat $ intersperse (" and ", []) (map wherePred qs)
-    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]
 
 
-whereClause :: Connection -> Query -> IO BS.ByteString
+wherePred :: Net.QueryItem -> QuotedSql
-whereClause _    [] = return ""
+wherePred (column, predicate) =
-whereClause conn qs =
+  ("t.%I " <> op <> "%L", map toSql [column, value])
-  (" 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]
 
   where
     opCode:rest = BS.split ':' $ fromMaybe "" predicate
@@ -75,13 +70,33 @@ wherePred conn (column, predicate) =
               _     -> "="
 
 
-pgFormat :: Connection -> String -> [SqlValue] -> IO BS.ByteString
+limitClause :: Maybe R.NonnegRange -> QuotedSql
-pgFormat conn sql args = do
+limitClause range =
-  [[escaped]] <- quickQuery conn q args
+  (" 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")

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 \