path: root/src/Sproxy/Server/DB.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
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 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 qualified Database.SQLite.Simple as SQLite

import Sproxy.Server.DB.DataFile ( DataFile(..), GroupMember(..),
  GroupPrivilege(..), PrivilegeRule(..) )
import qualified Sproxy.Application.Access as A
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 -> 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 ]
  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|
    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
    AND gp.privilege IN (
      SELECT privilege FROM privilege_rule
      WHERE domain = :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
     ]


userAccess :: Database -> Text -> Text -> A.Inquiry -> IO [Text]
userAccess db email domain inq = do
  let permitted c (_, qn) =
        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

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
        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
    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"
          refreshGroupMembers c $ \st ->
            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
              [q|SELECT "group", lower(domain), privilege FROM group_privilege|] $ \r ->
                submit st (r :: (Text, Text, Text))
          count c "group_privilege"

          Log.info "db: syncing privilege_rule"
          refreshPrivilegeRule c $ \st ->
            PG.forEach_ pg
              [q|SELECT lower(domain), privilege, path, method FROM privilege_rule|] $ \r ->
                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]))


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)
  )
|]

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
    [q|INSERT INTO group_member("group", email) VALUES (?, ?)|]
    a


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)
  )
|]

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
    [q|INSERT INTO group_privilege("group", domain, privilege) VALUES (?, ?, ?)|]
    a


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)
  )
|]

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
    [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}|]
  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