From 850e5cc2d4ef96a2dd2a43c9b8d4c1355eb7a148 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Sat, 13 May 2017 23:09:56 +0300 Subject: Add end-point for checking access in a bunch --- src/Sproxy/Application.hs | 37 ++++++++++++++++++++++++++++++++-- src/Sproxy/Application/Access.hs | 23 +++++++++++++++++++++ src/Sproxy/Server/DB.hs | 43 +++++++++++++++++++++++++++------------- 3 files changed, 87 insertions(+), 16 deletions(-) create mode 100644 src/Sproxy/Application/Access.hs (limited to 'src') 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 -- cgit v1.2.3