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

WIP: change db roles based on HTTP basic auth headers

Browse Source
This commit is contained in:
Joe Nelson
2014-09-29 22:52:02 -07:00
parent b29e07538c
commit 598d70579e
6 changed files with 109 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dbapi.cabal
+2
View File
@@ -31,6 +31,7 @@ executable dbapi
, transformers
, warp-tls
, bcrypt
, base64-string
Other-Modules: Dbapi
, PgStructure
, PgQuery
@@ -62,3 +63,4 @@ Test-Suite spec
, transformers
, warp-tls
, bcrypt
, base64-string
src/Dbapi.hs
+80 -63
View File
@@ -7,6 +7,7 @@ import Types (SqlRow, getRow)
import Control.Exception (try)
import Control.Monad (join)
import Control.Exception.Base (bracket_)
import Control.Arrow ((***))
import Control.Applicative
import Options.Applicative hiding (columns)
@@ -40,6 +41,7 @@ import qualified Data.Aeson as JSON
import PgQuery
import RangeQuery
import Data.Ranged.Ranges (emptyRange)
import Codec.Binary.Base64.String (decode)
-- }}}
@@ -48,6 +50,7 @@ data AppConfig = AppConfig {
, configPort :: Int
, configSslCert :: FilePath
, configSslKey :: FilePath
, configAnonRole :: String
}
jsonContentType :: (HeaderName, BS.ByteString)
@@ -69,72 +72,85 @@ filterByKeys m keys =
if null keys then m else
m `intersection` fromList (zip keys $ repeat undefined)
app :: Connection -> Application
app conn req respond = do
r <- try $
case (path, verb) of
([], _) ->
responseLBS status200 [jsonContentType] <$> printTables ver conn
httpRequesterRole :: RequestHeaders -> Connection -> IO(Maybe DbRole)
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 Nothing
_ -> return Nothing
([table], "OPTIONS") ->
responseLBS status200 [jsonContentType] <$>
printColumns ver (cs table) conn
app :: Connection -> DbRole -> Application
app conn anonymous req respond = do
r <- try $ do
role <- fromMaybe anonymous <$> httpRequesterRole hdrs conn
([table], "GET") ->
if range == Just emptyRange
then return $ responseLBS status416 [] "HTTP Range error"
else do
r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn
let canonical = urlEncodeVars $ sort $
map (join (***) cs) $
parseSimpleQuery $
rawQueryString req
return $ addHeaders [
("Content-Location",
"/" <> cs table <> "?" <> cs canonical
)] r
bracket_ (pgSetRole conn role) (pgResetRole conn) $
case (path, verb) of
([], _) ->
responseLBS status200 [jsonContentType] <$> printTables ver conn
([table], "POST") ->
jsonBodyAction req (\row -> do
allvals <- insert ver table row conn
keys <- primaryKeyColumns ver (cs table) conn
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
return $ responseLBS status201
[ jsonContentType
, (hLocation, "/" <> cs table <> "?" <> cs params)
] ""
)
([table], "OPTIONS") ->
responseLBS status200 [jsonContentType] <$>
printColumns ver (cs table) conn
([table], "PUT") ->
jsonBodyAction req (\row -> do
keys <- primaryKeyColumns ver (cs table) conn
let specifiedKeys = map (cs . fst) qq
if S.fromList keys /= S.fromList specifiedKeys
then return $ responseLBS status405 []
"You must speficy all and only primary keys as params"
else
if isJust cRange
then return $ responseLBS status400 []
"Content-Range is not allowed in PUT request"
else do
cols <- columns ver (cs table) conn
let colNames = S.fromList $ map (cs . colName) cols
let specifiedCols = S.fromList $ map fst $ getRow row
if colNames == specifiedCols then do
allvals <- upsert ver table row qq conn
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
return $ responseLBS status201
[ jsonContentType
, (hLocation, "/" <> cs table <> "?" <> cs params)
] ""
([table], "GET") ->
if range == Just emptyRange
then return $ responseLBS status416 [] "HTTP Range error"
else do
r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn
let canonical = urlEncodeVars $ sort $
map (join (***) cs) $
parseSimpleQuery $
rawQueryString req
return $ addHeaders [
("Content-Location",
"/" <> cs table <> "?" <> cs canonical
)] r
else return $ if S.null colNames then responseLBS status404 [] ""
else responseLBS status400 []
"You must specify all columns in PUT request"
)
([table], "POST") ->
jsonBodyAction req (\row -> do
allvals <- insert ver table row conn
keys <- primaryKeyColumns ver (cs table) conn
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
return $ responseLBS status201
[ jsonContentType
, (hLocation, "/" <> cs table <> "?" <> cs params)
] ""
)
(_, _) ->
return $ responseLBS status404 [] ""
([table], "PUT") ->
jsonBodyAction req (\row -> do
keys <- primaryKeyColumns ver (cs table) conn
let specifiedKeys = map (cs . fst) qq
if S.fromList keys /= S.fromList specifiedKeys
then return $ responseLBS status405 []
"You must speficy all and only primary keys as params"
else
if isJust cRange
then return $ responseLBS status400 []
"Content-Range is not allowed in PUT request"
else do
cols <- columns ver (cs table) conn
let colNames = S.fromList $ map (cs . colName) cols
let specifiedCols = S.fromList $ map fst $ getRow row
if colNames == specifiedCols then do
allvals <- upsert ver table row qq conn
let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
return $ responseLBS status201
[ jsonContentType
, (hLocation, "/" <> cs table <> "?" <> cs params)
] ""
else return $ if S.null colNames then responseLBS status404 [] ""
else responseLBS status400 []
"You must specify all columns in PUT request"
)
(_, _) ->
return $ responseLBS status404 [] ""
respond $ either sqlErrorHandler id r
@@ -142,9 +158,10 @@ app conn req respond = do
path = pathInfo req
verb = requestMethod req
qq = queryString req
ver = fromMaybe "1" $ requestedVersion (requestHeaders req)
range = requestedRange (requestHeaders req)
cRange = requestedContentRange (requestHeaders req)
hdrs = requestHeaders req
ver = fromMaybe "1" $ requestedVersion hdrs
range = requestedRange hdrs
cRange = requestedContentRange hdrs
respondWithRangedResult :: RangedResult -> Response
respondWithRangedResult rr =
src/Main.hs
+4 -1
View File
@@ -6,6 +6,7 @@ module Main where
import Dbapi
import Network.Wai.Handler.Warp hiding (Connection)
import Database.HDBC.PostgreSQL (connectPostgreSQL')
import Data.String.Conversions (cs)
import Control.Applicative
import Options.Applicative hiding (columns)
@@ -24,6 +25,8 @@ argParser = AppConfig
<> 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" <> value "dbapi_anon"
<> help "postgres role to use for non-authenticated requests")
main :: IO ()
main = do
@@ -36,7 +39,7 @@ main = do
Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
conn <- connectPostgreSQL' dburi
runTLS tls settings $ gzip def $ app conn
runTLS tls settings $ gzip def $ app conn (cs $ configAnonRole conf)
where
describe = progDesc "create a REST API to an existing Postgres database"
src/PgQuery.hs
+15 -4
View File
@@ -8,7 +8,10 @@ module PgQuery (
upsert,
addUser,
signInRole,
pgSetRole,
pgResetRole,
RangedResult(..),
DbRole
) where
import Data.Text (Text)
@@ -19,7 +22,7 @@ import Data.List (intersperse, intercalate)
import Data.Monoid ((<>), mconcat)
import qualified Data.Map as M
import Control.Monad (join)
import Control.Monad (join, void)
import qualified RangeQuery as R
import qualified Data.ByteString.Char8 as BS
@@ -44,7 +47,7 @@ data RangedResult = RangedResult {
type QuotedSql = (String, [SqlValue])
type Schema = String
type DbRole = String
type DbRole = BS.ByteString
getRows :: Schema -> String -> Net.Query -> Maybe R.NonnegRange -> Connection -> IO RangedResult
getRows schema table qq range conn = do
@@ -120,7 +123,7 @@ insert schema table row conn = do
Just m <- fetchRowMap stmt
return m
addUser :: String -> String -> String -> Connection -> IO ()
addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Connection -> IO ()
addUser identity pass role conn = do
hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy $ cs pass
_ <- insert "dbapi" "auth" (SqlRow [
@@ -128,7 +131,7 @@ addUser identity pass role conn = do
]) conn
return ()
signInRole :: String -> String -> Connection -> IO(Maybe DbRole)
signInRole :: BS.ByteString -> BS.ByteString -> Connection -> IO(Maybe DbRole)
signInRole user pass conn = do
u <- quickQuery conn "select pass, rolname from dbapi.auth where id = ?" [toSql user]
return $ case u of
@@ -185,3 +188,11 @@ populateSql conn sql = do
ph :: [a] -> String
ph = intercalate ", " . map (const "?::varchar")
pgSetRole :: Connection -> DbRole -> IO ()
pgSetRole conn role = do
query <- populateSql conn ("set role %I", [toSql role])
void $ run conn query []
pgResetRole :: Connection -> IO ()
pgResetRole conn = void $ run conn "reset role" []
test/SpecHelper.hs
+2 -2
View File
@@ -18,7 +18,7 @@ import qualified Data.ByteString.Char8 as BS
import Dbapi (app, AppConfig(..))
cfg :: AppConfig
cfg = AppConfig "postgres://postgres:@localhost:5432/dbapi_test" 9000 "test/test.crt" "test/test.key"
cfg = AppConfig "postgres://postgres:@localhost:5432/dbapi_test" 9000 "test/test.crt" "test/test.key" "postgres"
openConnection :: IO Connection
openConnection = connectPostgreSQL' $ configDbUri cfg
@@ -40,7 +40,7 @@ dbWithSchema action = withDatabaseConnection $ \c -> do
appWithFixture :: ActionWith Application -> IO ()
appWithFixture action = withDatabaseConnection $ \c -> do
runRaw c "begin;"
action $ app c
action $ app c "postgres"
rollback c
rangeHdrs :: ByteRange -> [Header]
test/Unit/PgQuerySpec.hs
+6 -2
View File
@@ -11,12 +11,16 @@ import PgQuery (insert, addUser, signInRole)
import Types (SqlRow(SqlRow))
import TestTypes (fromList, incStr, incNullableStr, incInsert, incId)
import Data.Map (toList)
import Data.Monoid ((<>))
import Data.String.Conversions (cs)
import Control.Arrow
import SpecHelper(dbWithSchema)
quickALQuery :: IConnection conn => conn -> String -> [SqlValue] -> IO [[(String, SqlValue)]]
quickALQuery :: IConnection conn => conn ->
String ->
[SqlValue] ->
IO [[(String, SqlValue)]]
quickALQuery conn q bind = do
sth <- prepare conn q
_ <- execute sth bind
@@ -61,7 +65,7 @@ spec = around dbWithSchema $ do
r2 <- signInRole user pass conn
r2 `shouldBe` Just role
r3 <- signInRole user (pass++"crap") conn
r3 <- signInRole user (pass <> "crap") conn
r3 `shouldBe` Nothing
it "will not add a user with an unknown role" $ \conn -> do