From 598d70579ec0e8c52a250373e950a139d7ff1586 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 29 Sep 2014 22:52:02 -0700 Subject: [PATCH] WIP: change db roles based on HTTP basic auth headers --- dbapi.cabal | 2 + src/Dbapi.hs | 143 ++++++++++++++++++++++----------------- src/Main.hs | 5 +- src/PgQuery.hs | 19 ++++-- test/SpecHelper.hs | 4 +- test/Unit/PgQuerySpec.hs | 8 ++- 6 files changed, 109 insertions(+), 72 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 99a3a48c7..7f6d02c68 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -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 diff --git a/src/Dbapi.hs b/src/Dbapi.hs index 65d27f5be..030aa0fed 100644 --- a/src/Dbapi.hs +++ b/src/Dbapi.hs @@ -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 = diff --git a/src/Main.hs b/src/Main.hs index 7d89c2890..631917791 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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" diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 431088c78..a1a2f98fd 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -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" [] diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index d0ef88fc2..faff3e21d 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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] diff --git a/test/Unit/PgQuerySpec.hs b/test/Unit/PgQuerySpec.hs index f1ca14350..8d0e317b4 100644 --- a/test/Unit/PgQuerySpec.hs +++ b/test/Unit/PgQuerySpec.hs @@ -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