aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Sproxy/Application.hs37
-rw-r--r--src/Sproxy/Application/Access.hs23
-rw-r--r--src/Sproxy/Server/DB.hs43
3 files changed, 87 insertions, 16 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 00:03:50 +0000