Add end-point for checking access in a bunch

5 files changed, 140 insertions, 36 deletions

diff --git a/README.md b/README.md
index 7795fd2..65f6839 100644
--- a/README.md
+++ b/README.md
@@ -140,32 +140,36 @@ Keep in mind that:
 - SQL wildcards (`_` and `%`) are supported for emails, paths (this _will_ change in future versions).
 
 
-HTTP headers passed to the back-end server
-------------------------------------------
+Checking access in a bunch
+--------------------------
 
-All Sproxy headers are UTF8-encoded.
+There is an API end-point for checking access rights in a single POST query:
+`/.sproxy/access`.  Users should be authenticated to use this end-point,
+otherwise the respond will be HTTP 511.
 
+The request body shall be a JSON object like this:
 
-header               | value
--------------------- | -----
-`From:`              | visitor's email address, lower case
-`X-Groups:`          | all groups that granted access to this resource, separated by commas (see the note below)
-`X-Given-Name:`      | the visitor's given (first) name
-`X-Family-Name:`     | the visitor's family (last) name
-`X-Forwarded-Proto:` | the visitor's protocol of an HTTP request, always `https`
-`X-Forwarded-For`    | the visitor's IP address (added to the end of the list if header is already present in client request)
+```json
+{
+  "tag1": {"path": "/foo", "method": "GET"},
+  "tag2": {"path": "/bar", "method": "GET"}
+}
+```
 
+And the respond will contain a JSON array with tag matching path and method
+pairs allowed to the user.  For example:
 
-`X-Groups` denotes an intersection of the groups the visitor belongs to and the groups that granted access:
+```sh
+$ curl -d '{"foo": {"path":"/get", "method":"GET"}, "bar": {"path":"/post", "method":"POST"}}' -XPOST -k 'https://example.ru:8443/.sproxy/access' ...
+["foo","bar"]
 
-Visitor's groups | Granted groups | `X-Groups`
----------------- | -------------- | ---------
-all              | all, devops    | all
-all, devops      | all            | all
-all, devops      | all, devops    | all,devops
-all, devops      | devops         | devops
-devops           | all, devops    | devops
-devops           | all            | Access denied
+$ curl -d '{"foo": {"path":"/get", "method":"POST"}, "bar": {"path":"/post", "method":"POST"}}' -XPOST -k 'https://example.ru:8443/.sproxy/access' ...
+["bar"]
+
+$ curl -d '{"foo": {"path":"/", "method":"POST"}, "bar": {"path":"/post", "method":"GET"}}' -XPOST -k 'https://example.ru:8443/.sproxy/access' ...
+[]
+
+```
 
 
 Logout
