aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy/Server/DB.hs
diff options
context:
space:
mode:
authorIgor Pashev <pashev.igor@gmail.com>2017-08-06 19:50:58 +0300
committerIgor Pashev <pashev.igor@gmail.com>2017-08-06 19:50:58 +0300
commitad1134ad752bbcd678cfb5a80217fabe57fdcd35 (patch)
tree62b14e42a0d37b748279d1ff7fabfa75a62da2dc /src/Sproxy/Server/DB.hs
parent7870f9db440cc091a15fa4fae646522cce65fb4b (diff)
downloadsproxy2-ad1134ad752bbcd678cfb5a80217fabe57fdcd35.tar.gz
Format with hindent
Diffstat (limited to 'src/Sproxy/Server/DB.hs')
-rw-r--r--src/Sproxy/Server/DB.hs213
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
-