Switch to HDBC

Fixes #2

Main.hs

@@ -4,7 +4,7 @@ module Main where
 
 import Control.Applicative
 
-import Database.PostgreSQL.Simple
+import Database.HDBC.PostgreSQL (connectPostgreSQL)
 
 import Network.Wai
 import Network.Wai.Handler.Warp hiding (Connection)
@@ -12,18 +12,13 @@ import Network.HTTP.Types.Status
 import Network.HTTP.Types.Header
 import Network.HTTP.Types.Method
 
-import Data.Aeson (encode)
-
 import Options.Applicative hiding (columns)
 
 import PgStructure (printTables, printColumns, selectAll)
 
-import Data.Text (unpack)
-import Web.Heroku.Postgres (parseDatabaseUrl)
-
 data AppConfig = AppConfig {
-    configDb   :: String
+    configDbUri :: String
-  , configPort :: Int }
+  , configPort  :: Int }
 
 argParser :: Parser AppConfig
 argParser = AppConfig
@@ -33,39 +28,25 @@ argParser = AppConfig
     <> help "port number on which to run HTTP server")
 
 main :: IO ()
-main = execParser (info (helper <*> argParser) describe) >>= exposeDb
+main = do
-  where describe = progDesc "create a REST API to an existing Postgres database"
+  conf <- execParser (info (helper <*> argParser) describe)
 
-exposeDb :: AppConfig -> IO ()
+  Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
-exposeDb conf = do
+  run (configPort conf) $ app conf
-  Prelude.putStrLn $ "Listening on port " ++ show port
-  run port $ app conf
 
   where
-    port = configPort conf
+    describe = progDesc "create a REST API to an existing Postgres database"
-
-connInfo :: AppConfig -> ConnectInfo
-connInfo config = defaultConnectInfo {
-    connectHost = host,
-    connectUser = user,
-    connectPassword = pass,
-    connectDatabase = db
-  }
-  where
-    opts = parseDatabaseUrl $ configDb config
-    fromOpt (fn, key) = maybe (fn defaultConnectInfo) unpack $ lookup key opts
-    [host, user, pass, db] = map fromOpt [(connectHost, "host"), (connectUser, "user"), (connectPassword, "password"), (connectDatabase, "dbname")]
 
 app ::  AppConfig -> Application
 app config req respond =
   case path of
     []      -> respond =<< responseLBS status200 [json] <$> (printTables =<< conn)
-    [table] -> if verb == methodOptions
+    [table] -> respond =<< if verb == methodOptions
-              then respond =<< responseLBS status200 [json] <$> (printColumns table =<< conn)
+                              then responseLBS status200 [json] <$> (printColumns table =<< conn)
-              else respond =<< responseLBS status200 [json] <$> encode <$> (selectAll table =<< conn)
+                              else responseLBS status200 [json] <$> (selectAll table =<< conn)
     _       -> respond $ responseLBS status404 [] ""
   where
     path = pathInfo req
     verb = requestMethod req
     json = (hContentType, "application/json")
-    conn = connect $ connInfo config
+    conn = connectPostgreSQL $ configDbUri config

PgStructure.hs

@@ -1,20 +1,20 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module PgStructure where
 
-import Control.Applicative
+import Data.Functor ( (<$>) )
+import Data.Maybe (mapMaybe)
+import Data.List (intercalate)
 
-import Data.HashMap.Strict
+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
 
-import Database.PostgreSQL.Simple
+import Database.HDBC hiding (colType, colNullable)
-import Database.PostgreSQL.Simple.Types
+import Database.HDBC.PostgreSQL
-import Database.PostgreSQL.Simple.FromRow
-import Database.PostgreSQL.Simple.SqlQQ
 
 import Data.Aeson ((.=))
 
@@ -24,9 +24,6 @@ data Table = Table {
 , tableInsertable :: Bool
 } deriving (Show)
 
