diff --git a/Main.hs b/Main.hs index 4c00747a1..fd76569a4 100644 --- a/Main.hs +++ b/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 - , 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 diff --git a/PgStructure.hs b/PgStructure.hs index e662e0b8d..b722317ed 100644 --- a/PgStructure.hs +++ b/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.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") diff --git a/dbapi.cabal b/dbapi.cabal index b2454fc66..db369edd7 100644 --- a/dbapi.cabal +++ b/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