aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy
diff options
context:
space:
mode:
Diffstat (limited to 'src/Sproxy')
-rw-r--r--src/Sproxy/Config.hs2
-rw-r--r--src/Sproxy/Server.hs29
-rw-r--r--src/Sproxy/Server/DB.hs46
-rw-r--r--src/Sproxy/Server/DB/DataFile.hs69
4 files changed, 133 insertions, 13 deletions
diff --git a/src/Sproxy/Config.hs b/src/Sproxy/Config.hs
index 30a8bae..e76b436 100644
--- a/src/Sproxy/Config.hs
+++ b/src/Sproxy/Config.hs
@@ -27,6 +27,7 @@ data ConfigFile = ConfigFile {
, cfListen80 :: Maybe Bool
, cfBackends :: [BackendConf]
, cfOAuth2 :: HashMap Text OAuth2Conf
+, cfDataFile :: Maybe FilePath
, cfDatabase :: Maybe String
, cfPgPassFile :: Maybe FilePath
, cfHTTP2 :: Bool
@@ -45,6 +46,7 @@ instance FromJSON ConfigFile where
<*> m .:? "listen80"
<*> m .: "backends"
<*> m .: "oauth2"
+ <*> m .:? "datafile"
<*> m .:? "database"
<*> m .:? "pgpassfile"
<*> m .:? "http2" .!= True
diff --git a/src/Sproxy/Server.hs b/src/Sproxy/Server.hs
index 98e9d56..5c80e44 100644
--- a/src/Sproxy/Server.hs
+++ b/src/Sproxy/Server.hs
@@ -67,13 +67,8 @@ server configFile = do
setGroupID $ userGroupID u
setUserID $ userID u
- case cfPgPassFile cf of
- Nothing -> return ()
- Just f -> do
- Log.info $ "pgpassfile: " ++ show f
- setEnv "PGPASSFILE" f
-
- db <- DB.start (cfHome cf) (newDataSource cf)
+ ds <- newDataSource cf
+ db <- DB.start (cfHome cf) ds
key <- maybe
(Log.info "using new random key" >> getEntropy 32)
@@ -112,11 +107,23 @@ server configFile = do
(sproxy key db oauth2clients backends)
-newDataSource :: ConfigFile -> Maybe DB.DataSource
+newDataSource :: ConfigFile -> IO (Maybe DB.DataSource)
newDataSource cf =
- case cfDatabase cf of
- Just str -> Just $ DB.PostgreSQL str
- Nothing -> Nothing
+ case (cfDataFile cf, cfDatabase cf) of
+ (Nothing, Just str) -> do
+ case cfPgPassFile cf of
+ Nothing -> return ()
+ Just f -> do
+ Log.info $ "pgpassfile: " ++ show f
+ setEnv "PGPASSFILE" f
+ return . Just $ DB.PostgreSQL str
+
+ (Just f, Nothing) -> return . Just $ DB.File f
+
+ (Nothing, Nothing) -> return Nothing
+ _ -> do
+ Log.error "only one data source can be used"
+ exitFailure
newOAuth2Client :: (Text, OAuth2Conf) -> IO (Text, OAuth2Client)
diff --git a/src/Sproxy/Server/DB.hs b/src/Sproxy/Server/DB.hs
index 90e2abd..2823ba0 100644
--- a/src/Sproxy/Server/DB.hs
+++ b/src/Sproxy/Server/DB.hs
@@ -14,17 +14,20 @@ import Control.Monad (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 Database.PostgreSQL.Simple as PG
import qualified Database.SQLite.Simple as SQLite
+import Sproxy.Server.DB.DataFile ( DataFile(..), GroupMember(..),
+ GroupPrivilege(..), PrivilegeRule(..) )
import qualified Sproxy.Logging as Log
type Database = Pool SQLite.Connection
-data DataSource = PostgreSQL String -- | File FilePath
+data DataSource = PostgreSQL String | File FilePath
{- TODO:
- Hash remote tables and update the local only when the remote change
@@ -77,6 +80,12 @@ userGroups db email domain path method =
, ":method" := method -- XXX case-sensitive by RFC2616
]
+-- FIXME short-cut for https://github.com/nurpax/sqlite-simple/issues/50
+-- FIXME nextRow is the only way to execute a prepared statement
+-- FIXME with bound parameters, but we don't expect any results.
+submit :: SQLite.Statement -> IO ()
+submit st = void (SQLite.nextRow st :: IO (Maybe [Int]))
+
populate :: Database -> Maybe DataSource -> IO ()
@@ -87,6 +96,40 @@ populate db Nothing = do
createGroupPrivilege c
createPrivilegeRule c
+populate db (Just (File f)) = do
+ Log.info $ "db: reading " ++ show f
+ r <- decodeFileEither f
+ case r of
+ Left e -> Log.error $ f ++ ": " ++ show e
+ Right df ->
+ withResource db $ \c -> SQLite.withTransaction c $ do
+ dropGroupMember c
+ createGroupMember c
+ SQLite.withStatement c
+ [q|INSERT INTO group_member("group", email) VALUES (?, ?)|]
+ $ \st -> mapM_ (\gm -> SQLite.withBind st
+ (gmGroup gm, toLower $ gmEmail gm)
+ (submit st)
+ ) (groupMember df)
+
+ dropGroupPrivilege c
+ createGroupPrivilege c
+ SQLite.withStatement c
+ [q|INSERT INTO group_privilege("group", domain, privilege) VALUES (?, ?, ?)|]
+ $ \st -> mapM_ (\gp -> SQLite.withBind st
+ (gpGroup gp, toLower $ gpDomain gp, gpPrivilege gp)
+ (submit st)
+ ) (groupPrivilege df)
+
+ dropPrivilegeRule c
+ createPrivilegeRule c
+ SQLite.withStatement c
+ [q|INSERT INTO privilege_rule(domain, privilege, path, method) VALUES (?, ?, ?, ?)|]
+ $ \st -> mapM_ (\pr -> SQLite.withBind st
+ (toLower $ prDomain pr, prPrivilege pr, prPath pr, prMethod pr)
+ (submit st)
+ ) (privilegeRule df)
+
-- XXX We keep only required minimum of the data, without any integrity check.
-- XXX Integrity check should be done somewhere else, e. g. in the master PostgreSQL database,
-- XXX or during importing the config file.
@@ -155,7 +198,6 @@ createGroupPrivilege c = SQLite.execute_ c [q|
)
|]
-
dropPrivilegeRule :: SQLite.Connection -> IO ()
dropPrivilegeRule c = SQLite.execute_ c "DROP TABLE IF EXISTS privilege_rule"
diff --git a/src/Sproxy/Server/DB/DataFile.hs b/src/Sproxy/Server/DB/DataFile.hs
new file mode 100644
index 0000000..efac923
--- /dev/null
+++ b/src/Sproxy/Server/DB/DataFile.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Sproxy.Server.DB.DataFile (
+ DataFile(..)
+, GroupMember(..)
+, GroupPrivilege(..)
+, PrivilegeRule(..)
+) where
+
+import Control.Applicative (empty)
+import Data.Aeson (FromJSON, parseJSON)
+import Data.Text (Text)
+import Data.Yaml (Value(Object), (.:))
+
+
+data DataFile = DataFile {
+ groupMember :: [GroupMember]
+, groupPrivilege :: [GroupPrivilege]
+, privilegeRule :: [PrivilegeRule]
+} deriving (Show)
+
+instance FromJSON DataFile where
+ parseJSON (Object m) = DataFile <$>
+ m .: "group_member"
+ <*> m .: "group_privilege"
+ <*> m .: "privilege_rule"
+ parseJSON _ = empty
+
+
+data GroupMember = GroupMember {
+ gmGroup :: Text
+, gmEmail :: Text
+} deriving (Show)
+
+instance FromJSON GroupMember where
+ parseJSON (Object m) = GroupMember <$>
+ m .: "group"
+ <*> m .: "email"
+ parseJSON _ = empty
+
+
+data GroupPrivilege = GroupPrivilege {
+ gpGroup :: Text
+, gpDomain :: Text
+, gpPrivilege :: Text
+} deriving (Show)
+
+instance FromJSON GroupPrivilege where
+ parseJSON (Object m) = GroupPrivilege <$>
+ m .: "group"
+ <*> m .: "domain"
+ <*> m .: "privilege"
+ parseJSON _ = empty
+
+
+data PrivilegeRule = PrivilegeRule {
+ prDomain :: Text
+, prPrivilege :: Text
+, prPath :: Text
+, prMethod :: Text
+} deriving (Show)
+
+instance FromJSON PrivilegeRule where
+ parseJSON (Object m) = PrivilegeRule <$>
+ m .: "domain"
+ <*> m .: "privilege"
+ <*> m .: "path"
+ <*> m .: "method"
+ parseJSON _ = empty
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 02:24:23 +0000