WIP: change db roles based on HTTP basic auth headers

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

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,9 +72,22 @@ filterByKeys m keys =
   if null keys then m else
     m `intersection` fromList (zip keys $ repeat undefined)
 
-app :: Connection -> Application
+httpRequesterRole :: RequestHeaders -> Connection -> IO(Maybe DbRole)
-app conn req respond = do
+httpRequesterRole hdrs conn = do
-  r <- try $
+  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
+
+app :: Connection -> DbRole -> Application
+app conn anonymous req respond = do
+  r <- try $ do
+    role <- fromMaybe anonymous <$> httpRequesterRole hdrs conn
+
+    bracket_ (pgSetRole conn role) (pgResetRole conn) $
       case (path, verb) of
         ([], _) ->
           responseLBS status200 [jsonContentType] <$> printTables ver conn
@@ -142,9 +158,10 @@ app conn req respond = do
     path   = pathInfo req
     verb   = requestMethod req
     qq     = queryString req
-    ver    = fromMaybe "1" $ requestedVersion (requestHeaders req)
+    hdrs   = requestHeaders req
-    range  = requestedRange (requestHeaders req)
+    ver    = fromMaybe "1" $ requestedVersion hdrs
-    cRange = requestedContentRange (requestHeaders req)
+    range  = requestedRange hdrs
+    cRange = requestedContentRange hdrs
 
 respondWithRangedResult :: RangedResult -> Response
 respondWithRangedResult rr =

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"

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" []

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]

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