fix for one of the failing tests (acl for tables added)

src/PostgREST/App.hs

@@ -50,8 +50,8 @@ import PostgREST.PgStructure
 
 import Prelude
 
-app :: [Table] -> [Relation] -> [Column] -> [PrimaryKey] -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
-app allTables allRelations allColumns allPrimaryKeys conf reqBody req =
+app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response
+app dbstructure conf reqBody role req =
   case (path, verb) of
     -- ([], _) -> do
     --   body <- encode <$> tables (cs schema)
@@ -65,7 +65,7 @@ app allTables allRelations allColumns allPrimaryKeys conf reqBody req =
     --     $ encode (TableOptions cols pkey)
 
     ([], _) -> do
-      let body = encode $ filter (((cs schema)==).tableSchema) allTables
+      let body = encode $ filter (filterTableAcl allTablesAcl role) $ filter (((cs schema)==).tableSchema) allTables
       return $ responseLBS status200 [jsonH, ("Custom", "header")] $ cs body
 
     ([table], "OPTIONS") -> do
@@ -257,8 +257,16 @@ app allTables allRelations allColumns allPrimaryKeys conf reqBody req =
       return $ responseLBS status404 [] ""
 
   where
+    allTables = tables dbstructure
+    allRelations = relations dbstructure
+    allColumns = columns dbstructure
+    allPrimaryKeys = primaryKeys dbstructure
+    allTablesAcl = tablesAcl dbstructure
     filterCol schema table (Column{colSchema=s, colTable=t}) =  s==schema && table==t
     filterPk schema table (PrimaryKey{pkSchema=s, pkTable=t}) =  s==schema && table==t
+
+    filterTableAcl :: [(Text, Text, Text)] -> Text -> Table -> Bool
+    filterTableAcl acl r (Table{tableSchema=s, tableName=n}) = isJust $ find (\(as,an,ar)->as==s && an==n && ar==r) acl
     path          = pathInfo req
     verb          = requestMethod req
     qq            = queryString req

src/PostgREST/Main.hs

@@ -99,10 +99,21 @@ main = do
   pkRes <-  H.session pool $ H.tx txParam $ allprimaryKeys
   let allPrimaryKeys = either (fail . show) id pkRes
 
-  runSettings appSettings $ middle $ \req respond -> do
+  tableAclRes <-  H.session pool $ H.tx txParam $ alltablesAcl
+  let allTablesAcl = either (fail . show) id tableAclRes
+
+
+  let dbstructure = DbStructure {
+    tables=allTables,
+    columns=allColumns,
+    relations=allRelations,
+    primaryKeys=allPrimaryKeys,
+    tablesAcl=allTablesAcl}
+
+  runSettings appSettings $ middle $ \ req respond -> do
     body <- strictRequestBody req
     resOrError <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $
-      authenticated conf (app allTables allRelations allColumns allPrimaryKeys conf body) req
+      authenticated conf (app dbstructure conf body) req
     either (respond . errResponse) respond resOrError
 
   where

src/PostgREST/Middleware.hs

@@ -26,11 +26,12 @@ import PostgREST.Config (AppConfig(..), corsPolicy)
 import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, setUserId)
 import PostgREST.App (contentTypeForAccept)
 import Codec.Binary.Base64.String (decode)
+import PostgREST.Auth (DbRole)
 
 import Prelude
 
 authenticated :: forall s. AppConfig ->
-                 (Request -> H.Tx P.Postgres s Response) ->
+                 (DbRole -> Request -> H.Tx P.Postgres s Response) ->
                  Request -> H.Tx P.Postgres s Response
 authenticated conf app req = do
   attempt <- httpRequesterRole (requestHeaders req)
@@ -39,8 +40,8 @@ authenticated conf app req = do
       return $ responseLBS status400 [] "Malformed basic auth header"
     LoginFailed ->
       return $ responseLBS status401 [] "Invalid username or password"
-    LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app req
-    NoCredentials         -> if anon /= currentRole then runInRole anon "" else app req
+    LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app currentRole req
+    NoCredentials         -> if anon /= currentRole then runInRole anon "" else app currentRole req
 
  where
    jwtSecret = cs $ configJwtSecret conf
@@ -62,7 +63,7 @@ authenticated conf app req = do
    runInRole r uid = do
      setUserId uid
      setRole r
-     app req
+     app r req
 
 
 redirectInsecure :: Application -> Application

src/PostgREST/PgStructure.hs

@@ -311,3 +311,17 @@ allprimaryKeys = do
     AND kc.table_schema NOT IN ('pg_catalog', 'information_schema')
   |]
   return $ map pkFromRow pks
+
+alltablesAcl :: H.Tx P.Postgres s [(Text, Text, Text)]
+alltablesAcl = do
+  acl <- H.listEx $ [H.stmt|
+    SELECT
+      table_schema,
+      table_name,
+      grantee as role
+    FROM information_schema.role_table_grants
+    WHERE
+      table_schema NOT IN ('pg_catalog', 'information_schema') AND
+      privilege_type = 'SELECT'
+  |]
+  return acl

src/PostgREST/Types.hs

@@ -1,6 +1,14 @@
 module PostgREST.Types where
 import Data.Text
 
+data DbStructure = DbStructure {
+  tables :: [Table]
+, columns :: [Column]
+, relations :: [Relation]
+, primaryKeys :: [PrimaryKey]
+, tablesAcl :: [(Text, Text, Text)]
+}
+
 data Table = Table {
   tableSchema :: Text
 , tableName :: Text

test/SpecHelper.hs

@@ -31,6 +31,7 @@ import PostgREST.Config (AppConfig(..))
 import PostgREST.Middleware
 import PostgREST.Error(errResponse)
 import PostgREST.PgStructure
+import PostgREST.Types
 
 isLeft :: Either a b -> Bool
 isLeft (Left _ ) = True
@@ -68,11 +69,22 @@ withApp perform = do
   pkRes <-  H.session pool $ H.tx txParam $ allprimaryKeys
   let allPrimaryKeys = either (fail . show) id pkRes
 
+  tableAclRes <-  H.session pool $ H.tx txParam $ alltablesAcl
+  let allTablesAcl = either (fail . show) id tableAclRes
+
+
+  let dbstructure = DbStructure {
+    tables=allTables,
+    columns=allColumns,
+    relations=allRelations,
+    primaryKeys=allPrimaryKeys,
+    tablesAcl=allTablesAcl}
+
 
   perform $ middle $ \req resp -> do
     body <- strictRequestBody req
     result <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True))
-      $ authenticated cfg (app allTables allRelations allColumns allPrimaryKeys cfg body) req
+      $ authenticated cfg (app dbstructure cfg body) req
     either (resp . errResponse) resp result
 
   where middle = defaultMiddle False