aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy/Server
diff options
context:
space:
mode:
authorIgor Pashev <pashev.igor@gmail.com>2016-10-27 22:57:34 +0300
committerIgor Pashev <pashev.igor@gmail.com>2016-11-19 23:29:43 +0300
commit4a9f329a6ea9bfa03352ca0d9dd1d556b93bec36 (patch)
treeec49e853364a61eb4c7c64b5f13b0153d21a4cc1 /src/Sproxy/Server
downloadsproxy2-4a9f329a6ea9bfa03352ca0d9dd1d556b93bec36.tar.gz
Initial release (1.90.0)1.90.0
Diffstat (limited to 'src/Sproxy/Server')
-rw-r--r--src/Sproxy/Server/DB.hs189
1 files changed, 189 insertions, 0 deletions
diff --git a/src/Sproxy/Server/DB.hs b/src/Sproxy/Server/DB.hs
new file mode 100644
index 0000000..b760afc
--- /dev/null
+++ b/src/Sproxy/Server/DB.hs
@@ -0,0 +1,189 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Sproxy.Server.DB (
+ Database
+, DataSource(..)
+, userExists
+, userGroups
+, start
+) where
+
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Exception (SomeException, bracket, catch, finally)
+import Control.Monad (forever, void)
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 (pack)
+import Data.Pool (Pool, createPool, withResource)
+import Data.Text (Text, toLower, unpack)
+import Data.Text.Encoding (encodeUtf8)
+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 qualified Sproxy.Logging as Log
+
+
+type Database = Pool SQLite.Connection
+
+data DataSource = PostgreSQL String -- | File FilePath
+
+{- TODO:
+ - Hash remote tables and update the local only when the remote change
+ - Switch to REGEX
+ - Generalize sync procedures for different tables
+ -}
+
+start :: FilePath -> Maybe DataSource -> IO Database
+start home ds = do
+ Log.info $ "home directory: " ++ show home
+ db <- createPool
+ (do c <- SQLite.open $ home ++ "/sproxy.sqlite3"
+ lvl <- Log.level
+ SQLite.setTrace c (if lvl == Log.Debug then Just $ Log.debug . unpack else Nothing)
+ return c)
+ SQLite.close
+ 1 -- stripes
+ 3600 -- keep alive (seconds). FIXME: no much sense as it's a local file
+ 128 -- max connections. FIXME: make configurable?
+
+ withResource db $ \c -> SQLite.execute_ c "PRAGMA journal_mode=WAL"
+ populate db ds
+ return db
+
+
+userExists :: Database -> String -> IO Bool
+userExists db email = do
+ r <- withResource db $ \c -> fmap SQLite.fromOnly <$> SQLite.queryNamed c
+ "SELECT EXISTS (SELECT 1 FROM group_member WHERE :email LIKE email LIMIT 1)"
+ [ ":email" := email ]
+ return $ head r
+
+
+userGroups :: Database -> String -> Text -> Text -> Text -> IO [ByteString]
+userGroups db email domain path method =
+ withResource db $ \c -> fmap (encodeUtf8 . 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 :domain LIKE gp.domain
+ AND gp.privilege IN (
+ SELECT privilege FROM privilege_rule
+ WHERE :domain LIKE 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
+ , ":method" := method -- XXX case-sensitive by RFC2616
+ ]
+
+
+populate :: Database -> Maybe DataSource -> IO ()
+
+populate db Nothing = do
+ Log.warn "db: no data source defined"
+ withResource db $ \c -> SQLite.withTransaction c $ do
+ createGroupMember c
+ createGroupPrivilege c
+ createPrivilegeRule c
+
+-- 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.
+populate db (Just (PostgreSQL connstr)) =
+ void . forkIO . forever . flip finally (7 `minutes` threadDelay)
+ . logException $ do
+ Log.info $ "db: synchronizing with " ++ show connstr
+ withResource db $ \c -> SQLite.withTransaction c $
+ bracket (PG.connectPostgreSQL $ pack connstr) PG.close $
+ \pg -> PG.withTransaction pg $ do
+
+ Log.info "db: syncing group_member"
+ dropGroupMember c
+ createGroupMember c
+ PG.forEach_ pg
+ [q|SELECT "group", lower(email) FROM group_member|] $ \r ->
+ SQLite.execute c
+ [q|INSERT INTO group_member("group", email) VALUES (?, ?)|]
+ (r :: (Text, Text))
+ count c "group_member"
+
+ Log.info "db: syncing group_privilege"
+ dropGroupPrivilege c
+ createGroupPrivilege c
+ PG.forEach_ pg
+ [q|SELECT "group", lower(domain), privilege FROM group_privilege|] $ \r ->
+ SQLite.execute c
+ [q|INSERT INTO group_privilege("group", domain, privilege) VALUES (?, ?, ?)|]
+ (r :: (Text, Text, Text))
+ count c "group_privilege"
+
+ Log.info "db: syncing privilege_rule"
+ dropPrivilegeRule c
+ createPrivilegeRule c
+ PG.forEach_ pg
+ [q|SELECT lower(domain), privilege, path, method FROM privilege_rule|] $ \r ->
+ SQLite.execute c
+ [q|INSERT INTO privilege_rule(domain, privilege, path, method) VALUES (?, ?, ?, ?)|]
+ (r :: (Text, Text, Text, Text))
+ count c "privilege_rule"
+
+
+dropGroupMember :: SQLite.Connection -> IO ()
+dropGroupMember c = SQLite.execute_ c "DROP TABLE IF EXISTS group_member"
+
+createGroupMember :: SQLite.Connection -> IO ()
+createGroupMember c = SQLite.execute_ c [q|
+ CREATE TABLE IF NOT EXISTS group_member (
+ "group" TEXT,
+ email TEXT,
+ PRIMARY KEY ("group", email)
+ )
+|]
+
+
+dropGroupPrivilege :: SQLite.Connection -> IO ()
+dropGroupPrivilege c = SQLite.execute_ c "DROP TABLE IF EXISTS group_privilege"
+
+createGroupPrivilege :: SQLite.Connection -> IO ()
+createGroupPrivilege c = SQLite.execute_ c [q|
+ CREATE TABLE IF NOT EXISTS group_privilege (
+ "group" TEXT,
+ domain TEXT,
+ privilege TEXT,
+ PRIMARY KEY ("group", domain, privilege)
+ )
+|]
+
+
+dropPrivilegeRule :: SQLite.Connection -> IO ()
+dropPrivilegeRule c = SQLite.execute_ c "DROP TABLE IF EXISTS privilege_rule"
+
+createPrivilegeRule :: SQLite.Connection -> IO ()
+createPrivilegeRule c = SQLite.execute_ c [q|
+ CREATE TABLE IF NOT EXISTS privilege_rule (
+ domain TEXT,
+ privilege TEXT,
+ path TEXT,
+ method TEXT,
+ PRIMARY KEY (domain, path, method)
+ )
+|]
+
+
+count :: SQLite.Connection -> String -> IO ()
+count c table = do
+ r <- fmap SQLite.fromOnly <$> SQLite.query_ c [qc|SELECT COUNT(*) FROM {table}|]
+ Log.info $ "db: " ++ table ++ " rows: " ++ show (head r :: Integer)
+
+
+logException :: IO () -> IO ()
+logException a = catch a $ \e ->
+ Log.error $ "db: " ++ show (e :: SomeException)
+
+
+minutes :: Int -> (Int -> IO ()) -> IO ()
+minutes us f = f $ us * 60 * 1000000
+