diff --git a/src/Main.hs b/src/Main.hs index f3294f2ef..d3d1a0836 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,17 +3,16 @@ module Main where import Paths_dbapi (version) import App -import Middleware (inTransaction, authenticated, withSavepoint, clientErrors, - redirectInsecure, withDBConnection, Environment(..)) +--import Auth +import Middleware import Control.Monad (unless) -import Control.Exception(bracket) import Data.String.Conversions (cs) +import Network.Wai import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.Gzip (gzip, def) import Network.Wai.Middleware.Static (staticPolicy, only) -import Data.Pool(createPool, destroyAllResources) import Data.List (intercalate) import Data.Version (versionBranch) import qualified Hasql as H @@ -25,26 +24,34 @@ import Config (AppConfig(..), argParser, corsPolicy) main :: IO () main = do conf <- execParser (info (helper <*> argParser) describe) - bracket - (createPool (connectPostgreSQL $ cs (configDbUri conf)) - close 1 600 (configPool conf)) - destroyAllResources - (\pool -> do - let port = configPort conf + let port = configPort conf - unless (configSecure conf) $ - putStrLn "WARNING, running in insecure mode, auth will be in plaintext" + unless (configSecure conf) $ + putStrLn "WARNING, running in insecure mode, auth will be in plaintext" - Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) - let settings = setPort port - . setServerName (cs $ "dbapi/" <> prettyVersion) - $ defaultSettings - runSettings settings $ (if configSecure conf then redirectInsecure else id) + Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) + + + let pgSettings = H.Postgres "localhost" 5432 "postgres" "" "postgres" + + sessSettings <- maybe (fail "Improper session settings") return $ + H.sessionSettings 6 30 + + let settings = setPort port + . setServerName (cs $ "dbapi/" <> prettyVersion) + $ defaultSettings + middle = + (if configSecure conf then redirectInsecure else id) . gzip def . cors corsPolicy . clientErrors - . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) - . withDBConnection pool . inTransaction Production - . authenticated (cs $ configAnonRole conf) . Middleware.withSavepoint Production $ app - ) + . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in + + runSettings settings $ middle (runApp pgSettings sessSettings) + -- . authenticated (cs $ configAnonRole conf) $ app + where describe = progDesc "create a REST API to an existing Postgres database" prettyVersion = intercalate "." $ map show $ versionBranch version + +runApp :: H.Postgres -> H.SessionSettings -> Application +runApp pg sess req respond = + respond =<< H.session pg sess (app req) diff --git a/src/Middleware.hs b/src/Middleware.hs index cfeccd592..519984964 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -2,97 +2,86 @@ module Middleware where -import Data.Aeson ((.=), toJSON, ToJSON, object, encode) -import Data.Maybe (fromMaybe) +--import Data.Aeson ((.=), toJSON, ToJSON, object, encode) +-- import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) -import Data.Pool(withResource, Pool) +-- import Data.Pool(withResource, Pool) -import Database.PostgreSQL.Simple +import qualified Hasql as H import Data.String.Conversions(cs) -import qualified Data.ByteString.Char8 as BS -import Control.Exception (catchJust, bracket_) +--import qualified Data.ByteString.Char8 as BS +import Control.Exception (catchJust) -import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization, - hLocation) -import Network.HTTP.Types.Status (status400, status401, status404, status301) +import Network.HTTP.Types.Header (hLocation, hContentType) +import Network.HTTP.Types.Status (status400, status301) import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, - rawQueryString, isSecure, requestMethod, Request) + rawQueryString, isSecure) import Network.URI (URI(..), parseURI) -import Auth (LoginAttempt(..), signInRole, setRole, resetRole) -import Codec.Binary.Base64.String (decode) +-- import Auth (LoginAttempt(..), signInRole, setRole, resetRole) +-- import Codec.Binary.Base64.String (decode) import Debug.Trace -data Environment = Test | Production deriving (Eq) +-- data Environment = Test | Production deriving (Eq) -withDBConnection :: Pool Connection -> (Connection -> Application) -> Application -withDBConnection pool app req respond = - withResource pool (\c -> app c req respond) +-- safeAction :: Request -> Bool +-- safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod -safeAction :: Request -> Bool -safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod +-- withSavepoint :: Environment -> (Connection -> Application) -> +-- Connection -> Application +-- withSavepoint env app conn req respond = +-- if env == Production && safeAction req +-- then go +-- else Database.PostgreSQL.Simple.withSavepoint conn go +-- where go = app conn req respond -inTransaction :: Environment -> (Connection -> Application) -> - Connection -> Application -inTransaction env app conn req respond = - if env == Production && safeAction req - then go - else withTransaction conn go - where go = app conn req respond +-- authenticated :: BS.ByteString -> (Connection -> Application) -> +-- Connection -> Application +-- authenticated anon app conn req respond = do +-- attempt <- httpRequesterRole (requestHeaders req) +-- case attempt of +-- MalformedAuth -> +-- respond $ responseLBS status400 [] "Malformed basic auth header" +-- LoginFailed -> +-- respond $ responseLBS status401 [] "Invalid username or password" +-- LoginSuccess role -> +-- bracket_ (setRole conn role) (resetRole conn) $ app conn req respond +-- NoCredentials -> +-- bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond -withSavepoint :: Environment -> (Connection -> Application) -> - Connection -> Application -withSavepoint env app conn req respond = - if env == Production && safeAction req - then go - else Database.PostgreSQL.Simple.withSavepoint conn go - where go = app conn req respond +-- where +-- httpRequesterRole :: RequestHeaders -> IO LoginAttempt +-- httpRequesterRole hdrs = 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 conn u p +-- _ -> return MalformedAuth +-- _ -> return NoCredentials -authenticated :: BS.ByteString -> (Connection -> Application) -> - Connection -> Application -authenticated anon app conn req respond = do - attempt <- httpRequesterRole (requestHeaders req) - case attempt of - MalformedAuth -> - respond $ responseLBS status400 [] "Malformed basic auth header" - LoginFailed -> - respond $ responseLBS status401 [] "Invalid username or password" - LoginSuccess role -> - bracket_ (setRole conn role) (resetRole conn) $ app conn req respond - NoCredentials -> - bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond - - where - httpRequesterRole :: RequestHeaders -> IO LoginAttempt - httpRequesterRole hdrs = 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 conn u p - _ -> return MalformedAuth - _ -> return NoCredentials - -instance ToJSON SqlError where - toJSON t = object [ - "error" .= object [ - "message" .= (cs $ sqlErrorMsg t :: String) - , "detail" .= (cs $ sqlErrorDetail t :: String) - , "state" .= (cs $ sqlState t :: String) - , "hint" .= (cs $ sqlErrorHint t :: String) - ] - ] +-- instance ToJSON SqlError where +-- toJSON t = object [ +-- "error" .= object [ +-- "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 sqlState err == "42P01" - then responseLBS status404 [] "" - else responseLBS status400 [(hContentType, "application/json")] (encode err) + respond $ + responseLBS status400 [(hContentType, "application/json")] (cs $ show err) + -- if sqlState err == "42P01" + -- then responseLBS status404 [] "" + -- else responseLBS status400 [(hContentType, "application/json")] (encode err) where - isPgException :: SqlError -> Maybe SqlError + isPgException :: H.Error -> Maybe H.Error isPgException x = Just (traceShow x x)