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
+