@@ -188,6 +192,34 @@ Disallow: /
 ```
 
 
+HTTP headers passed to the back-end server
+------------------------------------------
+
+All Sproxy headers are UTF8-encoded.
+
+
+header               | value
+-------------------- | -----
+`From:`              | visitor's email address, lower case
+`X-Groups:`          | all groups that granted access to this resource, separated by commas (see the note below)
+`X-Given-Name:`      | the visitor's given (first) name
+`X-Family-Name:`     | the visitor's family (last) name
+`X-Forwarded-Proto:` | the visitor's protocol of an HTTP request, always `https`
+`X-Forwarded-For`    | the visitor's IP address (added to the end of the list if header is already present in client request)
+
+
+`X-Groups` denotes an intersection of the groups the visitor belongs to and the groups that granted access:
+
+Visitor's groups | Granted groups | `X-Groups`
+---------------- | -------------- | ---------
+all              | all, devops    | all
+all, devops      | all            | all
+all, devops      | all, devops    | all,devops
+all, devops      | devops         | devops
+devops           | all, devops    | devops
+devops           | all            | Access denied
+
+
 Requirements
 ============
 Sproxy2 is written in Haskell with [GHC](http://www.haskell.org/ghc/).
diff --git a/sproxy2.cabal b/sproxy2.cabal
index ca55701..60179d1 100644
--- a/sproxy2.cabal
+++ b/sproxy2.cabal
@@ -32,6 +32,7 @@ executable sproxy2
     main-is: Main.hs
     other-modules:
       Sproxy.Application
+      Sproxy.Application.Access
       Sproxy.Application.Cookie
       Sproxy.Application.OAuth2
       Sproxy.Application.OAuth2.Common
diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs
index 7376657..5de9474 100644
--- a/src/Sproxy/Application.hs
+++ b/src/Sproxy/Application.hs
@@ -27,7 +27,7 @@ import Data.Word8 (_colon)
 import Foreign.C.Types (CTime(..))
 import Network.HTTP.Client.Conduit (bodyReaderSource)
 import Network.HTTP.Conduit (requestBodySourceChunkedIO, requestBodySourceIO)
-import Network.HTTP.Types (RequestHeaders, ResponseHeaders, methodGet)
+import Network.HTTP.Types (RequestHeaders, ResponseHeaders, methodGet, methodPost)
 import Network.HTTP.Types.Header ( hConnection,
   hContentLength, hContentType, hCookie, hLocation, hTransferEncoding )
 import Network.HTTP.Types.Status ( Status(..), badRequest400, forbidden403, found302,
@@ -39,6 +39,7 @@ import System.FilePath.Glob (Pattern, match)
 import System.Posix.Time (epochTime)
 import Text.InterpolatedString.Perl6 (qc)
 import Web.Cookie (Cookies, parseCookies, renderCookies)
+import qualified Data.Aeson as JSON
 import qualified Network.HTTP.Client as BE
 import qualified Network.Wai as W
 import qualified Web.Cookie as WC
@@ -48,7 +49,7 @@ import Sproxy.Application.Cookie ( AuthCookie(..), AuthUser,
   getGivenNameUtf8 )
 import Sproxy.Application.OAuth2.Common (OAuth2Client(..))
 import Sproxy.Config(BackendConf(..))
-import Sproxy.Server.DB (Database, userExists, userGroups)
+import Sproxy.Server.DB (Database, userAccess, userExists, userGroups)
 import qualified Sproxy.Application.State as State
 import qualified Sproxy.Logging as Log
 
@@ -81,12 +82,22 @@ sproxy key db oa2 backends = logException $ \req resp -> do
             ["robots.txt"] -> get robots req resp
             (".sproxy":proxy) ->
               case proxy of
+
                 ["logout"] -> get (logout key cookieName cookieDomain) req resp
+
                 ["oauth2", provider] ->
                     case HM.lookup provider oa2 of
                       Nothing -> notFound "OAuth2 provider" req resp
                       Just oa2c -> get (oauth2callback key db (provider, oa2c) be) req resp
+
+                ["access"] -> do
+                  now <- Just <$> epochTime
+                  case extractCookie key now cookieName req of
+                    Nothing -> authenticationRequired key oa2 req resp
+                    Just (authCookie, _) -> post (checkAccess db authCookie) req resp
+
                 _ -> notFound "proxy" req resp
+
             _ -> do
               now <- Just <$> epochTime
               case extractCookie key now cookieName req of
@@ -195,6 +206,20 @@ authorize db (authCookie, otherCookies) req = do
     setCookies cs = insert hCookie (toByteString . renderCookies $ cs)
 
 
+checkAccess :: Database -> AuthCookie -> W.Application
+checkAccess db authCookie req resp = do
+  let email = getEmail . acUser $ authCookie
+      domain = decodeUtf8 . fromJust $ requestDomain req
+  body <- W.strictRequestBody req
+  case JSON.eitherDecode' body of
+    Left err -> badRequest err req resp
+    Right inq -> do
+      Log.debug $ "access <<< " ++ show inq
+      tags <- userAccess db email domain inq
+      Log.debug $ "access >>> " ++ show tags
+      resp $ W.responseLBS ok200 [(hContentType, "application/json")] (JSON.encode tags)
+
+
 -- XXX If something seems strange, think about HTTP/1.1 <-> HTTP/1.0.
 -- FIXME For HTTP/1.0 backends we might need an option
 -- FIXME in config file. HTTP Client does HTTP/1.1 by default.
@@ -380,6 +405,14 @@ get app req resp
     resp $ W.responseLBS methodNotAllowed405 [("Allow", "GET")] "Method Not Allowed"
 
 
+post :: W.Middleware
+post app req resp
+  | W.requestMethod req == methodPost = app req resp
+  | otherwise = do
+    Log.warn $ "405 Method Not Allowed: " ++ showReq req
+    resp $ W.responseLBS methodNotAllowed405 [("Allow", "POST")] "Method Not Allowed"
+
+
 redirectURL :: W.Request -> Text -> ByteString
 redirectURL req provider =
   "https://" <> fromJust (W.requestHeaderHost req)
diff --git a/src/Sproxy/Application/Access.hs b/src/Sproxy/Application/Access.hs
new file mode 100644
index 0000000..d8984ee
--- /dev/null
+++ b/src/Sproxy/Application/Access.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Sproxy.Application.Access (
+  Inquiry
+, Question(..)
+) where
+
+import Data.Aeson (FromJSON)
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+
+data Question = Question {
+  path :: Text
+, method :: Text
+} deriving (Generic, Show)
+
+instance FromJSON Question
+
+type Inquiry = HashMap Text Question
+
diff --git a/src/Sproxy/Server/DB.hs b/src/Sproxy/Server/DB.hs
index b07a0a0..662a9c7 100644
--- a/src/Sproxy/Server/DB.hs
+++ b/src/Sproxy/Server/DB.hs
@@ -3,6 +3,7 @@
 module Sproxy.Server.DB (
   Database
 , DataSource(..)
+, userAccess
 , userExists
 , userGroups
 , start
@@ -10,18 +11,20 @@ module Sproxy.Server.DB (
 
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Exception (SomeException, bracket, catch, finally)
-import Control.Monad (forever, void)
+import Control.Monad (filterM, forever, void)
 import Data.ByteString.Char8 (pack)
 import Data.Pool (Pool, createPool, withResource)
 import Data.Text (Text, toLower, unpack)
 import Data.Yaml (decodeFileEither)
 import Database.SQLite.Simple (NamedParam((:=)))
 import Text.InterpolatedString.Perl6 (q, qc)
+import qualified Data.HashMap.Strict as HM
 import qualified Database.PostgreSQL.Simple as PG
 import qualified Database.SQLite.Simple as SQLite
 
 import Sproxy.Server.DB.DataFile ( DataFile(..), GroupMember(..),
   GroupPrivilege(..), PrivilegeRule(..) )
+import qualified Sproxy.Application.Access as A
 import qualified Sproxy.Logging as Log
 
 
@@ -61,19 +64,19 @@ userExists db email = do
   return $ head r
 
 
-userGroups :: Database -> Text -> Text -> Text -> Text -> IO [Text]
-userGroups db email domain path method =
-  withResource db $ \c -> fmap SQLite.fromOnly <$> SQLite.queryNamed c [q|
-      SELECT gm."group" FROM group_privilege gp JOIN group_member gm ON gm."group"  = gp."group"
-      WHERE :email LIKE gm.email
-      AND gp.domain = :domain
-      AND gp.privilege IN (
-        SELECT privilege FROM privilege_rule
-        WHERE domain = :domain
-        AND :path LIKE path
-        AND method = :method
-        ORDER BY length(path) - length(replace(path, '/', '')) DESC LIMIT 1
-      )
+userGroups_ :: SQLite.Connection -> Text -> Text -> Text -> Text -> IO [Text]
+userGroups_ c email domain path method =
+  fmap SQLite.fromOnly <$> SQLite.queryNamed c [q|
+    SELECT gm."group" FROM group_privilege gp JOIN group_member gm ON gm."group"  = gp."group"
+    WHERE :email LIKE gm.email
+    AND gp.domain = :domain
+    AND gp.privilege IN (
+      SELECT privilege FROM privilege_rule
+      WHERE domain = :domain
+      AND :path LIKE path
+      AND method = :method
+      ORDER BY length(path) - length(replace(path, '/', '')) DESC LIMIT 1
+    )
   |] [ ":email"  := email -- XXX always in lower case
      , ":domain" := toLower domain
      , ":path"   := path
@@ -81,6 +84,18 @@ userGroups db email domain path method =
      ]
 
 
+userAccess :: Database -> Text -> Text -> A.Inquiry -> IO [Text]
+userAccess db email domain inq = do
+  let permitted c (_, qn) =
+        not . null <$> userGroups_ c email domain (A.path qn) (A.method qn)
+  map fst <$> withResource db (\c -> filterM (permitted c) (HM.toList inq))
+
+
+userGroups :: Database -> Text -> Text -> Text -> Text -> IO [Text]
+userGroups db email domain path method =
+  withResource db $ \c -> userGroups_ c email domain path method
+
+
 populate :: Database -> Maybe DataSource -> IO ()
 
 populate db Nothing = do