From 91efcba6e9bb045437a6517942e28462d52e028a Mon Sep 17 00:00:00 2001
From: "Adam C. Baker" <adam.durandal@gmail.com>
Date: Sun, 6 Jul 2014 20:03:54 -0700
Subject: [PATCH] parse db url. Fixes #5.

---
 Main.hs     | 25 +++++++++++++++++++------
 dbapi.cabal |  5 +++--
 2 files changed, 22 insertions(+), 8 deletions(-)

diff --git a/Main.hs b/Main.hs
index dd9812fd9..2305b5c35 100644
--- a/Main.hs
+++ b/Main.hs
@@ -18,6 +18,9 @@ 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 }
@@ -36,13 +39,25 @@ main = execParser (info (helper <*> argParser) describe) >>= exposeDb
 exposeDb :: AppConfig -> IO ()
 exposeDb conf = do
   Prelude.putStrLn $ "Listening on port " ++ show port
-  run port app
+  run port $ app conf
 
   where
     port = configPort conf
 
-app :: Application
-app req respond =
+connInfo :: AppConfig -> ConnectInfo
+connInfo config = defaultConnectInfo {
+    connectHost = host,
+    connectUser = user,
+    connectPassword = pass,
+    connectDatabase = db
+  }
+  where
+    opts = parseDatabaseUrl $ configDb config
+    fromOpt key = maybe (connectHost defaultConnectInfo) unpack $ lookup key opts
+    [host, user, pass, db] = map fromOpt ["host", "user", "password", "dbname"]
+
+app ::  AppConfig -> Application
+app config req respond =
   case path of
     []      -> respond =<< responseLBS status200 [json] <$> (printTables =<< conn)
     [table] -> if verb == methodOptions
@@ -52,7 +67,5 @@ app req respond =
   where
     path = pathInfo req
     verb = requestMethod req
-    conn = connect defaultConnectInfo {
-      connectDatabase = "dbapi_test"
-    }
     json = (hContentType, "application/json")
+    conn = connect $ connInfo config
diff --git a/dbapi.cabal b/dbapi.cabal
index 8522f08cf..b2454fc66 100644
--- a/dbapi.cabal
+++ b/dbapi.cabal
@@ -7,7 +7,7 @@ author:              Joe Nelson
 maintainer:          cred+github@begriffs.com
 category:            Web
 build-type:          Simple
--- extra-source-files:  
+-- extra-source-files:
 cabal-version:       >=1.10
 
 executable dbapi
@@ -21,5 +21,6 @@ executable dbapi
                      , bytestring, aeson, network
                      , text, optparse-applicative
                      , unordered-containers
-  -- hs-source-dirs:      
+                     , heroku
+  -- hs-source-dirs:
   default-language:    Haskell2010