diff options
Diffstat (limited to 'src/Erebos/Object/Internal.hs')
| -rw-r--r-- | src/Erebos/Object/Internal.hs | 207 |
1 files changed, 25 insertions, 182 deletions
diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs index 03ee83c..4bca49c 100644 --- a/src/Erebos/Object/Internal.hs +++ b/src/Erebos/Object/Internal.hs @@ -1,7 +1,5 @@ module Erebos.Object.Internal ( Storage, PartialStorage, StorageCompleteness, - openStorage, memoryStorage, - deriveEphemeralStorage, derivePartialStorage, Ref, PartialRef, RefDigest, refDigest, @@ -45,17 +43,9 @@ module Erebos.Object.Internal ( wrappedStore, wrappedLoad, copyStored, unsafeMapStored, - - StoreInfo(..), makeStoreInfo, - - StoredHistory, - fromHistory, fromHistoryAt, storedFromHistory, storedHistoryList, - beginHistory, modifyHistory, ) where import Control.Applicative -import Control.Concurrent -import Control.Exception import Control.Monad import Control.Monad.Except import Control.Monad.Reader @@ -72,8 +62,6 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC import Data.Char import Data.Function -import qualified Data.HashTable.IO as HT -import qualified Data.Map as M import Data.Maybe import Data.Ratio import Data.Set (Set) @@ -89,92 +77,12 @@ import Data.Time.LocalTime import Data.UUID (UUID) import qualified Data.UUID as U -import System.Directory -import System.FilePath -import System.IO.Error import System.IO.Unsafe +import Erebos.Error import Erebos.Storage.Internal -type Storage = Storage' Complete -type PartialStorage = Storage' Partial - -storageVersion :: String -storageVersion = "0.1" - -openStorage :: FilePath -> IO Storage -openStorage path = modifyIOError annotate $ do - let versionFileName = "erebos-storage" - let versionPath = path </> versionFileName - let writeVersionFile = writeFileOnce versionPath $ BLC.pack $ storageVersion <> "\n" - - maybeVersion <- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ - Just <$> readFile versionPath - version <- case maybeVersion of - Just versionContent -> do - return $ takeWhile (/= '\n') versionContent - - Nothing -> do - files <- handleJust (guard . isDoesNotExistError) (const $ return []) $ - listDirectory path - when (not $ or - [ null files - , versionFileName `elem` files - , (versionFileName ++ ".lock") `elem` files - , "objects" `elem` files && "heads" `elem` files - ]) $ do - fail "directory is neither empty, nor an existing erebos storage" - - createDirectoryIfMissing True $ path - writeVersionFile - takeWhile (/= '\n') <$> readFile versionPath - - when (version /= storageVersion) $ do - fail $ "unsupported storage version " <> version - - createDirectoryIfMissing True $ path </> "objects" - createDirectoryIfMissing True $ path </> "heads" - watchers <- newMVar (Nothing, [], WatchList 1 []) - refgen <- newMVar =<< HT.new - refroots <- newMVar =<< HT.new - return $ Storage - { stBacking = StorageDir path watchers - , stParent = Nothing - , stRefGeneration = refgen - , stRefRoots = refroots - } - where - annotate e = annotateIOError e "failed to open storage" Nothing (Just path) - -memoryStorage' :: IO (Storage' c') -memoryStorage' = do - backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty <*> newMVar (WatchList 1 []) - refgen <- newMVar =<< HT.new - refroots <- newMVar =<< HT.new - return $ Storage - { stBacking = backing - , stParent = Nothing - , stRefGeneration = refgen - , stRefRoots = refroots - } - -memoryStorage :: IO Storage -memoryStorage = memoryStorage' - -deriveEphemeralStorage :: Storage -> IO Storage -deriveEphemeralStorage parent = do - st <- memoryStorage - return $ st { stParent = Just parent } - -derivePartialStorage :: Storage -> IO PartialStorage -derivePartialStorage parent = do - st <- memoryStorage' - return $ st { stParent = Just parent } - -type Ref = Ref' Complete -type PartialRef = Ref' Partial - zeroRef :: Storage' c -> Ref' c zeroRef s = Ref s (RefDigest h) where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of @@ -308,7 +216,7 @@ ioLoadObject ref@(Ref st rhash) = do let chash = hashToRefDigest file when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -} return $ case runExcept $ unsafeDeserializeObject st file of - Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} + Left err -> error $ showErebosError err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} Right (x, rest) | BL.null rest -> x | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} @@ -316,7 +224,7 @@ lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.By lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString) lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref -unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString) +unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except ErebosError (Object' c, BL.ByteString) unsafeDeserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes) unsafeDeserializeObject st bytes = case BLC.break (=='\n') bytes of @@ -325,10 +233,10 @@ unsafeDeserializeObject st bytes = guard $ B.length content == len (,next) <$> case otype of _ | otype == BC.pack "blob" -> return $ Blob content - | otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ") + | otype == BC.pack "rec" -> maybe (throwOtherError $ "malformed record item ") (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content | otherwise -> return $ UnknownObject otype content - _ -> throwError $ "Malformed object" + _ -> throwOtherError $ "malformed object" where splitObjPrefix line = do [otype, tlen] <- return $ BLC.words line (len, rest) <- BLC.readInt tlen @@ -363,10 +271,10 @@ unsafeDeserializeObject st bytes = _ -> Nothing return (name, val) -deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString) +deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString) deserializeObject = unsafeDeserializeObject -deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject] +deserializeObjects :: PartialStorage -> BL.ByteString -> Except ErebosError [PartialObject] deserializeObjects _ bytes | BL.null bytes = return [] deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes (obj:) <$> deserializeObjects st rest @@ -437,11 +345,12 @@ newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString type StoreRec c = StoreRecM c () -newtype Load a = Load (ReaderT (Ref, Object) (Except String) a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) +newtype Load a = Load (ReaderT (Ref, Object) (Except ErebosError) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError) evalLoad :: Load a -> Ref -> a -evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref) +evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ") ++) . showErebosError) id $ + runExcept $ runReaderT f (ref, lazyLoadObject ref) loadCurrentRef :: Load Ref loadCurrentRef = Load $ asks fst @@ -449,8 +358,8 @@ loadCurrentRef = Load $ asks fst loadCurrentObject :: Load Object loadCurrentObject = Load $ asks snd -newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) +newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except ErebosError) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError) loadRecCurrentRef :: LoadRec Ref loadRecCurrentRef = LoadRec $ asks fst @@ -506,7 +415,7 @@ storeZero = StoreZero class StorableText a where toText :: a -> Text - fromText :: MonadError String m => Text -> m a + fromText :: MonadError ErebosError m => Text -> m a instance StorableText Text where toText = id; fromText = return @@ -619,23 +528,23 @@ storeRecItems items = StoreRecM $ do loadBlob :: (ByteString -> a) -> Load a loadBlob f = loadCurrentObject >>= \case Blob x -> return $ f x - _ -> throwError "Expecting blob" + _ -> throwOtherError "Expecting blob" loadRec :: LoadRec a -> Load a loadRec (LoadRec lrec) = loadCurrentObject >>= \case Rec rs -> do ref <- loadCurrentRef either throwError return $ runExcept $ runReaderT lrec (ref, rs) - _ -> throwError "Expecting record" + _ -> throwOtherError "Expecting record" loadZero :: a -> Load a loadZero x = loadCurrentObject >>= \case ZeroObject -> return x - _ -> throwError "Expecting zero" + _ -> throwOtherError "Expecting zero" loadEmpty :: String -> LoadRec () -loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name +loadEmpty name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name loadMbEmpty :: String -> LoadRec (Maybe ()) loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems @@ -646,7 +555,7 @@ loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadInt :: Num a => String -> LoadRec a -loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name +loadInt name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbInt name loadMbInt :: Num a => String -> LoadRec (Maybe a) loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems @@ -657,7 +566,7 @@ loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadNum :: (Real a, Fractional a) => String -> LoadRec a -loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name +loadNum name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbNum name loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a) loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems @@ -668,7 +577,7 @@ loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadText :: StorableText a => String -> LoadRec a -loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name +loadText name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbText name loadMbText :: StorableText a => String -> LoadRec (Maybe a) loadMbText name = listToMaybe <$> loadTexts name @@ -682,7 +591,7 @@ loadTexts name = sequence . mapMaybe p =<< loadRecItems p _ = Nothing loadBinary :: BA.ByteArray a => String -> LoadRec a -loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name +loadBinary name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbBinary name loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) loadMbBinary name = listToMaybe <$> loadBinaries name @@ -696,7 +605,7 @@ loadBinaries name = mapMaybe p <$> loadRecItems p _ = Nothing loadDate :: StorableDate a => String -> LoadRec a -loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name +loadDate name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbDate name loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems @@ -707,7 +616,7 @@ loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadUUID :: StorableUUID a => String -> LoadRec a -loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name +loadUUID name = maybe (throwOtherError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems @@ -718,7 +627,7 @@ loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadRawRef :: String -> LoadRec Ref -loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name +loadRawRef name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name loadMbRawRef :: String -> LoadRec (Maybe Ref) loadMbRawRef name = listToMaybe <$> loadRawRefs name @@ -778,72 +687,6 @@ unsafeMapStored :: (a -> b) -> Stored a -> Stored b unsafeMapStored f (Stored ref x) = Stored ref (f x) -data StoreInfo = StoreInfo - { infoDate :: ZonedTime - , infoNote :: Maybe Text - } - deriving (Show) - -makeStoreInfo :: IO StoreInfo -makeStoreInfo = StoreInfo - <$> getZonedTime - <*> pure Nothing - -storeInfoRec :: StoreInfo -> StoreRec c -storeInfoRec info = do - storeDate "date" $ infoDate info - storeMbText "note" $ infoNote info - -loadInfoRec :: LoadRec StoreInfo -loadInfoRec = StoreInfo - <$> loadDate "date" - <*> loadMbText "note" - - -data History a = History StoreInfo (Stored a) (Maybe (StoredHistory a)) - deriving (Show) - -type StoredHistory a = Stored (History a) - -instance Storable a => Storable (History a) where - store' (History si x prev) = storeRec $ do - storeInfoRec si - storeMbRef "prev" prev - storeRef "item" x - - load' = loadRec $ History - <$> loadInfoRec - <*> loadRef "item" - <*> loadMbRef "prev" - -fromHistory :: StoredHistory a -> a -fromHistory = fromStored . storedFromHistory - -fromHistoryAt :: ZonedTime -> StoredHistory a -> Maybe a -fromHistoryAt zat = fmap (fromStored . snd) . listToMaybe . dropWhile ((at<) . zonedTimeToUTC . fst) . storedHistoryTimedList - where at = zonedTimeToUTC zat - -storedFromHistory :: StoredHistory a -> Stored a -storedFromHistory sh = let History _ item _ = fromStored sh - in item - -storedHistoryList :: StoredHistory a -> [Stored a] -storedHistoryList = map snd . storedHistoryTimedList - -storedHistoryTimedList :: StoredHistory a -> [(ZonedTime, Stored a)] -storedHistoryTimedList sh = let History hinfo item prev = fromStored sh - in (infoDate hinfo, item) : maybe [] storedHistoryTimedList prev - -beginHistory :: Storable a => Storage -> StoreInfo -> a -> IO (StoredHistory a) -beginHistory st si x = do sx <- wrappedStore st x - wrappedStore st $ History si sx Nothing - -modifyHistory :: Storable a => StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a) -modifyHistory si f prev@(Stored (Ref st _) _) = do - sx <- wrappedStore st $ f $ fromHistory prev - wrappedStore st $ History si sx (Just prev) - - showRatio :: Rational -> String showRatio r = case decimalRatio r of Just (n, 1) -> show n |