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,72 +72,85 @@ 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 (path, verb) of
+  case BS.split ' ' (cs auth) of
-      ([], _) ->
+    ("Basic " : b64 : _) ->
-        responseLBS status200 [jsonContentType] <$> printTables ver conn
+      case BS.split ':' $ cs (decode $ cs b64) of
+        (u:p:_) -> signInRole u p conn
+        _ -> return Nothing
+    _ -> return Nothing
 
-      ([table], "OPTIONS") ->
+app :: Connection -> DbRole -> Application
-        responseLBS status200 [jsonContentType] <$>
+app conn anonymous req respond = do
-          printColumns ver (cs table) conn
+  r <- try $ do
+    role <- fromMaybe anonymous <$> httpRequesterRole hdrs conn
 
-      ([table], "GET") ->
+    bracket_ (pgSetRole conn role) (pgResetRole conn) $
-        if range == Just emptyRange
+      case (path, verb) of
-        then return $ responseLBS status416 [] "HTTP Range error"
+        ([], _) ->
-        else do
+          responseLBS status200 [jsonContentType] <$> printTables ver conn
-          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
 
-      ([table], "POST") ->
+        ([table], "OPTIONS") ->
-        jsonBodyAction req (\row -> do
+          responseLBS status200 [jsonContentType] <$>
-          allvals <- insert ver table row conn
+            printColumns ver (cs table) 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], "PUT") ->
+        ([table], "GET") ->
-        jsonBodyAction req (\row -> do
+          if range == Just emptyRange
-          keys <- primaryKeyColumns ver (cs table) conn
+          then return $ responseLBS status416 [] "HTTP Range error"
-          let specifiedKeys = map (cs . fst) qq
+          else do
-          if S.fromList keys /= S.fromList specifiedKeys
+            r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn
-            then return $ responseLBS status405 []
+            let canonical = urlEncodeVars $ sort $
-                 "You must speficy all and only primary keys as params"
+                            map (join (***) cs) $
-            else
+                            parseSimpleQuery $
-              if isJust cRange
+                            rawQueryString req
-                 then return $ responseLBS status400 []
+            return $ addHeaders [
-                      "Content-Range is not allowed in PUT request"
+              ("Content-Location",
-              else do
+               "/" <> cs table <> "?" <> cs canonical
-                cols <- columns ver (cs table) conn
+              )] r
-                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 [] ""
+        ([table], "POST") ->
-                    else responseLBS status400 []
+          jsonBodyAction req (\row -> do
-                       "You must specify all columns in PUT request"
+            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], "PUT") ->
-        return $ responseLBS status404 [] ""
+          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)
+    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