jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into errors

Browse Source 
Conflicts:
	src/Main.hs
	src/Middleware.hs
This commit is contained in:
Adam C. Baker
2014-10-13 17:45:32 -07:00
parent fd237b33b1 bd1d365143
commit 5630ee52fd
7 changed files with 53 additions and 59 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dbapi.cabal
+5 -5
View File
@@ -1,5 +1,5 @@
name: dbapi
version: 0.1.0.0
version: 0.2.0.0
synopsis: The database is your api
license: MIT
license-file: LICENSE
@@ -20,7 +20,7 @@ executable dbapi
, HTTP, convertible
, case-insensitive
, http-types, scientific, time
, bytestring, aeson, network
, bytestring, aeson, network >= 2.6
, text , containers
, optparse-applicative >= 0.9.1 && < 0.10
, unordered-containers
@@ -29,10 +29,10 @@ executable dbapi
, http-media, regex-tdfa
, Ranged-sets
, transformers
, warp-tls
, bcrypt
, base64-string
, split
, network-uri >= 2.6
Other-Modules: Dbapi
, PgStructure
, PgQuery
@@ -55,7 +55,7 @@ Test-Suite spec
, case-insensitive
, wai-extra, wai-cors, containers
, http-types, scientific, time
, bytestring, aeson, network
, bytestring, aeson, network >= 2.6
, text, optparse-applicative
, unordered-containers
, regex-base
@@ -63,7 +63,7 @@ Test-Suite spec
, http-media, regex-tdfa
, Ranged-sets
, transformers
, warp-tls
, bcrypt
, base64-string
, split
, network-uri >= 2.6
src/Dbapi.hs
+1 -2
View File
@@ -47,9 +47,8 @@ import Data.Ranged.Ranges (emptyRange)
data AppConfig = AppConfig {
configDbUri :: String
, configPort :: Int
, configSslCert :: FilePath
, configSslKey :: FilePath
, configAnonRole :: String
, configSecure :: Bool
}
jsonContentType :: (HeaderName, BS.ByteString)
src/Main.hs
+11 -11
View File
@@ -2,14 +2,15 @@
module Main where
import Dbapi
import Middleware (inTransaction, authenticated, withSavepoint, clientErrors)
import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
redirectInsecure)
import Network.Wai.Handler.Warp hiding (Connection)
import Database.HDBC.PostgreSQL (connectPostgreSQL')
import Data.String.Conversions (cs)
import Control.Monad (unless)
import Control.Applicative
import Options.Applicative hiding (columns)
import Network.Wai.Handler.WarpTLS (tlsSettings, runTLS)
import Network.Wai.Middleware.Gzip (gzip, def)
import Network.Wai.Middleware.Cors (cors)
@@ -19,12 +20,10 @@ argParser = AppConfig
<> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
<*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
<> help "port number on which to run HTTP server")
<*> strOption (long "sslcert" <> short 'c' <> metavar "PATH" <> value "test/test.crt"
<> help "path to SSL cert file")
<*> strOption (long "sslkey" <> short 'k' <> metavar "PATH" <> value "test/test.key"
<> help "path to SSL key file")
<*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE"
<> help "postgres role to use for non-authenticated requests")
<*> switch (long "secure" <> short 's'
<> help "Redirect all requests to HTTPS" )
main :: IO ()
main = do
@@ -32,13 +31,14 @@ main = do
let port = configPort conf
let dburi = configDbUri conf
let tls = tlsSettings (configSslCert conf) (configSslKey conf)
let settings = setPort port defaultSettings
unless (configSecure conf) $
putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
conn <- connectPostgreSQL' dburi
runTLS tls settings . gzip def . cors corsPolicy . clientErrors $ (
inTransaction . authenticated (cs $ configAnonRole conf) . withSavepoint) app conn
run port $ (if configSecure conf then redirectInsecure else id)
. 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"
src/Middleware.hs
+33 -9
View File
@@ -5,6 +5,7 @@ module Middleware where
import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
import Data.Maybe (fromMaybe)
import Data.Monoid (mconcat)
import Database.HDBC (runRaw)
import Database.HDBC.PostgreSQL (Connection)
@@ -12,29 +13,31 @@ import Database.HDBC.Types (SqlError(..))
import Data.String.Conversions(cs)
import qualified Data.ByteString.Char8 as BS
import Control.Exception (finally, throw, catchJust, catch, SomeException,
import Control.Exception (finally, throw, catchJust, catch, SomeException,
bracket_)
import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization)
import Network.HTTP.Types.Status (status400, status401)
import Network.Wai (Application, requestHeaders, responseLBS)
import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
hLocation)
import Network.HTTP.Types.Status (status400, status401, status301)
import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
rawQueryString, isSecure)
import Network.URI (URI(..), parseURI)
import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
import Codec.Binary.Base64.String (decode)
inTransaction :: (Connection -> Application) -> (Connection -> Application)
inTransaction app conn req respond =
finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
withSavepoint :: (Connection -> Application) -> Connection -> Application
withSavepoint :: (Connection -> Application) -> (Connection -> Application)
withSavepoint app conn req respond = 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)
authenticated :: BS.ByteString -> (Connection -> Application)
-> Connection -> Application
authenticated :: BS.ByteString -> (Connection -> Application) ->
(Connection -> Application)
authenticated anon app conn req respond = do
attempt <- httpRequesterRole (requestHeaders req)
case attempt of
@@ -58,7 +61,6 @@ authenticated anon app conn req respond = do
_ -> return MalformedAuth
_ -> return NoCredentials
instance ToJSON SqlError where
toJSON t = object [
"error" .= object [
@@ -78,3 +80,25 @@ clientErrors app req respond =
where
isPgException :: SqlError -> Maybe SqlError
isPgException = Just
redirectInsecure :: Application -> Application
redirectInsecure app req respond = do
let hdrs = requestHeaders req
host = lookup "host" hdrs
uriM = parseURI . cs =<< mconcat [
Just "https://",
host,
Just $ rawPathInfo req,
Just $ rawQueryString req]
isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"
if not (isSecure req || isHerokuSecure)
then case uriM of
Just uri ->
respond $ responseLBS status301 [
(hLocation, cs . show $ uri { uriScheme = "https:" })
] ""
Nothing ->
respond $ responseLBS status400 [] "SSL is required"
else app req respond
test/SpecHelper.hs
+3 -3
View File
@@ -29,7 +29,7 @@ isLeft (Left _ ) = True
isLeft _ = False
cfg :: AppConfig
cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "test/test.crt" "test/test.key" "dbapi_anonymous"
cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False
openConnection :: IO Connection
openConnection = connectPostgreSQL' $ configDbUri cfg
@@ -88,8 +88,8 @@ authHeader user pass =
-- for hspec-wai
pending_ :: WaiSession ()
pending_ = liftIO pending
pending_ = liftIO Test.Hspec.pending
-- for hspec-wai
pendingWith_ :: String -> WaiSession ()
pendingWith_ = liftIO . pendingWith
pendingWith_ = liftIO . Test.Hspec.pendingWith
test/test.crt
-14
View File
@@ -1,14 +0,0 @@
-----BEGIN CERTIFICATE-----
MIICLTCCAZYCCQCj6GtISfdwNjANBgkqhkiG9w0BAQUFADBbMQswCQYDVQQGEwJV
UzELMAkGA1UECBMCQ0ExFjAUBgNVBAcTDVNhbiBGcmFuY2lzY28xEzARBgNVBAoT
Ckxvb3AgUmVjdXIxEjAQBgNVBAMTCWxvY2FsaG9zdDAeFw0xNDEwMDMyMDQyNDNa
Fw0xNTEwMDMyMDQyNDNaMFsxCzAJBgNVBAYTAlVTMQswCQYDVQQIEwJDQTEWMBQG
A1UEBxMNU2FuIEZyYW5jaXNjbzETMBEGA1UEChMKTG9vcCBSZWN1cjESMBAGA1UE
AxMJbG9jYWxob3N0MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC5gFnTRBge
mXdkCMD+OycujZrCWOOLIDBqRr7kDbxVXqz/TKHRVx6bz88g9egzvR2HLyA418kd
dAu+lMmjrRv/k0Lnk/UvC1aj0huoHpOVUgOwy3qS4cE663uU5qsrgf4RDP7bLDcQ
FDW02SQ2n5ryv8nB9TSYpvQvYPiTMMKdrwIDAQABMA0GCSqGSIb3DQEBBQUAA4GB
AAQwkC+GSaGArAKdMIqs8/55KAjyNd11MupiCWsu1cwBJ4QJc1PxrYOMLMYnU06J
I0v1bJ6mG06/Js0r2FHM0NXSQO+7DLPWu4LchoBgFt4ZRm2+GbLzFrfu41yn5mJN
VeUxCBQ9hOrE8Kwe+/9IUUVPxlISF+YHOyF3DxWUViak
-----END CERTIFICATE-----
test/test.key
-15
View File
@@ -1,15 +0,0 @@
-----BEGIN RSA PRIVATE KEY-----
MIICXQIBAAKBgQC5gFnTRBgemXdkCMD+OycujZrCWOOLIDBqRr7kDbxVXqz/TKHR
Vx6bz88g9egzvR2HLyA418kddAu+lMmjrRv/k0Lnk/UvC1aj0huoHpOVUgOwy3qS
4cE663uU5qsrgf4RDP7bLDcQFDW02SQ2n5ryv8nB9TSYpvQvYPiTMMKdrwIDAQAB
AoGAZZD0Haub9S0b5KayXMCwnFmmEaEvvR47xATGQgGPS8LRv9sKgp9LwA4RH7/k
imeSglD4OIdVs421XH0ExlxjBiV5EzTCgLUyKbfA//xUy9ggXD1Ks4vIHL0c1DM4
g6/zylN7CQtt4Bb6YdWDSAUXIl3U5Dj1kG7BWuXfJTxCx7ECQQDyLxoQRNkPwKP/
xeOqfCgwyD52rnUJ7g9UViFcCU2ZLLEYxE4b3FECcwhOfUlxYvKdOx03Qts0taow
dPU/BEXHAkEAxBVyKwTJ0T6rQmcQEx3WuaBhSjXgZigUN4OdXMg+LSO+1MON6Nhm
J9ociy+xvfd0Cf3yABaAEU/hZ+Pmk2DI2QJBAO/XU8F+3VQrXH7l9HSXJppBBRM1
7HScDRRhhAIIuI+UYgJ8DjqrMpLxZu2MSBqBenHZ5DIhBMOrkVMR0PrKeWsCQCHh
gsSkIysgpP7oSALFmSCh8a2c+ZUtP7EH8NzjTLsH/iVNVOvy2FPygBQcvZ2RcF95
naMeQCq9nrkQy/qTMqECQQDa1WjWS2ngwqGzHovqiKRg3lQ8MFNlvlStAQl8+9h0
KJj8Rl6h+gO8eretBIe+y5j/hCC90xlJotzwO3jJF6Hc
-----END RSA PRIVATE KEY-----