diff --git a/src/Dbapi.hs b/src/Dbapi.hs index fcd1699e9..c206dbcf6 100644 --- a/src/Dbapi.hs +++ b/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 -httpRequesterRole hdrs conn = do - let auth = fromMaybe "" $ lookup hAuthorization hdrs - 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 +app :: Connection -> Application +app conn req respond = + 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 diff --git a/src/Main.hs b/src/Main.hs index f7ce83637..289d6c81c 100644 --- a/src/Main.hs +++ b/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 $ - inTransaction (app (cs $ configAnonRole conf)) conn + runTLS tls settings . gzip def . cors corsPolicy . clientErrors $ ( + inTransaction . authenticated (cs $ configAnonRole conf) . withSavepoint) app conn where describe = progDesc "create a REST API to an existing Postgres database"