72 lines
2.2 KiB
Haskell
72 lines
2.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Applicative
|
|
|
|
import Database.PostgreSQL.Simple
|
|
|
|
import Network.Wai
|
|
import Network.Wai.Handler.Warp hiding (Connection)
|
|
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 }
|
|
|
|
argParser :: Parser AppConfig
|
|
argParser = AppConfig
|
|
<$> strOption (long "db" <> short 'd' <> metavar "URI"
|
|
<> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
|
|
<*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
|
|
<> 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"
|
|
|
|
exposeDb :: AppConfig -> IO ()
|
|
exposeDb conf = do
|
|
Prelude.putStrLn $ "Listening on port " ++ show port
|
|
run port $ 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")]
|
|
|
|
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)
|
|
_ -> respond $ responseLBS status404 [] ""
|
|
where
|
|
path = pathInfo req
|
|
verb = requestMethod req
|
|
json = (hContentType, "application/json")
|
|
conn = connect $ connInfo config
|