----------------------------------------------------------- -- | -- Module : Database.HaskellDB.FlatDB -- Copyright : Bjorn Bringert 2006 -- License : BSD-style -- -- Maintainer : haskelldb-users@lists.sourceforge.net -- Stability : experimental -- Portability : non-portable -- -- This is a very experimental HaskellDB back-end which is written in pure Haskell -- and doesn't use SQL. It stores the database in a file. Using this with -- concurrent writes leads to data loss. This back-end does not support transactions. ----------------------------------------------------------- module Database.HaskellDB.FlatDB (DriverInterface(..), driver, withFlatDB, newDB) where import Database.HaskellDB.Database import Database.HaskellDB.HDBRec import Database.HaskellDB.FieldType import Database.HaskellDB.PrimQuery import Database.HaskellDB.Query hiding (isNull, union, intersect) import Database.HaskellDB.DriverAPI import Control.Monad import Control.Monad.Trans import Data.Bits import Data.IORef import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid (mconcat) import Data.List import Data.Maybe import Prelude hiding (toInteger) import System.Time import System.Directory import System.IO import Debug.Trace type FlatDB = Map TableName FlatTable type RelSchema = [(Attribute,FieldDesc)] type FlatTable = FlatRel data FlatRel = FlatRel { relSchema :: RelSchema, relRows :: [FlatRow] } deriving (Show,Read) type FlatRow = [(String,Value)] data Value = VString String | VInteger Integer | VDouble Double | VBool Bool | VDate CalendarTime | VNull deriving (Show,Read,Eq,Ord) -- FIXME: ord and eq are too liberal here? -- | This driver requires the following options: -- "filepath" driver :: DriverInterface driver = defaultdriver {connect = flatDBConnectOpts} flatDBConnectOpts :: MonadIO m => [(String,String)] -> (Database -> m a) -> m a flatDBConnectOpts opts f = do [a] <- getOptions ["filepath"] opts withFlatDB a f withFlatDB :: MonadIO m => FilePath -> (Database -> m a) -> m a withFlatDB f m = do e <- liftIO $ doesFileExist f when (not e) $ liftIO $ newDB f db <- liftIO $ readDB f dbr <- liftIO $ newIORef db x <- m (flatDatabase dbr) db' <- liftIO $ readIORef dbr (tmpFile,tmpH) <- liftIO $ openTempFile "." (f++".tmp") liftIO $ hWriteDB tmpH db' liftIO $ hClose tmpH liftIO $ renameFile tmpFile f return x emptyDB :: FlatDB emptyDB = Map.empty modifyDB :: IORef FlatDB -> (FlatDB -> FlatDB) -> IO () modifyDB db f = modifyIORef db f queryDB :: IORef FlatDB -> (FlatDB -> a) -> IO a queryDB db f = liftM f $ readIORef db flatDatabase :: IORef FlatDB -> Database flatDatabase db = Database { dbQuery = \x y -> readIORef db >>= \d -> flatQueryHDB x y d, dbInsert = \x y -> modifyDB db $ flatInsert x y, dbInsertQuery = \x y -> modifyDB db $ flatInsertQuery x y, dbDelete = \x y -> modifyDB db $ flatDelete x y, dbUpdate = \x y z -> modifyDB db $ flatUpdate x y z, dbTables = queryDB db $ flatTables, dbDescribe = \x -> queryDB db $ flatDescribe x, dbTransaction = notImplemented "dbTransaction", dbCreateDB = \x -> return (), dbCreateTable = \x y -> modifyDB db $ flatCreateTable x y, dbDropDB = notImplemented "dbDropDB", dbDropTable = \x -> modifyDB db $ flatDropTable x } readDB :: FilePath -> IO FlatDB readDB f = do c <- readFile f case reads c of [] -> err $ "parse error" [(x,[])] -> return x [(_,_)] -> err $ "junk at end" _ -> fail $ "ambiguous parse" where err e = fail $ "FlatDB error when reading " ++ show f ++ ": " ++ e writeDB :: FilePath -> FlatDB -> IO () writeDB f db = do h <- openFile f WriteMode hWriteDB h db hClose h hWriteDB :: Handle -> FlatDB -> IO () hWriteDB h db = hPutStr h $ show db newDB :: FilePath -> IO () newDB f = writeDB f emptyDB -- Relations -- FIXME: make distinct relInsert :: FlatRow -> FlatRel -> FlatRel relInsert r t = t { relRows = r : relRows t } -- FIXME: make distinct -- FIXME: assert relSchema t1 == relSchema t2 relUnion :: FlatRel -> FlatRel -> FlatRel relUnion t1 t2 = t1 { relRows = relRows t1 `union` relRows t2 } relFilter :: (FlatRow -> Bool) -> FlatRel -> FlatRel relFilter p t = t { relRows = filter p (relRows t) } -- FIXME: make distinct relMap :: (FlatRow -> FlatRow) -> FlatRel -> FlatRel relMap f t = t { relRows = map f (relRows t) } modifyTable :: TableName -> (FlatRel -> FlatRel) -> FlatDB -> FlatDB modifyTable n f = Map.adjust f n -- FIXME: does nothing if the table doesn't exist flatTrace :: String -> a -> a --flatTrace = trace -- ENABLE FOR TRACING flatTrace _ x = x flatQueryHDB :: GetRec er vr => PrimQuery -> Rel er -> FlatDB -> IO [Record vr] flatQueryHDB q rel db = flatTrace (show q) $ mapM (getRec flatGetInstances rel scheme) rs where scheme = attributes q rs = relRows $ flatQuery q db flatGetInstances :: GetInstances FlatRow flatGetInstances = GetInstances { getString = flatGetFieldM toString , getInt = flatGetFieldM toInt , getInteger = flatGetFieldM toInteger , getDouble = flatGetFieldM toDouble , getBool = flatGetFieldM toBool , getCalendarTime = flatGetFieldM toDate } where flatGetFieldM f r l = return $ flatGetField f r l flatQuery :: PrimQuery -> FlatDB -> FlatRel flatQuery pq db = e pq where e q = case q of BaseTable n _ -> case Map.lookup n db of Just t -> t Nothing -> error $ "Table not found: " ++ n Project bs x -> FlatRel { relSchema = [(n, inferType s e) | (n,e) <- (gbs++abs)], -- FIXME: what about nullability? relRows = rps3 } where FlatRel { relSchema = s, relRows = rs } = e x (abs,gbs) = partition (isAggregate . snd) bs rps1 = map (\r -> (evalBinds r gbs, r)) rs rps2 = groupBy (\ (x1,_) (x2,_) -> x1 == x2) rps1 -- FIXME: BUG: what if groups are not contiguous? rps3 | null gbs && null rs = [[(n,evalAggr [] e) | (n,e) <- abs]] -- return one result if there are no non-aggregates and the relation is empty | otherwise = map (\g -> fst (head g) ++ [(n,evalAggr (map snd g) e) | (n,e) <- abs]) rps2 Restrict p x -> relFilter (\r -> toBool (evalExpr r p)) t where t = e x Binary op x1 x2 -> case op of Times -> FlatRel { relSchema = s1 ++ s2, -- FIXME: assert s1, s2 disjoint relRows = [r1 ++ r2 | r1 <- rs1, r2 <- rs2] } Union -> FlatRel { relSchema = s1, -- FIXME: assert t1 == t2 relRows = rs1 `union` rs2 } Intersect -> FlatRel { relSchema = s1, -- FIXME: assert t1 == t2 relRows = rs1 `intersect` rs2 } Divide -> notImplemented $ show op -- FIXME: hairy, do it later Difference -> FlatRel { relSchema = s1, -- FIXME: assert t1 == t2 relRows = rs1 \\ rs2 } where FlatRel { relSchema = s1, relRows = rs1 } = e x1 FlatRel { relSchema = s2, relRows = rs2 } = e x2 Special op q -> case op of Order os -> t { relRows = sortBy sortExprs (relRows t) } where sortExprs r1 r2 = mconcat [cmpExpr o e r1 r2 | OrderExpr o e <- os] cmpExpr OpAsc e r1 r2 = evalExpr r1 e `compare` evalExpr r2 e cmpExpr OpDesc e r1 r2 = evalExpr r2 e `compare` evalExpr r1 e Top n -> t { relRows = take n (relRows t) } where t = e q Empty -> FlatRel { relSchema = [], relRows = [] } flatInsert :: TableName -> Assoc -> FlatDB -> FlatDB flatInsert n xs = flatTrace ("Insert: " ++ show xs) $ modifyTable n (relInsert r) where r = evalBinds [] xs flatInsertQuery :: TableName -> PrimQuery -> FlatDB -> FlatDB flatInsertQuery n q db = modifyTable n (relUnion rs) db where rs = flatQuery q db flatDelete :: TableName -> [PrimExpr] -> FlatDB -> FlatDB flatDelete n cs = flatTrace ("Delete: " ++ n ++ ", " ++ show cs) $ modifyTable n (relFilter (not . p)) where p r = all (\c -> toBool (evalExpr r c)) cs flatUpdate :: TableName -> [PrimExpr] -> Assoc -> FlatDB -> FlatDB flatUpdate n cs u = flatTrace ("Update: " ++ n ++ ", " ++ show cs ++ ", " ++ show u) $ modifyTable n (relMap f) where p r = all (\c -> toBool (evalExpr r c)) cs f r | p r = [maybe e ((,) n . evalExpr r) $ lookup n u | e@(n,_) <- r] | otherwise = r flatTables :: FlatDB -> [TableName] flatTables = Map.keys flatDescribe :: TableName -> FlatDB -> [(Attribute,FieldDesc)] flatDescribe n = relSchema . fromJust . Map.lookup n flatCreateTable :: TableName -> [(Attribute,FieldDesc)] -> FlatDB -> FlatDB flatCreateTable n s = Map.insert n t -- FIXME: overwrites existing table where t = FlatRel { relSchema = s, relRows = [] } flatDropTable :: TableName -> FlatDB -> FlatDB flatDropTable n = Map.delete n evalBinds :: FlatRow -> [(Attribute,PrimExpr)] -> FlatRow evalBinds env bs = [(n,evalExpr env e) | (n,e) <- bs] evalExpr :: FlatRow -> PrimExpr -> Value evalExpr env (AttrExpr a) = fromJust $ lookup a env evalExpr env (BinExpr op x1 x2) = case op of OpEq -> VBool (v1 == v2) OpLt -> VBool (v1 < v2) OpLtEq -> VBool (v1 <= v2) OpGt -> VBool (v1 > v2) OpGtEq -> VBool (v1 >= v2) OpNotEq -> VBool (v1 /= v2) OpAnd -> VBool (toBool v1 && toBool v2) OpOr -> VBool (toBool v1 || toBool v2) OpLike -> VBool (toString v1 `matches` toString v2) OpIn -> let v2s = case x2 of ListExpr x2s -> map (evalExpr env) x2s in VBool (v1 `elem` v2s) OpOther o -> notImplemented $ show op OpCat -> VString (toString v1 ++ toString v2) OpPlus -> numOp (+) v1 v2 OpMinus -> numOp (-) v1 v2 OpMul -> numOp (*) v1 v2 OpDiv -> case (v1,v2) of (VInteger i1, VInteger i2) -> VInteger (i1 `div` i2) (VDouble d1, VDouble d2) -> VDouble (d1 / d2) OpMod -> numOp (mod) v1 v2 OpBitNot -> notImplemented $ show op -- FIXME: shouldn't this be an UnOp? OpBitAnd -> bitOp (.&.) v1 v2 OpBitOr -> bitOp (.|.) v1 v2 OpBitXor -> bitOp (xor) v1 v2 OpAsg -> notImplemented $ show op -- FIXME: wtf is this? where v1 = evalExpr env x1 v2 = evalExpr env x2 numOp o (VInteger i1) (VInteger i2) = VInteger (o i1 i2) numOp _ _ _ = error "numOp" bitOp o (VInteger i1) (VInteger i2) = VInteger (o i1 i2) bitOp _ _ _ = error "bitOp" matches = notImplemented "matches" evalExpr env (UnExpr op x) = case op of OpNot -> VBool (not (toBool v)) OpIsNull -> VBool (isNull v) OpIsNotNull -> VBool (not (isNull v)) OpLength -> VInteger (genericLength (toString v)) UnOpOther o -> notImplemented $ show op where v = evalExpr env x evalExpr env (AggrExpr op x) = undefined -- this need something different, -- it affects the result set evalExpr env (ConstExpr c) = case c of NullLit -> VNull DefaultLit -> notImplemented $ show c -- FIXME: need to know default for column BoolLit b -> VBool b StringLit s -> VString s IntegerLit i -> VInteger i DoubleLit d -> VDouble d DateLit d -> VDate d OtherLit l -> notImplemented $ show c evalExpr env (CaseExpr cs el) = case [x | (c,x) <- cs, toBool (evalExpr env c)] of x:_ -> evalExpr env x _ -> evalExpr env el evalAggr :: [FlatRow] -> PrimExpr -> Value evalAggr rs (AggrExpr op e) = case op of AggrCount -> VInteger (genericLength vs) -- FIXME: should this count unique values? AggrSum -> numAggr sum sum AggrAvg -> dblAggr average AggrMin -> numAggr minimum minimum AggrMax -> numAggr maximum minimum AggrStdDev -> dblAggr stddev AggrStdDevP -> dblAggr stddevp AggrVar -> dblAggr variance AggrVarP -> dblAggr variancep AggrOther o -> notImplemented $ show op where vs = map (\r -> evalExpr r e) rs numAggr :: ([Integer] -> Integer) -> ([Double] -> Double) -> Value numAggr f g | null vs || isInteger (head vs) = VInteger $ f $ map toInteger vs | otherwise = VDouble $ g $ map toDouble vs dblAggr :: ([Double] -> Double) -> Value dblAggr f = numAggr (round . f . map fromIntegral) f average xs = sum xs / len xs stddev = sqrt . variance stddevp = sqrt . variancep variance xs = sum [(x - average xs) ^ 2 | x <- xs] / (len xs - 1) variancep xs = sum [(x - average xs) ^ 2 | x <- xs] / len xs len = fromIntegral . length -- Type checking inferType :: [(Attribute,FieldDesc)] -> PrimExpr -> FieldDesc inferType env e = undefined -- Getting values from results flatGetField :: (Value -> a) -> FlatRow -> String -> Maybe a flatGetField f r n = case lookup n r of Nothing -> error $ "No field " ++ n ++ " in " ++ show r Just VNull -> Nothing Just v -> Just $ f v isNull :: Value -> Bool isNull VNull = True isNull _ = False isInteger :: Value -> Bool isInteger (VInteger _) = True isInteger _ = False toString :: Value -> String toString (VString s) = s toString v = error $ show v ++ " is not a string" toInt :: Value -> Int toInt (VInteger i) = fromIntegral i toInt v = error $ show v ++ " is not an integer" toInteger :: Value -> Integer toInteger (VInteger i) = i toInteger v = error $ show v ++ " is not an integer" toDouble :: Value -> Double toDouble (VDouble d) = d toDouble v = error $ show v ++ " is not a double" toBool :: Value -> Bool toBool (VBool b) = b toBool v = error $ show v ++ " is not a boolean" toDate :: Value -> CalendarTime toDate (VDate d) = d toDate v = error $ show v ++ " is not a date" notImplemented s = error $ "NOT IMPLEMENTED: " ++ s