diff options
Diffstat (limited to 'src/Sproxy/Server/DB.hs')
| -rw-r--r-- | src/Sproxy/Server/DB.hs | 213 |
1 files changed, 117 insertions, 96 deletions
diff --git a/src/Sproxy/Server/DB.hs b/src/Sproxy/Server/DB.hs index 662a9c7..be44f69 100644 --- a/src/Sproxy/Server/DB.hs +++ b/src/Sproxy/Server/DB.hs @@ -1,72 +1,83 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module Sproxy.Server.DB ( - Database -, DataSource(..) -, userAccess -, userExists -, userGroups -, start -) where + +module Sproxy.Server.DB + ( Database + , DataSource(..) + , userAccess + , userExists + , userGroups + , start + ) where import Control.Concurrent (forkIO, threadDelay) import Control.Exception (SomeException, bracket, catch, finally) import Control.Monad (filterM, forever, void) import Data.ByteString.Char8 (pack) +import qualified Data.HashMap.Strict as HM 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 Database.SQLite.Simple (NamedParam((:=))) import qualified Database.SQLite.Simple as SQLite +import Text.InterpolatedString.Perl6 (q, qc) -import Sproxy.Server.DB.DataFile ( DataFile(..), GroupMember(..), - GroupPrivilege(..), PrivilegeRule(..) ) import qualified Sproxy.Application.Access as A import qualified Sproxy.Logging as Log - +import Sproxy.Server.DB.DataFile + (DataFile(..), GroupMember(..), GroupPrivilege(..), + PrivilegeRule(..)) 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 - 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? - + 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 -> Text -> 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 ] + 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_ :: SQLite.Connection -> Text -> Text -> Text -> Text -> IO [Text] userGroups_ c email domain path method = - fmap SQLite.fromOnly <$> SQLite.queryNamed c [q| + 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 @@ -77,12 +88,12 @@ userGroups_ c email domain path method = 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 - ] - + |] + [ ":email" := email -- XXX always in lower case + , ":domain" := toLower domain + , ":path" := path + , ":method" := method -- XXX case-sensitive by RFC2616 + ] userAccess :: Database -> Text -> Text -> A.Inquiry -> IO [Text] userAccess db email domain inq = do @@ -90,80 +101,85 @@ userAccess db email domain inq = do 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 Log.warn "db: no data source defined" - withResource db $ \c -> SQLite.withTransaction c $ do - createGroupMember c - createGroupPrivilege c - createPrivilegeRule c - + withResource db $ \c -> + SQLite.withTransaction c $ do + createGroupMember c + 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 + Left e -> Log.error $ f ++ ": " ++ show e Right df -> - withResource db $ \c -> SQLite.withTransaction c $ do - refreshGroupMembers c $ \st -> - mapM_ (\gm -> submit st (gmGroup gm, toLower $ gmEmail gm) - ) (groupMember df) - - refreshGroupPrivileges c $ \st -> - mapM_ (\gp -> submit st (gpGroup gp, toLower $ gpDomain gp, gpPrivilege gp) - ) (groupPrivilege df) - - refreshPrivilegeRule c $ \st -> - mapM_ (\pr -> submit st (toLower $ prDomain pr, prPrivilege pr, prPath pr, prMethod pr) - ) (privilegeRule df) - - + withResource db $ \c -> + SQLite.withTransaction c $ do + refreshGroupMembers c $ \st -> + mapM_ + (\gm -> submit st (gmGroup gm, toLower $ gmEmail gm)) + (groupMember df) + refreshGroupPrivileges c $ \st -> + mapM_ + (\gp -> + submit st (gpGroup gp, toLower $ gpDomain gp, gpPrivilege gp)) + (groupPrivilege df) + refreshPrivilegeRule c $ \st -> + mapM_ + (\pr -> + submit + st + ( toLower $ prDomain pr + , prPrivilege pr + , prPath pr + , prMethod pr)) + (privilegeRule df) populate db (Just (PostgreSQL connstr)) = - void . forkIO . forever . flip finally (7 `minutes` threadDelay) - . logException $ do + 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 - + withResource db $ \c -> + SQLite.withTransaction c $ + bracket (PG.connectPostgreSQL $ pack connstr) PG.close $ \pg -> + PG.withTransaction pg $ do Log.info "db: syncing group_member" refreshGroupMembers c $ \st -> - PG.forEach_ pg - [q|SELECT "group", lower(email) FROM group_member|] $ \r -> - submit st (r :: (Text, Text)) + PG.forEach_ pg [q|SELECT "group", lower(email) FROM group_member|] $ \r -> + submit st (r :: (Text, Text)) count c "group_member" - Log.info "db: syncing group_privilege" refreshGroupPrivileges c $ \st -> - PG.forEach_ pg + PG.forEach_ + pg [q|SELECT "group", lower(domain), privilege FROM group_privilege|] $ \r -> - submit st (r :: (Text, Text, Text)) + submit st (r :: (Text, Text, Text)) count c "group_privilege" - Log.info "db: syncing privilege_rule" refreshPrivilegeRule c $ \st -> - PG.forEach_ pg + PG.forEach_ + pg [q|SELECT lower(domain), privilege, path, method FROM privilege_rule|] $ \r -> - submit st (r :: (Text, Text, Text, Text)) + submit st (r :: (Text, Text, Text, Text)) count c "privilege_rule" - -- 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.ToRow values => SQLite.Statement -> values -> IO () -submit st v = SQLite.withBind st v $ void (SQLite.nextRow st :: IO (Maybe [Int])) - +submit st v = + SQLite.withBind st v $ void (SQLite.nextRow st :: IO (Maybe [Int])) createGroupMember :: SQLite.Connection -> IO () -createGroupMember c = SQLite.execute_ c [q| +createGroupMember c = + SQLite.execute_ + c + [q| CREATE TABLE IF NOT EXISTS group_member ( "group" TEXT, email TEXT, @@ -175,13 +191,16 @@ refreshGroupMembers :: SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO () refreshGroupMembers c a = do SQLite.execute_ c "DROP TABLE IF EXISTS group_member" createGroupMember c - SQLite.withStatement c + SQLite.withStatement + c [q|INSERT INTO group_member("group", email) VALUES (?, ?)|] a - createGroupPrivilege :: SQLite.Connection -> IO () -createGroupPrivilege c = SQLite.execute_ c [q| +createGroupPrivilege c = + SQLite.execute_ + c + [q| CREATE TABLE IF NOT EXISTS group_privilege ( "group" TEXT, domain TEXT, @@ -190,17 +209,21 @@ createGroupPrivilege c = SQLite.execute_ c [q| ) |] -refreshGroupPrivileges :: SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO () +refreshGroupPrivileges :: + SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO () refreshGroupPrivileges c a = do SQLite.execute_ c "DROP TABLE IF EXISTS group_privilege" createGroupPrivilege c - SQLite.withStatement c + SQLite.withStatement + c [q|INSERT INTO group_privilege("group", domain, privilege) VALUES (?, ?, ?)|] a - createPrivilegeRule :: SQLite.Connection -> IO () -createPrivilegeRule c = SQLite.execute_ c [q| +createPrivilegeRule c = + SQLite.execute_ + c + [q| CREATE TABLE IF NOT EXISTS privilege_rule ( domain TEXT, privilege TEXT, @@ -210,26 +233,24 @@ createPrivilegeRule c = SQLite.execute_ c [q| ) |] -refreshPrivilegeRule :: SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO () +refreshPrivilegeRule :: + SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO () refreshPrivilegeRule c a = do SQLite.execute_ c "DROP TABLE IF EXISTS privilege_rule" createPrivilegeRule c - SQLite.withStatement c + SQLite.withStatement + c [q|INSERT INTO privilege_rule(domain, privilege, path, method) VALUES (?, ?, ?, ?)|] a - count :: SQLite.Connection -> String -> IO () count c table = do - r <- fmap SQLite.fromOnly <$> SQLite.query_ c [qc|SELECT COUNT(*) FROM {table}|] + 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) - +logException a = catch a $ \e -> Log.error $ "db: " ++ show (e :: SomeException) minutes :: Int -> (Int -> IO ()) -> IO () minutes us f = f $ us * 60 * 1000000 - |