module Database.Graph.HGraphStorage.FileOps where
import Control.Applicative
import Control.Exception.Base (Exception)
import Data.Binary
import Data.Default
import Data.Traversable
import System.FilePath
import qualified Data.Map as DM
import System.IO
import System.Directory
import Database.Graph.HGraphStorage.Constants
import Database.Graph.HGraphStorage.Types
import qualified Data.ByteString.Lazy as BS
import Data.Int
import Data.ByteString.Lazy (toStrict, fromStrict)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Control.Monad (foldM, when, join)
import Control.Monad.Base (MonadBase)
import Control.Exception.Lifted (throwIO)
import Control.Monad.IO.Class (liftIO)
import Database.Graph.HGraphStorage.FreeList
open :: FilePath -> GraphSettings -> IO Handles
open dir gs = do
createDirectoryIfMissing True dir
Handles
<$> getHandle objectFile
<*> getFreeList objectFile (def::ObjectID)
<*> getHandle objectTypeFile
<*> getHandle relationFile
<*> getFreeList relationFile (def::RelationID)
<*> getHandle relationTypeFile
<*> getHandle propertyFile
<*> getFreeList propertyFile (def::PropertyID)
<*> getHandle propertyTypeFile
<*> getHandle propertyValuesFile
where
getHandle :: FilePath -> IO Handle
getHandle name = do
let f = dir </> name
h <- openBinaryFile f ReadWriteMode
setBufferMode h $ gsMainBuffering gs
return h
getFreeList :: (Binary a) => FilePath -> a -> IO (FreeList a)
getFreeList name d = do
let f = dir </> freePrefix ++ name
h<- openBinaryFile f ReadWriteMode
setBufferMode h $ gsFreeBuffering gs
initFreeList (fromIntegral $ binLength d) h (do
ex <- doesFileExist f
when ex $ removeFile f)
setBufferMode :: Handle -> Maybe BufferMode -> IO()
setBufferMode _ Nothing = return ()
setBufferMode h (Just bm) = hSetBuffering h bm
close :: Handles -> IO ()
close Handles{..} = do
hClose hObjects
_ <- closeFreeList hObjectFree
hClose hObjectTypes
hClose hRelations
_ <- closeFreeList hRelationFree
hClose hRelationTypes
hClose hProperties
_ <- closeFreeList hPropertyFree
hClose hPropertyTypes
hClose hPropertyValues
readModel :: (GraphUsableMonad m)
=> Handles -> m Model
readModel hs = do
let defMdl = def
pts <- readAll hs
when (null pts) $ do
let t = "name"
a <- write hs Nothing (Property namePropertyID 0 0 (BS.length t))
b <- write hs Nothing (PropertyType (dataTypeID DTText) a)
when (b /= namePropertyID) $ throwIO $ IncoherentNamePropertyTypeID namePropertyID b
liftIO $ do
hSeek (hPropertyValues hs) AbsoluteSeek 0
BS.hPut (hPropertyValues hs) t
return ()
ots <- readAll hs
rts <- readAll hs
mdlWithProps <- foldM addProp defMdl pts
mdlWithObjs <- foldM addOType mdlWithProps ots
foldM addRType mdlWithObjs rts
where
addProp mdl (ptId,pt) = addN mdl (ptFirstProperty pt) ptId $ \name ->
return mdl{mPropertyTypes = addToLookup ptId (name,dataType $ ptDataType pt) $ mPropertyTypes mdl}
addOType mdl (otId,ot) = addN mdl (otFirstProperty ot) otId $ \name ->
return mdl {mObjectTypes = addToLookup otId name $ mObjectTypes mdl}
addRType mdl (rtId,rt) = addN mdl (rtFirstProperty rt) rtId $ \name ->
return mdl {mRelationTypes = addToLookup rtId name $ mRelationTypes mdl}
addN mdl pId tId f = do
pvs <- readProperties hs mdl namePropertyID pId
case pvs of
[(_,PVText name)] -> f name
[] -> throwIO $ NoNameProperty tId
_ -> throwIO $ MultipleNameProperty tId
writeGeneric :: (GraphUsableMonad m)
=> (Integral a,Binary a,Default a, Binary b) => Handle -> Maybe (FreeList a) -> Int64 -> Maybe a -> b -> m a
writeGeneric h _ sz (Just a) b =
liftIO $ do
hSeek h AbsoluteSeek (toInteger (a 1) * toInteger sz)
BS.hPut h $ encode b
return a
writeGeneric h mf sz Nothing b = do
mid <- liftIO $ join <$> for mf getFromFreeList
case mid of
Just i -> writeGeneric h mf sz (Just i) b
Nothing -> liftIO $ do
hSeek h SeekFromEnd 0
allsz <- hTell h
let a=div allsz $ toInteger sz
BS.hPut h $ encode b
return $ fromInteger a + 1
readGeneric :: (GraphUsableMonad m)
=> (Integral a, Binary b) => Handle -> Int64 -> a -> m b
readGeneric h sz a =
liftIO $ do
hSeek h AbsoluteSeek (toInteger (a 1) * toInteger sz)
decode <$> BS.hGet h (fromIntegral sz)
readAll :: (GraphUsableMonad m,GraphIdSerializable a b) => Handles -> m [(a,b)]
readAll hs = foldAll hs (\a b->return $ b:a) []
foldAllGeneric :: (GraphUsableMonad m)
=> (Integral a, Eq b, Binary b, Default b) => Handle -> Int64
-> (c -> (a,b) -> m c) -> c -> m c
foldAllGeneric h sz f st = do
liftIO $ hSeek h AbsoluteSeek 0
go (fromIntegral sz) 0 st
where go isz a st2 = do
bs <- liftIO $ BS.hGet h isz
if BS.null bs
then return st2
else do
let b = decode bs
i = a + 1
l2 <- if b == def
then return st2
else f st2 (i,b)
go isz i l2
readProperties :: (GraphUsableMonad m)
=> Handles -> Model -> PropertyTypeID -> PropertyID -> m [(Property,PropertyValue)]
readProperties _ _ _ pid | pid == def = return []
readProperties hs mdl ptid pid = do
p <- readOne hs pid
vs <- if ptid == def || pType p == ptid
then
do
let m = DM.lookup (pType p) $ toName $ mPropertyTypes mdl
(_, dt) <- throwIfNothing (UnknownPropertyType (pType p)) m
val <- readPropertyValue hs dt (pOffset p) (pLength p)
return [(p,val)]
else return []
let p2 = pNext p
(vs ++) <$> readProperties hs mdl ptid p2
writeProperty :: (GraphUsableMonad m)
=> Handles -> PropertyTypeID -> PropertyID -> PropertyValue -> m PropertyID
writeProperty hs ptid nextid v = do
let h = hPropertyValues hs
liftIO $ hSeek h SeekFromEnd 0
off <- liftIO $ fromIntegral <$> hTell h
let bs = toBin v
liftIO $ BS.hPut h bs
write hs Nothing $ Property ptid nextid off (BS.length bs)
where
toBin (PVBinary bs) = bs
toBin (PVText t) = fromStrict $ encodeUtf8 t
toBin (PVInteger i) = encode i
throwIfNothing :: (MonadBase IO m,
Exception e) =>
e -> Maybe a -> m a
throwIfNothing e Nothing = throwIO e
throwIfNothing _ (Just a) = return a
readPropertyValue :: (GraphUsableMonad m)
=> Handles -> DataType -> PropertyValueOffset -> PropertyValueLength -> m PropertyValue
readPropertyValue hs dt off len = do
let h = hPropertyValues hs
liftIO $ hSeek h AbsoluteSeek (fromIntegral off)
liftIO $ toValue dt <$> BS.hGet h (fromIntegral len)
where
toValue DTBinary = PVBinary
toValue DTText = PVText . decodeUtf8 . toStrict
toValue DTInteger = PVInteger . decode
class (Integral a, Binary b) => GraphIdSerializable a b where
write :: (GraphUsableMonad m) => Handles -> Maybe a -> b -> m a
readOne :: (GraphUsableMonad m) => Handles -> a -> m b
foldAll :: (GraphUsableMonad m) => Handles -> (c -> (a,b) -> m c) -> c -> m c
instance GraphIdSerializable ObjectID Object where
write hs = writeGeneric (hObjects hs) (Just $ hObjectFree hs) objectSize
readOne hs = readGeneric (hObjects hs) objectSize
foldAll hs = foldAllGeneric(hObjects hs) objectSize
instance GraphIdSerializable RelationID Relation where
write hs = writeGeneric (hRelations hs) (Just $ hRelationFree hs) relationSize
readOne hs = readGeneric (hRelations hs) relationSize
foldAll hs = foldAllGeneric(hRelations hs) relationSize
instance GraphIdSerializable PropertyID Property where
write hs = writeGeneric (hProperties hs) (Just $ hPropertyFree hs) propertySize
readOne hs = readGeneric (hProperties hs) propertySize
foldAll hs = foldAllGeneric(hProperties hs) propertySize
instance GraphIdSerializable PropertyTypeID PropertyType where
write hs = writeGeneric (hPropertyTypes hs) Nothing propertyTypeSize
readOne hs = readGeneric (hPropertyTypes hs) propertyTypeSize
foldAll hs = foldAllGeneric(hPropertyTypes hs) propertyTypeSize
instance GraphIdSerializable ObjectTypeID ObjectType where
write hs = writeGeneric (hObjectTypes hs) Nothing objectTypeSize
readOne hs = readGeneric (hObjectTypes hs) objectTypeSize
foldAll hs = foldAllGeneric(hObjectTypes hs) objectTypeSize
instance GraphIdSerializable RelationTypeID RelationType where
write hs = writeGeneric (hRelationTypes hs) Nothing relationTypeSize
readOne hs = readGeneric (hRelationTypes hs) relationTypeSize
foldAll hs = foldAllGeneric(hRelationTypes hs) relationTypeSize