move auth out of dbapi, use middleware, put in main

src/Dbapi.hs

@@ -4,10 +4,8 @@
 module Dbapi where
 
 import Types (SqlRow, getRow)
-import Middleware(reportPgErrors)
 
 import Control.Monad (join)
-import Control.Exception.Base (bracket_)
 import Control.Arrow ((***))
 import Control.Applicative
 import Options.Applicative hiding (columns)
@@ -43,7 +41,6 @@ import qualified Data.Aeson as JSON
 import PgQuery
 import RangeQuery
 import Data.Ranged.Ranges (emptyRange)
-import Codec.Binary.Base64.String (decode)
 
 -- }}}
 
@@ -74,44 +71,9 @@ filterByKeys m keys =
   if null keys then m else
     m `intersection` fromList (zip keys $ repeat undefined)
 
-httpRequesterRole :: RequestHeaders -> Connection -> IO LoginAttempt
+app :: Connection -> Application
-httpRequesterRole hdrs conn = do
+app conn req respond =
-  let auth = fromMaybe "" $ lookup hAuthorization hdrs
+  respond =<< case (path, verb) of
-  case BS.split ' ' (cs auth) of
-    ("Basic" : b64 : _) ->
-      case BS.split ':' $ cs (decode $ cs b64) of
-        (u:p:_) -> signInRole u p conn
-        _ -> return MalformedAuth
-    _ -> return NoCredentials
-
-
-app :: DbRole -> Connection -> Application
-app anonymous conn req respond = do
-  attempt <- httpRequesterRole (requestHeaders req) conn
-
-  case attempt of
-    MalformedAuth ->
-      respond $ responseLBS status400 [] "Malformed basic auth header"
-    LoginFailed ->
-      respond $ responseLBS status401 [] "Invalid username or password"
-    LoginSuccess role ->
-      bracket_ (pgSetRole conn role) (pgResetRole conn) $ appWithRole conn req respond
-    NoCredentials ->
-      bracket_ (pgSetRole conn anonymous) (pgResetRole conn) $ appWithRole conn req respond
-
-
-appWithRole :: Connection -> Application
-appWithRole conn = reportPgErrors (\req respond ->
-  let
-      path   = pathInfo req
-      verb   = requestMethod req
-      qq     = queryString req
-      hdrs   = requestHeaders req
-      ver    = fromMaybe "1" $ requestedVersion hdrs
-      range  = requestedRange hdrs
-      cRange = requestedContentRange hdrs
-      allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
-   in respond =<< case (path, verb) of
     ([], _) ->
       responseLBS status200 [jsonContentType] <$> printTables ver conn
 
@@ -169,7 +131,16 @@ appWithRole conn = reportPgErrors (\req respond ->
 
     (_, _) ->
       return $ responseLBS status404 [] ""
-  )
+
+  where
+    path   = pathInfo req
+    verb   = requestMethod req
+    qq     = queryString req
+    hdrs   = requestHeaders req
+    ver    = fromMaybe "1" $ requestedVersion hdrs
+    range  = requestedRange hdrs
+    cRange = requestedContentRange hdrs
+    allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
 
 defaultCorsPolicy :: CorsResourcePolicy
 defaultCorsPolicy =  CorsResourcePolicy Nothing

src/Main.hs

@@ -1,10 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
--- {{{ Imports
-
 module Main where
 import Dbapi
-import Middleware (inTransaction)
+import Middleware (inTransaction, authenticated, withSavepoint, clientErrors)
 import Network.Wai.Handler.Warp hiding (Connection)
 import Database.HDBC.PostgreSQL (connectPostgreSQL')
 import Data.String.Conversions (cs)
@@ -15,8 +13,6 @@ import Network.Wai.Handler.WarpTLS (tlsSettings, runTLS)
 import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Cors (cors)
 
--- }}}
-
 argParser :: Parser AppConfig
 argParser = AppConfig
   <$> strOption (long "db" <> short 'd' <> metavar "URI"
@@ -41,8 +37,8 @@ main = do
 
   Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
   conn <- connectPostgreSQL' dburi
-  runTLS tls settings . gzip def . cors corsPolicy $
+  runTLS tls settings . gzip def . cors corsPolicy . clientErrors $ (
-    inTransaction (app (cs $ configAnonRole conf)) conn
+    inTransaction . authenticated (cs $ configAnonRole conf) . withSavepoint) app conn
 
   where
     describe = progDesc "create a REST API to an existing Postgres database"