module Hails.Database ( mkPolicy, withDB ) where
import Data.Typeable
import LIO.MonadCatch
import LIO.DCLabel
import LIO.TCB
import DCLabel.Core
import Data.String.Utils
import Hails.Database.MongoDB.TCB.Types
import Hails.Database.MongoDB.TCB.DCAccess
import qualified Data.UString as U
import System.Environment
import qualified Data.ByteString.Char8 as C
loadDatabase :: DatabasePolicy dbp
=> Principal
-> DatabaseName
-> (DC dbp)
loadDatabase dbPrincipal dbName = do
let policyPriv = createPrivTCB $ newPriv dbPrincipal
let dbConf = DBConf dbName policyPriv
clr <- getClearance
lowerClrTCB $ newDC dbPrincipal (<>)
res <- createDatabasePolicy dbConf policyPriv
lowerClrTCB clr
return res
mkPolicy :: forall dbp. (DatabasePolicy dbp, Typeable dbp) => DC dbp
mkPolicy = do
let tp = typeRepTyCon $ typeOf $ (undefined :: dbp)
let typeName = tyConPackage tp ++ ":" ++ tyConModule tp ++
"." ++ tyConName tp
dbs <- ioTCB $ databases
maybe (err typeName) doit $ lookup typeName dbs
where doit (dbName, dbPrincipal) = loadDatabase dbPrincipal dbName
err tn = throwIO . userError $ "mkPolicy: could not find policy for "
++ tn
confLineToConfPair :: String
-> (String, (DatabaseName, Principal))
confLineToConfPair line = do
case split "," line of
(typeName:dbPrincipal:dbName:[]) -> (typeName, (dbN, dbP))
where dbP = principal . C.pack $ dbPrincipal
dbN = U.pack dbName
_ -> ("",(undefined, undefined))
databases :: IO [(String, (DatabaseName, Principal))]
databases = do
env <- getEnvironment
let configFile = maybe "/etc/share/hails/conf/databases.conf" id
(lookup "DATABASE_CONFIG_FILE" env)
confLines <- fmap lines $ readFile configFile
return $ map confLineToConfPair $ filter (not.null) confLines
withDB :: DatabasePolicy dbp
=> dbp
-> DCAction a
-> DC (Either Failure a)
withDB dbp act = do
let db = policyDB dbp
dcAccess db act