From 1b8f0f28294e9de0c741b3aaabbd6b8ec8cb015e Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Wed, 12 Nov 2014 17:34:44 -0800
Subject: [PATCH] Main compiles. Still bugs though

---
 src/Main.hs       | 15 ++++++++++-----
 src/Middleware.hs | 32 +++++++++++++++-----------------
 2 files changed, 25 insertions(+), 22 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index daecf231b..886eb132e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -5,19 +5,24 @@ import Paths_dbapi (version)
 import App
 import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
   redirectInsecure, withDBConnection, Environment(..))
-import Network.Wai.Handler.Warp hiding (Connection)
 import Data.String.Conversions (cs)
 
+import qualified Data.CaseInsensitive as CI
+import qualified Data.ByteString.Char8 as BS
 import Control.Monad (unless)
 import Control.Applicative
 import Control.Exception(bracket)
 import Options.Applicative hiding (columns)
+import Network.Wai
+import Network.Wai.Handler.Warp hiding (Connection)
 import Network.Wai.Middleware.Gzip (gzip, def)
-import Network.Wai.Middleware.Cors (cors)
+import Network.Wai.Middleware.Cors (cors, CorsResourcePolicy(..))
 import Network.Wai.Middleware.Static (staticPolicy, only)
 import Data.Pool(createPool, destroyAllResources)
 import Data.List (intercalate)
 import Data.Version (versionBranch)
+import Data.Text (strip)
+import Database.PostgreSQL.Simple
 
 data AppConfig = AppConfig {
     configDbUri :: String
@@ -44,8 +49,8 @@ main :: IO ()
 main = do
   conf <- execParser (info (helper <*> argParser) describe)
   bracket
-    (createPool (connectPostgreSQL' (configDbUri conf))
-      disconnect 1 600 (configPool conf))
+    (createPool (connectPostgreSQL $ cs (configDbUri conf))
+      close 1 600 (configPool conf))
     destroyAllResources
     (\pool -> do
       let port = configPort conf
@@ -61,7 +66,7 @@ main = do
         . gzip def . cors corsPolicy . clientErrors
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
         . withDBConnection pool . inTransaction Production
-        . authenticated (cs $ configAnonRole conf) . withSavepoint Production $ app
+        . authenticated (cs $ configAnonRole conf) . Middleware.withSavepoint Production $ app
       )
   where
     describe = progDesc "create a REST API to an existing Postgres database"
diff --git a/src/Middleware.hs b/src/Middleware.hs
index 533090eae..cfeccd592 100644
--- a/src/Middleware.hs
+++ b/src/Middleware.hs
@@ -7,10 +7,10 @@ import Data.Maybe (fromMaybe)
 import Data.Monoid (mconcat)
 import Data.Pool(withResource, Pool)
 
+import Database.PostgreSQL.Simple
 import Data.String.Conversions(cs)
 import qualified Data.ByteString.Char8 as BS
-import Control.Exception (finally, throw, catchJust, catch, SomeException,
-    bracket_)
+import Control.Exception (catchJust, bracket_)
 
 import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
   hLocation)
@@ -19,7 +19,7 @@ import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
                    rawQueryString, isSecure, requestMethod, Request)
 import Network.URI (URI(..), parseURI)
 
-import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
+import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
 import Debug.Trace
@@ -37,20 +37,17 @@ inTransaction :: Environment -> (Connection -> Application) ->
                  Connection -> Application
 inTransaction env app conn req respond =
   if env == Production && safeAction req
-    then
-      app conn req respond
-    else
-      finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
+    then go
+    else withTransaction conn go
+  where go = app conn req respond
 
 withSavepoint :: Environment -> (Connection -> Application) ->
                  Connection -> Application
 withSavepoint env app conn req respond =
   if env == Production && safeAction req
-    then app conn req respond
-    else do
-      runRaw conn "savepoint req_sp"
-      catch (app conn req respond) (\e -> let _ = (e::SomeException) in
-        runRaw conn "rollback to savepoint req_sp" >> throw e)
+    then go
+    else Database.PostgreSQL.Simple.withSavepoint conn go
+  where go = app conn req respond
 
 authenticated :: BS.ByteString -> (Connection -> Application) ->
                  Connection -> Application
@@ -73,23 +70,24 @@ authenticated anon app conn req respond = do
     case BS.split ' ' (cs auth) of
       ("Basic" : b64 : _) ->
         case BS.split ':' $ cs (decode $ cs b64) of
-          (u:p:_) -> signInRole u p conn
+          (u:p:_) -> signInRole conn u p
           _ -> return MalformedAuth
       _ -> return NoCredentials
 
 instance ToJSON SqlError where
   toJSON t = object [
       "error" .= object [
-          "code"    .= seNativeError t
-        , "message" .= seErrorMsg t
-        , "state"   .= seState t
+          "message" .= (cs $ sqlErrorMsg t :: String)
+        , "detail"  .= (cs $ sqlErrorDetail t :: String)
+        , "state"   .= (cs $ sqlState t :: String)
+        , "hint"    .= (cs $ sqlErrorHint t :: String)
       ]
     ]
 
 clientErrors :: Application -> Application
 clientErrors app req respond =
   catchJust isPgException (app req respond) $ \err ->
-    respond $ if seState err == "42P01"
+    respond $ if sqlState err == "42P01"
        then responseLBS status404 [] ""
        else responseLBS status400 [(hContentType, "application/json")] (encode err)