-instance FromRow Table where
-  fromRow = Table <$> field <*> field <*> fmap toBool field
-
 instance JSON.ToJSON Table where
   toJSON v = JSON.object [
       "schema"     .= tableSchema v
@@ -48,12 +45,6 @@ data Column = Column {
 , colPrecision :: Maybe Int
 } deriving (Show)
 
-instance FromRow Column where
-  fromRow = Column <$> field <*> field <*> field <*> field <*>
-                       fmap toBool field <*> field <*>
-                       fmap toBool field <*>
-                       field <*> field
-
 instance JSON.ToJSON Column where
   toJSON c = JSON.object [
       "schema"    .= colSchema c
@@ -66,21 +57,43 @@ instance JSON.ToJSON Column where
     , "precision" .= colPrecision c ]
 
 tables :: String -> Connection -> IO [Table]
-tables s conn = query conn q $ Only s
+tables s conn = do
-  where q = [sql|
+  r <- quickQuery conn
-              select table_schema, table_name,
+        "select table_schema, table_name,\
-                     is_insertable_into
+        \       is_insertable_into\
-                from information_schema.tables
+        \  from information_schema.tables\
-               where table_schema = ? |]
+        \ where table_schema = ?" [toSql s]
+  return $ mapMaybe mkTable r
+
+  where
+    mkTable [schema, name, insertable] =
+      Just $ Table (fromSql schema)
+        (fromSql name)
+        (toBool (fromSql insertable))
+    mkTable _ = Nothing
 
 columns :: T.Text -> Connection -> IO [Column]
-columns t conn = query conn q $ Only t
+columns t conn = do
-  where q = [sql|
+  r <- quickQuery conn
-              select table_schema, table_name, column_name, ordinal_position,
+        "select table_schema, table_name, column_name, ordinal_position,\
-                     is_nullable, data_type, is_updatable,
+        \       is_nullable, data_type, is_updatable,\
-                     character_maximum_length, numeric_precision
+        \       character_maximum_length, numeric_precision\
-                from information_schema.columns
+        \  from information_schema.columns\
-               where table_name = ? |]
+        \ where table_name = ?" [toSql t]
+  return $ mapMaybe mkColumn r
+
+  where
+    mkColumn [schema, table, name, pos, nullable, colT, updatable, maxlen, precision] =
+      Just $ Column (fromSql schema)
+        (fromSql table)
+        (fromSql name)
+        (fromSql pos)
+        (toBool (fromSql nullable))
+        (fromSql colT)
+        (toBool (fromSql updatable))
+        (fromSql maxlen)
+        (fromSql precision)
+    mkColumn _ = Nothing
 
 namedColumnHash :: [Column] -> HashMap String Column
 namedColumnHash = fromList . (Prelude.zip =<< Prelude.map colName)
@@ -91,10 +104,24 @@ printTables conn = JSON.encode <$> tables "base" conn
 printColumns :: T.Text -> Connection -> IO BL.ByteString
 printColumns table conn = JSON.encode . namedColumnHash <$> columns table conn
 
-selectAll :: T.Text -> Connection -> IO JSON.Value
+selectAll :: T.Text -> Connection -> IO BL.ByteString
-selectAll table conn = fromOnly <$> Prelude.head <$> query conn q (Only safeName)
+selectAll table conn = do
+  sql <- prepareDynamic conn
+    "select array_to_json(array_agg(row_to_json(t)))\
+    \  from (select * from %I.%I) t" [toSql (T.pack "base"), toSql table]
+  r <- quickQuery conn sql []
+  return $ case r of
+                [[json]] -> fromSql json
+                _        -> "" :: BL.ByteString
+
+prepareDynamic :: Connection -> String -> [SqlValue] -> IO String
+prepareDynamic conn sql args = do
+  let q = (concat [ "select format('", sql, "', ", placeholders args, ")" ])
+  r <- quickQuery conn q args
+
+  return $ case r of
+                [[formatted]] -> fromSql formatted
+                _             -> ""
+
   where
-    q = [sql|
+    placeholders = intercalate ", " . map (const "?::varchar")
-          select array_to_json(array_agg(row_to_json(t)))
-            from (select * from ?) t; |]
-    safeName = QualifiedIdentifier (Just "base") table

dbapi.cabal

@@ -16,11 +16,10 @@ executable dbapi
   other-modules:       PgStructure
   other-extensions:    OverloadedStrings
   build-depends:       base >=4.6 && <5
-                     , postgresql-simple
+                     , HDBC, HDBC-postgresql
                      , warp, wai, http-types
                      , bytestring, aeson, network
                      , text, optparse-applicative
                      , unordered-containers
-                     , heroku
   -- hs-source-dirs:
   default-language:    Haskell2010