Switch to HDBC

Fixes #2
2014-07-08 23:29:09 -07:00
parent 53d90987ff
commit bbbb327855
3 changed files with 75 additions and 68 deletions
@@ -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
-  , configPort :: Int }
+    configDbUri :: String
+  , 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
-  where describe = progDesc "create a REST API to an existing Postgres database"
+main = do
+  conf <- execParser (info (helper <*> argParser) describe)

-exposeDb :: AppConfig -> IO ()
-exposeDb conf = do
-  Prelude.putStrLn $ "Listening on port " ++ show port
-  run port $ app conf
+  Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
+  run (configPort conf) $ app conf

  where
-    port = configPort conf
-
-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")]
+    describe = progDesc "create a REST API to an existing Postgres database"

 app ::  AppConfig -> Application
 app config req respond =
  case path of
    []      -> respond =<< responseLBS status200 [json] <$> (printTables =<< conn)
-    [table] -> if verb == methodOptions
-              then respond =<< responseLBS status200 [json] <$> (printColumns table =<< conn)
-              else respond =<< responseLBS status200 [json] <$> encode <$> (selectAll table =<< conn)
+    [table] -> respond =<< if verb == methodOptions
+                              then responseLBS status200 [json] <$> (printColumns 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
@@ -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.PostgreSQL.Simple.Types
-import Database.PostgreSQL.Simple.FromRow
-import Database.PostgreSQL.Simple.SqlQQ
+import Database.HDBC hiding (colType, colNullable)
+import Database.HDBC.PostgreSQL

 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
-  where q = [sql|
-              select table_schema, table_name,
-                     is_insertable_into
-                from information_schema.tables
-               where table_schema = ? |]
+tables s conn = do
+  r <- quickQuery conn
+        "select table_schema, table_name,\
+        \       is_insertable_into\
+        \  from information_schema.tables\
+        \ 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
-  where q = [sql|
-              select table_schema, table_name, column_name, ordinal_position,
-                     is_nullable, data_type, is_updatable,
-                     character_maximum_length, numeric_precision
-                from information_schema.columns
-               where table_name = ? |]
+columns t conn = do
+  r <- quickQuery conn
+        "select table_schema, table_name, column_name, ordinal_position,\
+        \       is_nullable, data_type, is_updatable,\
+        \       character_maximum_length, numeric_precision\
+        \  from information_schema.columns\
+        \ 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 table conn = fromOnly <$> Prelude.head <$> query conn q (Only safeName)
+selectAll :: T.Text -> Connection -> IO BL.ByteString
+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|
-          select array_to_json(array_agg(row_to_json(t)))
-            from (select * from ?) t; |]
-    safeName = QualifiedIdentifier (Just "base") table
+    placeholders = intercalate ", " . map (const "?::varchar")
@@ -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