From f4394413ab3cf2dfb94b1f024a047938cfd471e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 30 Oct 2024 20:06:03 +0100 Subject: Rename Erebos.Storage module to Erebos.Object.Internal --- src/Erebos/Attach.hs | 2 +- src/Erebos/Channel.hs | 2 +- src/Erebos/Chatroom.hs | 2 +- src/Erebos/Contact.hs | 2 +- src/Erebos/Conversation.hs | 4 +- src/Erebos/Discovery.hs | 2 +- src/Erebos/ICE.chs | 2 +- src/Erebos/Identity.hs | 2 +- src/Erebos/Message.hs | 2 +- src/Erebos/Network.hs | 2 +- src/Erebos/Network.hs-boot | 2 +- src/Erebos/Network/Protocol.hs | 2 +- src/Erebos/Object/Internal.hs | 1081 ++++++++++++++++++++++++++++++++++++++++ src/Erebos/Pairing.hs | 2 +- src/Erebos/PubKey.hs | 2 +- src/Erebos/Service.hs | 2 +- src/Erebos/Set.hs | 2 +- src/Erebos/State.hs | 2 +- src/Erebos/Storage.hs | 1081 ---------------------------------------- src/Erebos/Storage/Key.hs | 2 +- src/Erebos/Storage/Merge.hs | 2 +- src/Erebos/Sync.hs | 2 +- 22 files changed, 1102 insertions(+), 1102 deletions(-) create mode 100644 src/Erebos/Object/Internal.hs delete mode 100644 src/Erebos/Storage.hs (limited to 'src/Erebos') diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs index bd2f521..e0a240e 100644 --- a/src/Erebos/Attach.hs +++ b/src/Erebos/Attach.hs @@ -16,11 +16,11 @@ import qualified Data.Text as T import Erebos.Identity import Erebos.Network +import Erebos.Object.Internal import Erebos.Pairing import Erebos.PubKey import Erebos.Service import Erebos.State -import Erebos.Storage import Erebos.Storage.Key type AttachService = PairingService AttachIdentity diff --git a/src/Erebos/Channel.hs b/src/Erebos/Channel.hs index 5f66637..c17c9ab 100644 --- a/src/Erebos/Channel.hs +++ b/src/Erebos/Channel.hs @@ -26,8 +26,8 @@ import Data.ByteString.Lazy qualified as BL import Data.List import Erebos.Identity +import Erebos.Object.Internal import Erebos.PubKey -import Erebos.Storage data Channel = Channel { chPeers :: [Stored (Signed IdentityData)] diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index 8833450..25c8c17 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -49,11 +49,11 @@ import Data.Text (Text) import Data.Time import Erebos.Identity +import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State -import Erebos.Storage import Erebos.Storage.Merge import Erebos.Util diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs index d90aa50..0af434f 100644 --- a/src/Erebos/Contact.hs +++ b/src/Erebos/Contact.hs @@ -23,12 +23,12 @@ import qualified Data.Text as T import Erebos.Identity import Erebos.Network +import Erebos.Object.Internal import Erebos.Pairing import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State -import Erebos.Storage import Erebos.Storage.Merge data Contact = Contact diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs index 63475bd..4c68830 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -29,11 +29,11 @@ import Data.Text qualified as T import Data.Time.Format import Data.Time.LocalTime -import Erebos.Identity import Erebos.Chatroom +import Erebos.Identity import Erebos.Message hiding (formatMessage) +import Erebos.Object.Internal import Erebos.State -import Erebos.Storage data Message = DirectMessageMessage DirectMessage Bool diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 48df9c3..d89a7fa 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -19,8 +19,8 @@ import Network.Socket import Erebos.ICE import Erebos.Identity import Erebos.Network +import Erebos.Object.Internal import Erebos.Service -import Erebos.Storage keepaliveSeconds :: Int diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs index 096ee0d..787ce51 100644 --- a/src/Erebos/ICE.chs +++ b/src/Erebos/ICE.chs @@ -40,7 +40,7 @@ import Foreign.Ptr import Foreign.StablePtr import Erebos.Flow -import Erebos.Storage +import Erebos.Object.Internal #include "pjproject.h" diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs index 577e5ac..fdfacfc 100644 --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -40,8 +40,8 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T +import Erebos.Object.Internal import Erebos.PubKey -import Erebos.Storage import Erebos.Storage.Merge import Erebos.Util diff --git a/src/Erebos/Message.hs b/src/Erebos/Message.hs index 5ef27f3..a558d1a 100644 --- a/src/Erebos/Message.hs +++ b/src/Erebos/Message.hs @@ -31,9 +31,9 @@ import Data.Time.LocalTime import Erebos.Identity import Erebos.Network +import Erebos.Object.Internal import Erebos.Service import Erebos.State -import Erebos.Storage import Erebos.Storage.Merge data DirectMessage = DirectMessage diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs index 2064d1c..358bb7c 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -63,10 +63,10 @@ import Erebos.ICE #endif import Erebos.Identity import Erebos.Network.Protocol +import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.State -import Erebos.Storage import Erebos.Storage.Key import Erebos.Storage.Merge diff --git a/src/Erebos/Network.hs-boot b/src/Erebos/Network.hs-boot index 849bfc1..af77581 100644 --- a/src/Erebos/Network.hs-boot +++ b/src/Erebos/Network.hs-boot @@ -1,6 +1,6 @@ module Erebos.Network where -import Erebos.Storage +import Erebos.Object.Internal data Server data Peer diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs index cfbaea3..bceb355 100644 --- a/src/Erebos/Network/Protocol.hs +++ b/src/Erebos/Network/Protocol.hs @@ -67,8 +67,8 @@ import System.Clock import Erebos.Channel import Erebos.Flow import Erebos.Identity +import Erebos.Object.Internal import Erebos.Service -import Erebos.Storage protocolVersion :: Text diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs new file mode 100644 index 0000000..638689a --- /dev/null +++ b/src/Erebos/Object/Internal.hs @@ -0,0 +1,1081 @@ +module Erebos.Object.Internal ( + Storage, PartialStorage, StorageCompleteness, + openStorage, memoryStorage, + deriveEphemeralStorage, derivePartialStorage, + + Ref, PartialRef, RefDigest, + refDigest, + readRef, showRef, showRefDigest, + refDigestFromByteString, hashToRefDigest, + copyRef, partialRef, partialRefFromDigest, + + Object, PartialObject, Object'(..), RecItem, RecItem'(..), + serializeObject, deserializeObject, deserializeObjects, + ioLoadObject, ioLoadBytes, + storeRawBytes, lazyLoadBytes, + storeObject, + collectObjects, collectStoredObjects, + + Head, HeadType(..), + HeadTypeID, mkHeadTypeID, + headId, headStorage, headRef, headObject, headStoredObject, + loadHeads, loadHead, reloadHead, + storeHead, replaceHead, updateHead, updateHead_, + loadHeadRaw, storeHeadRaw, replaceHeadRaw, + + WatchedHead, + watchHead, watchHeadWith, unwatchHead, + watchHeadRaw, + + MonadStorage(..), + + Storable(..), ZeroStorable(..), + StorableText(..), StorableDate(..), StorableUUID(..), + + Store, StoreRec, + evalStore, evalStoreObject, + storeBlob, storeRec, storeZero, + storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, + storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, + storeZRef, + storeRecItems, + + Load, LoadRec, + evalLoad, + loadCurrentRef, loadCurrentObject, + loadRecCurrentRef, loadRecItems, + + loadBlob, loadRec, loadZero, + loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, + loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, + loadTexts, loadBinaries, loadRefs, loadRawRefs, + loadZRef, + + Stored, + fromStored, storedRef, + 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 +import Control.Monad.Writer + +import Crypto.Hash + +import Data.Bifunctor +import Data.ByteString (ByteString) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +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 Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Text.Encoding.Error +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.Format +import Data.Time.LocalTime +import Data.Typeable +import Data.UUID (UUID) +import qualified Data.UUID as U +import qualified Data.UUID.V4 as U + +import System.Directory +import System.FSNotify +import System.FilePath +import System.IO.Error +import System.IO.Unsafe + +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 + Nothing -> error $ "Failed to create zero hash" + Just h' -> h' + digestAlgo :: Digest a -> a + digestAlgo = undefined + +isZeroRef :: Ref' c -> Bool +isZeroRef (Ref _ h) = all (==0) $ BA.unpack h + + +refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c)) +refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst + +readRef :: Storage -> ByteString -> IO (Maybe Ref) +readRef s b = + case readRefDigest b of + Nothing -> return Nothing + Just dgst -> refFromDigest s dgst + +copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c')) +copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref + Nothing -> doCopy + where doCopy = do mbobj' <- ioLoadObject ref' + mbobj <- sequence $ copyObject' st <$> mbobj' + sequence $ unsafeStoreObject st <$> join mbobj + +copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c')) +copyRecItem' st = \case + RecEmpty -> return $ return $ RecEmpty + RecInt x -> return $ return $ RecInt x + RecNum x -> return $ return $ RecNum x + RecText x -> return $ return $ RecText x + RecBinary x -> return $ return $ RecBinary x + RecDate x -> return $ return $ RecDate x + RecUUID x -> return $ return $ RecUUID x + RecRef x -> fmap RecRef <$> copyRef' st x + RecUnknown t x -> return $ return $ RecUnknown t x + +copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) +copyObject' _ (Blob bs) = return $ return $ Blob bs +copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs +copyObject' _ ZeroObject = return $ return ZeroObject +copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content + +copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c')) +copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref' + +copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c')) +copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item' + +copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c')) +copyObject st obj' = returnLoadResult <$> copyObject' st obj' + +partialRef :: PartialStorage -> Ref -> PartialRef +partialRef st (Ref _ dgst) = Ref st dgst + +partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef +partialRefFromDigest st dgst = Ref st dgst + + +data Object' c + = Blob ByteString + | Rec [(ByteString, RecItem' c)] + | ZeroObject + | UnknownObject ByteString ByteString + deriving (Show) + +type Object = Object' Complete +type PartialObject = Object' Partial + +data RecItem' c + = RecEmpty + | RecInt Integer + | RecNum Rational + | RecText Text + | RecBinary ByteString + | RecDate ZonedTime + | RecUUID UUID + | RecRef (Ref' c) + | RecUnknown ByteString ByteString + deriving (Show) + +type RecItem = RecItem' Complete + +serializeObject :: Object' c -> BL.ByteString +serializeObject = \case + Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] + Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec + in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt + ZeroObject -> BL.empty + UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ] + +-- |Serializes and stores object data without ony dependencies, so is safe only +-- if all the referenced objects are already stored or reference is partial. +unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c) +unsafeStoreObject storage = \case + ZeroObject -> return $ zeroRef storage + obj -> unsafeStoreRawBytes storage $ serializeObject obj + +storeObject :: PartialStorage -> PartialObject -> IO PartialRef +storeObject = unsafeStoreObject + +storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef +storeRawBytes = unsafeStoreRawBytes + +serializeRecItem :: ByteString -> RecItem' c -> [ByteString] +serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n'] +serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n'] +serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n'] +serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n'] + where escaped = BC.concatMap escape $ encodeUtf8 x + escape '\n' = BC.pack "\n\t" + escape c = BC.singleton c +serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n'] +serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n'] +serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n'] +serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n'] +serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ] + +lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) +lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject + +ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c)) +ioLoadObject ref | isZeroRef ref = return $ return ZeroObject +ioLoadObject ref@(Ref st rhash) = do + file' <- ioLoadBytes ref + return $ do + file <- file' + 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 -} + Right (x, rest) | BL.null rest -> x + | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} + +lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString +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 _ bytes | BL.null bytes = return (ZeroObject, bytes) +unsafeDeserializeObject st bytes = + case BLC.break (=='\n') bytes of + (line, rest) | Just (otype, len) <- splitObjPrefix line -> do + let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest + 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 ") + (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content + | otherwise -> return $ UnknownObject otype content + _ -> throwError $ "Malformed object" + where splitObjPrefix line = do + [otype, tlen] <- return $ BLC.words line + (len, rest) <- BLC.readInt tlen + guard $ BL.null rest + return (BL.toStrict otype, len) + + mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest) + mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest + mergeCont _ [] = [] + + parseRecLine line = do + colon <- BC.elemIndex ':' line + space <- BC.elemIndex ' ' line + guard $ colon < space + let name = B.take colon line + itype = B.take (space-colon-1) $ B.drop (colon+1) line + content = B.drop (space+1) line + + let val = fromMaybe (RecUnknown itype content) $ + case BC.unpack itype of + "e" -> do guard $ B.null content + return RecEmpty + "i" -> do (num, rest) <- BC.readInteger content + guard $ B.null rest + return $ RecInt num + "n" -> RecNum <$> parseRatio content + "t" -> return $ RecText $ decodeUtf8With lenientDecode content + "b" -> RecBinary <$> readHex content + "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) + "u" -> RecUUID <$> U.fromASCIIBytes content + "r" -> RecRef . Ref st <$> readRefDigest content + _ -> Nothing + return (name, val) + +deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString) +deserializeObject = unsafeDeserializeObject + +deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject] +deserializeObjects _ bytes | BL.null bytes = return [] +deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes + (obj:) <$> deserializeObjects st rest + + +collectObjects :: Object -> [Object] +collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj) + +collectStoredObjects :: Stored Object -> [Stored Object] +collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj) + +collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest) +collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items + where helper (RecRef ref) (xs, s) | r <- refDigest ref + , r `S.notMember` s + = let o = wrappedLoad ref + (xs', s') = collectOtherStored (S.insert r s) $ fromStored o + in ((o : xs') ++ xs, s') + helper _ (xs, s) = (xs, s) +collectOtherStored seen _ = ([], seen) + + +type Head = Head' Complete + +headId :: Head a -> HeadID +headId (Head uuid _) = uuid + +headStorage :: Head a -> Storage +headStorage = refStorage . headRef + +headRef :: Head a -> Ref +headRef (Head _ sx) = storedRef sx + +headObject :: Head a -> a +headObject (Head _ sx) = fromStored sx + +headStoredObject :: Head a -> Stored a +headStoredObject (Head _ sx) = sx + +deriving instance StorableUUID HeadID +deriving instance StorableUUID HeadTypeID + +mkHeadTypeID :: String -> HeadTypeID +mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString + +class Storable a => HeadType a where + headTypeID :: proxy a -> HeadTypeID + + +headTypePath :: FilePath -> HeadTypeID -> FilePath +headTypePath spath (HeadTypeID tid) = spath "heads" U.toString tid + +headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath +headPath spath tid (HeadID hid) = headTypePath spath tid U.toString hid + +loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] +loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do + let hpath = headTypePath spath $ headTypeID @a Proxy + + files <- filterM (doesFileExist . (hpath )) =<< + handleJust (\e -> guard (isDoesNotExistError e)) (const $ return []) + (getDirectoryContents hpath) + fmap catMaybes $ forM files $ \hname -> do + case U.fromString hname of + Just hid -> do + (h:_) <- BC.lines <$> B.readFile (hpath hname) + Just ref <- readRef s h + return $ Just $ Head (HeadID hid) $ wrappedLoad ref + Nothing -> return Nothing +loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do + let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref + | otherwise = Nothing + catMaybes . map toHead <$> readMVar theads + +loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a)) +loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid + +loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref) +loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do + handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do + (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid) + Just ref <- readRef s h + return $ Just ref +loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do + lookup (tid, hid) <$> readMVar theads + +reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) +reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid + +storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) +storeHead st obj = do + let tid = headTypeID @a Proxy + stored <- wrappedStore st obj + hid <- storeHeadRaw st tid (storedRef stored) + return $ Head hid stored + +storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID +storeHeadRaw st tid ref = liftIO $ do + hid <- HeadID <$> U.nextRandom + case stBacking st of + StorageDir { dirPath = spath } -> do + Right () <- writeFileChecked (headPath spath tid hid) Nothing $ + showRef ref `B.append` BC.singleton '\n' + return () + StorageMemory { memHeads = theads } -> do + modifyMVar_ theads $ return . (((tid, hid), ref) :) + return hid + +replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a)) +replaceHead prev@(Head hid pobj) stored' = liftIO $ do + let st = headStorage prev + tid = headTypeID @a Proxy + stored <- copyStored st stored' + bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> + replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) + +replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref) +replaceHeadRaw st tid hid prev new = liftIO $ do + case stBacking st of + StorageDir { dirPath = spath } -> do + let filename = headPath spath tid hid + showRefL r = showRef r `B.append` BC.singleton '\n' + + writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case + Left Nothing -> return $ Left Nothing + Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs + return $ Left $ Just oref + Right () -> return $ Right new + + StorageMemory { memHeads = theads, memWatchers = twatch } -> do + res <- modifyMVar theads $ \hs -> do + ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch + return $ case partition ((==(tid, hid)) . fst) hs of + ([] , _ ) -> (hs, Left Nothing) + ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs', + Right (new, ws)) + | otherwise -> (hs, Left $ Just r) + case res of + Right (r, ws) -> mapM_ ($ r) ws >> return (Right r) + Left x -> return $ Left x + +updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b) +updateHead h f = do + (o, x) <- f $ headStoredObject h + replaceHead h o >>= \case + Right h' -> return (Just h', x) + Left Nothing -> return (Nothing, x) + Left (Just h') -> updateHead h' f + +updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a)) +updateHead_ h = fmap fst . updateHead h . (fmap (,()) .) + + +data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a) + +watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead +watchHead h = watchHeadWith h id + +watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead +watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do + watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb + +watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead +watchHeadRaw st tid hid sel cb = do + memo <- newEmptyMVar + let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) + where wl' = wl { wlNext = wlNext wl + 1 + , wlList = WatchListItem + { wlID = wlNext wl + , wlHead = (tid, hid) + , wlFun = \r -> do + let x = sel r + modifyMVar_ memo $ \prev -> do + when (Just x /= prev) $ cb x + return $ Just x + } : wlList wl + } + + watched <- case stBacking st of + StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do + manager <- maybe startManager return mbmanager + ilist' <- case tid `elem` ilist of + True -> return ilist + False -> do + void $ watchDir manager (headTypePath spath tid) (const True) $ \case + Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do + loadHeadRaw st tid ihid >>= \case + Just ref -> do + (_, _, iwl) <- readMVar mvar + mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl + Nothing -> return () + _ -> return () + return $ tid : ilist + return $ first ( Just manager, ilist', ) $ addWatcher wl + + StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher + + cur <- fmap sel <$> loadHeadRaw st tid hid + maybe (return ()) cb cur + putMVar memo cur + + return watched + +unwatchHead :: WatchedHead -> IO () +unwatchHead (WatchedHead st wid _) = do + let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl } + case stBacking st of + StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher + StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher + + +class Monad m => MonadStorage m where + getStorage :: m Storage + mstore :: Storable a => a -> m (Stored a) + + default mstore :: MonadIO m => Storable a => a -> m (Stored a) + mstore x = do + st <- getStorage + wrappedStore st x + +instance MonadIO m => MonadStorage (ReaderT Storage m) where + getStorage = ask + +instance MonadIO m => MonadStorage (ReaderT (Head a) m) where + getStorage = asks $ headStorage + + +class Storable a where + store' :: a -> Store + load' :: Load a + + store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c) + store st = evalStore st . store' + load :: Ref -> a + load = evalLoad load' + +class Storable a => ZeroStorable a where + fromZero :: Storage -> a + +data Store = StoreBlob ByteString + | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]]) + | StoreZero + | StoreUnknown ByteString ByteString + +evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c) +evalStore st = unsafeStoreObject st <=< evalStoreObject st + +evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c) +evalStoreObject _ (StoreBlob x) = return $ Blob x +evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s) +evalStoreObject _ StoreZero = return ZeroObject +evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content + +newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a) + deriving (Functor, Applicative, Monad) + +type StoreRec c = StoreRecM c () + +newtype Load a = Load (ReaderT (Ref, Object) (Except String) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) + +evalLoad :: Load a -> Ref -> a +evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref) + +loadCurrentRef :: Load Ref +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) + +loadRecCurrentRef :: LoadRec Ref +loadRecCurrentRef = LoadRec $ asks fst + +loadRecItems :: LoadRec [(ByteString, RecItem)] +loadRecItems = LoadRec $ asks snd + + +instance Storable Object where + store' (Blob bs) = StoreBlob bs + store' (Rec xs) = StoreRec $ \st -> return $ do + Rec xs' <- copyObject st (Rec xs) + return xs' + store' ZeroObject = StoreZero + store' (UnknownObject otype content) = StoreUnknown otype content + + load' = loadCurrentObject + + store st = unsafeStoreObject st <=< copyObject st + load = lazyLoadObject + +instance Storable ByteString where + store' = storeBlob + load' = loadBlob id + +instance Storable a => Storable [a] where + store' [] = storeZero + store' (x:xs) = storeRec $ do + storeRef "i" x + storeRef "n" xs + + load' = loadCurrentObject >>= \case + ZeroObject -> return [] + _ -> loadRec $ (:) + <$> loadRef "i" + <*> loadRef "n" + +instance Storable a => ZeroStorable [a] where + fromZero _ = [] + + +storeBlob :: ByteString -> Store +storeBlob = StoreBlob + +storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store +storeRec sr = StoreRec $ do + let StoreRecM r = sr + execWriter . runReaderT r + +storeZero :: Store +storeZero = StoreZero + + +class StorableText a where + toText :: a -> Text + fromText :: MonadError String m => Text -> m a + +instance StorableText Text where + toText = id; fromText = return + +instance StorableText [Char] where + toText = T.pack; fromText = return . T.unpack + + +class StorableDate a where + toDate :: a -> ZonedTime + fromDate :: ZonedTime -> a + +instance StorableDate ZonedTime where + toDate = id; fromDate = id + +instance StorableDate UTCTime where + toDate = utcToZonedTime utc + fromDate = zonedTimeToUTC + +instance StorableDate Day where + toDate day = toDate $ UTCTime day 0 + fromDate = utctDay . fromDate + + +class StorableUUID a where + toUUID :: a -> UUID + fromUUID :: UUID -> a + +instance StorableUUID UUID where + toUUID = id; fromUUID = id + + +storeEmpty :: String -> StoreRec c +storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]] + +storeMbEmpty :: String -> Maybe () -> StoreRec c +storeMbEmpty name = maybe (return ()) (const $ storeEmpty name) + +storeInt :: Integral a => String -> a -> StoreRec c +storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]] + +storeMbInt :: Integral a => String -> Maybe a -> StoreRec c +storeMbInt name = maybe (return ()) (storeInt name) + +storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c +storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]] + +storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c +storeMbNum name = maybe (return ()) (storeNum name) + +storeText :: StorableText a => String -> a -> StoreRec c +storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]] + +storeMbText :: StorableText a => String -> Maybe a -> StoreRec c +storeMbText name = maybe (return ()) (storeText name) + +storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c +storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]] + +storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c +storeMbBinary name = maybe (return ()) (storeBinary name) + +storeDate :: StorableDate a => String -> a -> StoreRec c +storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]] + +storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c +storeMbDate name = maybe (return ()) (storeDate name) + +storeUUID :: StorableUUID a => String -> a -> StoreRec c +storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]] + +storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c +storeMbUUID name = maybe (return ()) (storeUUID name) + +storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c +storeRef name x = StoreRecM $ do + s <- ask + tell $ (:[]) $ do + ref <- store s x + return [(BC.pack name, RecRef ref)] + +storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c +storeMbRef name = maybe (return ()) (storeRef name) + +storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c +storeRawRef name ref = StoreRecM $ do + st <- ask + tell $ (:[]) $ do + ref' <- copyRef st ref + return [(BC.pack name, RecRef ref')] + +storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c +storeMbRawRef name = maybe (return ()) (storeRawRef name) + +storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c +storeZRef name x = StoreRecM $ do + s <- ask + tell $ (:[]) $ do + ref <- store s x + return $ if isZeroRef ref then [] + else [(BC.pack name, RecRef ref)] + +storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c +storeRecItems items = StoreRecM $ do + st <- ask + tell $ flip map items $ \( name, value ) -> do + value' <- copyRecItem st value + return [ ( name, value' ) ] + +loadBlob :: (ByteString -> a) -> Load a +loadBlob f = loadCurrentObject >>= \case + Blob x -> return $ f x + _ -> throwError "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" + +loadZero :: a -> Load a +loadZero x = loadCurrentObject >>= \case + ZeroObject -> return x + _ -> throwError "Expecting zero" + + +loadEmpty :: String -> LoadRec () +loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name + +loadMbEmpty :: String -> LoadRec (Maybe ()) +loadMbEmpty name = (lookup (BC.pack name) <$> loadRecItems) >>= \case + Nothing -> return Nothing + Just (RecEmpty) -> return (Just ()) + Just _ -> throwError $ "Expecting type int of record item '"++name++"'" + +loadInt :: Num a => String -> LoadRec a +loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name + +loadMbInt :: Num a => String -> LoadRec (Maybe a) +loadMbInt name = (lookup (BC.pack name) <$> loadRecItems) >>= \case + Nothing -> return Nothing + Just (RecInt x) -> return (Just $ fromInteger x) + Just _ -> throwError $ "Expecting type int of record item '"++name++"'" + +loadNum :: (Real a, Fractional a) => String -> LoadRec a +loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name + +loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a) +loadMbNum name = (lookup (BC.pack name) <$> loadRecItems) >>= \case + Nothing -> return Nothing + Just (RecNum x) -> return (Just $ fromRational x) + Just _ -> throwError $ "Expecting type number of record item '"++name++"'" + +loadText :: StorableText a => String -> LoadRec a +loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name + +loadMbText :: StorableText a => String -> LoadRec (Maybe a) +loadMbText name = (lookup (BC.pack name) <$> loadRecItems) >>= \case + Nothing -> return Nothing + Just (RecText x) -> Just <$> fromText x + Just _ -> throwError $ "Expecting type text of record item '"++name++"'" + +loadTexts :: StorableText a => String -> LoadRec [a] +loadTexts name = do + items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems + forM items $ \case RecText x -> fromText x + _ -> throwError $ "Expecting type text of record item '"++name++"'" + +loadBinary :: BA.ByteArray a => String -> LoadRec a +loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name + +loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) +loadMbBinary name = (lookup (BC.pack name) <$> loadRecItems) >>= \case + Nothing -> return Nothing + Just (RecBinary x) -> return $ Just $ BA.convert x + Just _ -> throwError $ "Expecting type binary of record item '"++name++"'" + +loadBinaries :: BA.ByteArray a => String -> LoadRec [a] +loadBinaries name = do + items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems + forM items $ \case RecBinary x -> return $ BA.convert x + _ -> throwError $ "Expecting type binary of record item '"++name++"'" + +loadDate :: StorableDate a => String -> LoadRec a +loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name + +loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) +loadMbDate name = (lookup (BC.pack name) <$> loadRecItems) >>= \case + Nothing -> return Nothing + Just (RecDate x) -> return $ Just $ fromDate x + Just _ -> throwError $ "Expecting type date of record item '"++name++"'" + +loadUUID :: StorableUUID a => String -> LoadRec a +loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name + +loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) +loadMbUUID name = (lookup (BC.pack name) <$> loadRecItems) >>= \case + Nothing -> return Nothing + Just (RecUUID x) -> return $ Just $ fromUUID x + Just _ -> throwError $ "Expecting type UUID of record item '"++name++"'" + +loadRawRef :: String -> LoadRec Ref +loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name + +loadMbRawRef :: String -> LoadRec (Maybe Ref) +loadMbRawRef name = (lookup (BC.pack name) <$> loadRecItems) >>= \case + Nothing -> return Nothing + Just (RecRef x) -> return (Just x) + Just _ -> throwError $ "Expecting type ref of record item '"++name++"'" + +loadRawRefs :: String -> LoadRec [Ref] +loadRawRefs name = do + items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems + forM items $ \case RecRef x -> return x + _ -> throwError $ "Expecting type ref of record item '"++name++"'" + +loadRef :: Storable a => String -> LoadRec a +loadRef name = load <$> loadRawRef name + +loadMbRef :: Storable a => String -> LoadRec (Maybe a) +loadMbRef name = fmap load <$> loadMbRawRef name + +loadRefs :: Storable a => String -> LoadRec [a] +loadRefs name = map load <$> loadRawRefs name + +loadZRef :: ZeroStorable a => String -> LoadRec a +loadZRef name = loadMbRef name >>= \case + Nothing -> do Ref st _ <- loadRecCurrentRef + return $ fromZero st + Just x -> return x + + +type Stored a = Stored' Complete a + +instance Storable a => Storable (Stored a) where + store st = copyRef st . storedRef + store' (Stored _ x) = store' x + load' = Stored <$> loadCurrentRef <*> load' + +instance ZeroStorable a => ZeroStorable (Stored a) where + fromZero st = Stored (zeroRef st) $ fromZero st + +fromStored :: Stored a -> a +fromStored (Stored _ x) = x + +storedRef :: Stored a -> Ref +storedRef (Stored ref _) = ref + +wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a) +wrappedStore st x = do ref <- liftIO $ store st x + return $ Stored ref x + +wrappedLoad :: Storable a => Ref -> Stored a +wrappedLoad ref = Stored ref (load ref) + +copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => + Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a)) +copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref' + +-- |Passed function needs to preserve the object representation to be safe +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 + Just (n', d) -> let n = abs n' + in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." ++ + (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d))) + Nothing -> show (numerator r) ++ "/" ++ show (denominator r) + +decimalRatio :: Rational -> Maybe (Integer, Integer) +decimalRatio r = do + let n = numerator r + d = denominator r + (c2, d') = takeFactors 2 d + (c5, d'') = takeFactors 5 d' + guard $ d'' == 1 + let m = if c2 > c5 then 5 ^ (c2 - c5) + else 2 ^ (c5 - c2) + return (n * m, d * m) + +takeFactors :: Integer -> Integer -> (Integer, Integer) +takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f) + in (c+1, n') + | otherwise = (0, n) + +parseRatio :: ByteString -> Maybe Rational +parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of + (m:xs) | m == BC.pack "-" -> negate <$> positive xs + xs -> positive xs + where positive = \case + [bx] -> fromInteger . fst <$> BC.readInteger bx + [bx, op, by] -> do + (x, _) <- BC.readInteger bx + (y, _) <- BC.readInteger by + case BC.unpack op of + "." -> return $ (x % 1) + (y % (10 ^ BC.length by)) + "/" -> return $ x % y + _ -> Nothing + _ -> Nothing diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs index 2166e71..772eda0 100644 --- a/src/Erebos/Pairing.hs +++ b/src/Erebos/Pairing.hs @@ -27,10 +27,10 @@ import Data.Word import Erebos.Identity import Erebos.Network +import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.State -import Erebos.Storage data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest | PairingResponse Bytes diff --git a/src/Erebos/PubKey.hs b/src/Erebos/PubKey.hs index 09a8e02..5d0cf62 100644 --- a/src/Erebos/PubKey.hs +++ b/src/Erebos/PubKey.hs @@ -21,7 +21,7 @@ import Data.ByteArray import Data.ByteString (ByteString) import qualified Data.Text as T -import Erebos.Storage +import Erebos.Object.Internal import Erebos.Storage.Key data PublicKey = PublicKey ED.PublicKey diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs index f8428d1..5341c52 100644 --- a/src/Erebos/Service.hs +++ b/src/Erebos/Service.hs @@ -34,8 +34,8 @@ import qualified Data.UUID as U import Erebos.Identity import {-# SOURCE #-} Erebos.Network +import Erebos.Object.Internal import Erebos.State -import Erebos.Storage class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGlobalState s)) => Service s where serviceID :: proxy s -> ServiceID diff --git a/src/Erebos/Set.hs b/src/Erebos/Set.hs index c5edd56..1dc96ee 100644 --- a/src/Erebos/Set.hs +++ b/src/Erebos/Set.hs @@ -19,7 +19,7 @@ import Data.Map qualified as M import Data.Maybe import Data.Ord -import Erebos.Storage +import Erebos.Object.Internal import Erebos.Storage.Merge import Erebos.Util diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs index 3012064..40896f7 100644 --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -35,8 +35,8 @@ import Data.UUID qualified as U import System.IO import Erebos.Identity +import Erebos.Object.Internal import Erebos.PubKey -import Erebos.Storage import Erebos.Storage.Merge data LocalState = LocalState diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs deleted file mode 100644 index 2cef6c0..0000000 --- a/src/Erebos/Storage.hs +++ /dev/null @@ -1,1081 +0,0 @@ -module Erebos.Storage ( - Storage, PartialStorage, StorageCompleteness, - openStorage, memoryStorage, - deriveEphemeralStorage, derivePartialStorage, - - Ref, PartialRef, RefDigest, - refDigest, - readRef, showRef, showRefDigest, - refDigestFromByteString, hashToRefDigest, - copyRef, partialRef, partialRefFromDigest, - - Object, PartialObject, Object'(..), RecItem, RecItem'(..), - serializeObject, deserializeObject, deserializeObjects, - ioLoadObject, ioLoadBytes, - storeRawBytes, lazyLoadBytes, - storeObject, - collectObjects, collectStoredObjects, - - Head, HeadType(..), - HeadTypeID, mkHeadTypeID, - headId, headStorage, headRef, headObject, headStoredObject, - loadHeads, loadHead, reloadHead, - storeHead, replaceHead, updateHead, updateHead_, - loadHeadRaw, storeHeadRaw, replaceHeadRaw, - - WatchedHead, - watchHead, watchHeadWith, unwatchHead, - watchHeadRaw, - - MonadStorage(..), - - Storable(..), ZeroStorable(..), - StorableText(..), StorableDate(..), StorableUUID(..), - - Store, StoreRec, - evalStore, evalStoreObject, - storeBlob, storeRec, storeZero, - storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, - storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, - storeZRef, - storeRecItems, - - Load, LoadRec, - evalLoad, - loadCurrentRef, loadCurrentObject, - loadRecCurrentRef, loadRecItems, - - loadBlob, loadRec, loadZero, - loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, - loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, - loadTexts, loadBinaries, loadRefs, loadRawRefs, - loadZRef, - - Stored, - fromStored, storedRef, - 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 -import Control.Monad.Writer - -import Crypto.Hash - -import Data.Bifunctor -import Data.ByteString (ByteString) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -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 Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.Ratio -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding -import Data.Text.Encoding.Error -import Data.Time.Calendar -import Data.Time.Clock -import Data.Time.Format -import Data.Time.LocalTime -import Data.Typeable -import Data.UUID (UUID) -import qualified Data.UUID as U -import qualified Data.UUID.V4 as U - -import System.Directory -import System.FSNotify -import System.FilePath -import System.IO.Error -import System.IO.Unsafe - -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 - Nothing -> error $ "Failed to create zero hash" - Just h' -> h' - digestAlgo :: Digest a -> a - digestAlgo = undefined - -isZeroRef :: Ref' c -> Bool -isZeroRef (Ref _ h) = all (==0) $ BA.unpack h - - -refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c)) -refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst - -readRef :: Storage -> ByteString -> IO (Maybe Ref) -readRef s b = - case readRefDigest b of - Nothing -> return Nothing - Just dgst -> refFromDigest s dgst - -copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c')) -copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref - Nothing -> doCopy - where doCopy = do mbobj' <- ioLoadObject ref' - mbobj <- sequence $ copyObject' st <$> mbobj' - sequence $ unsafeStoreObject st <$> join mbobj - -copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c')) -copyRecItem' st = \case - RecEmpty -> return $ return $ RecEmpty - RecInt x -> return $ return $ RecInt x - RecNum x -> return $ return $ RecNum x - RecText x -> return $ return $ RecText x - RecBinary x -> return $ return $ RecBinary x - RecDate x -> return $ return $ RecDate x - RecUUID x -> return $ return $ RecUUID x - RecRef x -> fmap RecRef <$> copyRef' st x - RecUnknown t x -> return $ return $ RecUnknown t x - -copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) -copyObject' _ (Blob bs) = return $ return $ Blob bs -copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs -copyObject' _ ZeroObject = return $ return ZeroObject -copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content - -copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c')) -copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref' - -copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c')) -copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item' - -copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c')) -copyObject st obj' = returnLoadResult <$> copyObject' st obj' - -partialRef :: PartialStorage -> Ref -> PartialRef -partialRef st (Ref _ dgst) = Ref st dgst - -partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef -partialRefFromDigest st dgst = Ref st dgst - - -data Object' c - = Blob ByteString - | Rec [(ByteString, RecItem' c)] - | ZeroObject - | UnknownObject ByteString ByteString - deriving (Show) - -type Object = Object' Complete -type PartialObject = Object' Partial - -data RecItem' c - = RecEmpty - | RecInt Integer - | RecNum Rational - | RecText Text - | RecBinary ByteString - | RecDate ZonedTime - | RecUUID UUID - | RecRef (Ref' c) - | RecUnknown ByteString ByteString - deriving (Show) - -type RecItem = RecItem' Complete - -serializeObject :: Object' c -> BL.ByteString -serializeObject = \case - Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] - Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec - in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt - ZeroObject -> BL.empty - UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ] - --- |Serializes and stores object data without ony dependencies, so is safe only --- if all the referenced objects are already stored or reference is partial. -unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c) -unsafeStoreObject storage = \case - ZeroObject -> return $ zeroRef storage - obj -> unsafeStoreRawBytes storage $ serializeObject obj - -storeObject :: PartialStorage -> PartialObject -> IO PartialRef -storeObject = unsafeStoreObject - -storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef -storeRawBytes = unsafeStoreRawBytes - -serializeRecItem :: ByteString -> RecItem' c -> [ByteString] -serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n'] -serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n'] -serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n'] -serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n'] - where escaped = BC.concatMap escape $ encodeUtf8 x - escape '\n' = BC.pack "\n\t" - escape c = BC.singleton c -serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n'] -serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n'] -serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n'] -serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n'] -serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ] - -lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) -lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject - -ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c)) -ioLoadObject ref | isZeroRef ref = return $ return ZeroObject -ioLoadObject ref@(Ref st rhash) = do - file' <- ioLoadBytes ref - return $ do - file <- file' - 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 -} - Right (x, rest) | BL.null rest -> x - | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} - -lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString -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 _ bytes | BL.null bytes = return (ZeroObject, bytes) -unsafeDeserializeObject st bytes = - case BLC.break (=='\n') bytes of - (line, rest) | Just (otype, len) <- splitObjPrefix line -> do - let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest - 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 ") - (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content - | otherwise -> return $ UnknownObject otype content - _ -> throwError $ "Malformed object" - where splitObjPrefix line = do - [otype, tlen] <- return $ BLC.words line - (len, rest) <- BLC.readInt tlen - guard $ BL.null rest - return (BL.toStrict otype, len) - - mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest) - mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest - mergeCont _ [] = [] - - parseRecLine line = do - colon <- BC.elemIndex ':' line - space <- BC.elemIndex ' ' line - guard $ colon < space - let name = B.take colon line - itype = B.take (space-colon-1) $ B.drop (colon+1) line - content = B.drop (space+1) line - - let val = fromMaybe (RecUnknown itype content) $ - case BC.unpack itype of - "e" -> do guard $ B.null content - return RecEmpty - "i" -> do (num, rest) <- BC.readInteger content - guard $ B.null rest - return $ RecInt num - "n" -> RecNum <$> parseRatio content - "t" -> return $ RecText $ decodeUtf8With lenientDecode content - "b" -> RecBinary <$> readHex content - "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) - "u" -> RecUUID <$> U.fromASCIIBytes content - "r" -> RecRef . Ref st <$> readRefDigest content - _ -> Nothing - return (name, val) - -deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString) -deserializeObject = unsafeDeserializeObject - -deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject] -deserializeObjects _ bytes | BL.null bytes = return [] -deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes - (obj:) <$> deserializeObjects st rest - - -collectObjects :: Object -> [Object] -collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj) - -collectStoredObjects :: Stored Object -> [Stored Object] -collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj) - -collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest) -collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items - where helper (RecRef ref) (xs, s) | r <- refDigest ref - , r `S.notMember` s - = let o = wrappedLoad ref - (xs', s') = collectOtherStored (S.insert r s) $ fromStored o - in ((o : xs') ++ xs, s') - helper _ (xs, s) = (xs, s) -collectOtherStored seen _ = ([], seen) - - -type Head = Head' Complete - -headId :: Head a -> HeadID -headId (Head uuid _) = uuid - -headStorage :: Head a -> Storage -headStorage = refStorage . headRef - -headRef :: Head a -> Ref -headRef (Head _ sx) = storedRef sx - -headObject :: Head a -> a -headObject (Head _ sx) = fromStored sx - -headStoredObject :: Head a -> Stored a -headStoredObject (Head _ sx) = sx - -deriving instance StorableUUID HeadID -deriving instance StorableUUID HeadTypeID - -mkHeadTypeID :: String -> HeadTypeID -mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString - -class Storable a => HeadType a where - headTypeID :: proxy a -> HeadTypeID - - -headTypePath :: FilePath -> HeadTypeID -> FilePath -headTypePath spath (HeadTypeID tid) = spath "heads" U.toString tid - -headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath -headPath spath tid (HeadID hid) = headTypePath spath tid U.toString hid - -loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] -loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do - let hpath = headTypePath spath $ headTypeID @a Proxy - - files <- filterM (doesFileExist . (hpath )) =<< - handleJust (\e -> guard (isDoesNotExistError e)) (const $ return []) - (getDirectoryContents hpath) - fmap catMaybes $ forM files $ \hname -> do - case U.fromString hname of - Just hid -> do - (h:_) <- BC.lines <$> B.readFile (hpath hname) - Just ref <- readRef s h - return $ Just $ Head (HeadID hid) $ wrappedLoad ref - Nothing -> return Nothing -loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do - let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref - | otherwise = Nothing - catMaybes . map toHead <$> readMVar theads - -loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a)) -loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid - -loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref) -loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do - handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do - (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid) - Just ref <- readRef s h - return $ Just ref -loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do - lookup (tid, hid) <$> readMVar theads - -reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) -reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid - -storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) -storeHead st obj = do - let tid = headTypeID @a Proxy - stored <- wrappedStore st obj - hid <- storeHeadRaw st tid (storedRef stored) - return $ Head hid stored - -storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID -storeHeadRaw st tid ref = liftIO $ do - hid <- HeadID <$> U.nextRandom - case stBacking st of - StorageDir { dirPath = spath } -> do - Right () <- writeFileChecked (headPath spath tid hid) Nothing $ - showRef ref `B.append` BC.singleton '\n' - return () - StorageMemory { memHeads = theads } -> do - modifyMVar_ theads $ return . (((tid, hid), ref) :) - return hid - -replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a)) -replaceHead prev@(Head hid pobj) stored' = liftIO $ do - let st = headStorage prev - tid = headTypeID @a Proxy - stored <- copyStored st stored' - bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> - replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) - -replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref) -replaceHeadRaw st tid hid prev new = liftIO $ do - case stBacking st of - StorageDir { dirPath = spath } -> do - let filename = headPath spath tid hid - showRefL r = showRef r `B.append` BC.singleton '\n' - - writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case - Left Nothing -> return $ Left Nothing - Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs - return $ Left $ Just oref - Right () -> return $ Right new - - StorageMemory { memHeads = theads, memWatchers = twatch } -> do - res <- modifyMVar theads $ \hs -> do - ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch - return $ case partition ((==(tid, hid)) . fst) hs of - ([] , _ ) -> (hs, Left Nothing) - ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs', - Right (new, ws)) - | otherwise -> (hs, Left $ Just r) - case res of - Right (r, ws) -> mapM_ ($ r) ws >> return (Right r) - Left x -> return $ Left x - -updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b) -updateHead h f = do - (o, x) <- f $ headStoredObject h - replaceHead h o >>= \case - Right h' -> return (Just h', x) - Left Nothing -> return (Nothing, x) - Left (Just h') -> updateHead h' f - -updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a)) -updateHead_ h = fmap fst . updateHead h . (fmap (,()) .) - - -data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a) - -watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead -watchHead h = watchHeadWith h id - -watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead -watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do - watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb - -watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead -watchHeadRaw st tid hid sel cb = do - memo <- newEmptyMVar - let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) - where wl' = wl { wlNext = wlNext wl + 1 - , wlList = WatchListItem - { wlID = wlNext wl - , wlHead = (tid, hid) - , wlFun = \r -> do - let x = sel r - modifyMVar_ memo $ \prev -> do - when (Just x /= prev) $ cb x - return $ Just x - } : wlList wl - } - - watched <- case stBacking st of - StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do - manager <- maybe startManager return mbmanager - ilist' <- case tid `elem` ilist of - True -> return ilist - False -> do - void $ watchDir manager (headTypePath spath tid) (const True) $ \case - Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do - loadHeadRaw st tid ihid >>= \case - Just ref -> do - (_, _, iwl) <- readMVar mvar - mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl - Nothing -> return () - _ -> return () - return $ tid : ilist - return $ first ( Just manager, ilist', ) $ addWatcher wl - - StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher - - cur <- fmap sel <$> loadHeadRaw st tid hid - maybe (return ()) cb cur - putMVar memo cur - - return watched - -unwatchHead :: WatchedHead -> IO () -unwatchHead (WatchedHead st wid _) = do - let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl } - case stBacking st of - StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher - StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher - - -class Monad m => MonadStorage m where - getStorage :: m Storage - mstore :: Storable a => a -> m (Stored a) - - default mstore :: MonadIO m => Storable a => a -> m (Stored a) - mstore x = do - st <- getStorage - wrappedStore st x - -instance MonadIO m => MonadStorage (ReaderT Storage m) where - getStorage = ask - -instance MonadIO m => MonadStorage (ReaderT (Head a) m) where - getStorage = asks $ headStorage - - -class Storable a where - store' :: a -> Store - load' :: Load a - - store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c) - store st = evalStore st . store' - load :: Ref -> a - load = evalLoad load' - -class Storable a => ZeroStorable a where - fromZero :: Storage -> a - -data Store = StoreBlob ByteString - | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]]) - | StoreZero - | StoreUnknown ByteString ByteString - -evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c) -evalStore st = unsafeStoreObject st <=< evalStoreObject st - -evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c) -evalStoreObject _ (StoreBlob x) = return $ Blob x -evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s) -evalStoreObject _ StoreZero = return ZeroObject -evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content - -newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a) - deriving (Functor, Applicative, Monad) - -type StoreRec c = StoreRecM c () - -newtype Load a = Load (ReaderT (Ref, Object) (Except String) a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) - -evalLoad :: Load a -> Ref -> a -evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref) - -loadCurrentRef :: Load Ref -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) - -loadRecCurrentRef :: LoadRec Ref -loadRecCurrentRef = LoadRec $ asks fst - -loadRecItems :: LoadRec [(ByteString, RecItem)] -loadRecItems = LoadRec $ asks snd - - -instance Storable Object where - store' (Blob bs) = StoreBlob bs - store' (Rec xs) = StoreRec $ \st -> return $ do - Rec xs' <- copyObject st (Rec xs) - return xs' - store' ZeroObject = StoreZero - store' (UnknownObject otype content) = StoreUnknown otype content - - load' = loadCurrentObject - - store st = unsafeStoreObject st <=< copyObject st - load = lazyLoadObject - -instance Storable ByteString where - store' = storeBlob - load' = loadBlob id - -instance Storable a => Storable [a] where - store' [] = storeZero - store' (x:xs) = storeRec $ do - storeRef "i" x - storeRef "n" xs - - load' = loadCurrentObject >>= \case - ZeroObject -> return [] - _ -> loadRec $ (:) - <$> loadRef "i" - <*> loadRef "n" - -instance Storable a => ZeroStorable [a] where - fromZero _ = [] - - -storeBlob :: ByteString -> Store -storeBlob = StoreBlob - -storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store -storeRec sr = StoreRec $ do - let StoreRecM r = sr - execWriter . runReaderT r - -storeZero :: Store -storeZero = StoreZero - - -class StorableText a where - toText :: a -> Text - fromText :: MonadError String m => Text -> m a - -instance StorableText Text where - toText = id; fromText = return - -instance StorableText [Char] where - toText = T.pack; fromText = return . T.unpack - - -class StorableDate a where - toDate :: a -> ZonedTime - fromDate :: ZonedTime -> a - -instance StorableDate ZonedTime where - toDate = id; fromDate = id - -instance StorableDate UTCTime where - toDate = utcToZonedTime utc - fromDate = zonedTimeToUTC - -instance StorableDate Day where - toDate day = toDate $ UTCTime day 0 - fromDate = utctDay . fromDate - - -class StorableUUID a where - toUUID :: a -> UUID - fromUUID :: UUID -> a - -instance StorableUUID UUID where - toUUID = id; fromUUID = id - - -storeEmpty :: String -> StoreRec c -storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]] - -storeMbEmpty :: String -> Maybe () -> StoreRec c -storeMbEmpty name = maybe (return ()) (const $ storeEmpty name) - -storeInt :: Integral a => String -> a -> StoreRec c -storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]] - -storeMbInt :: Integral a => String -> Maybe a -> StoreRec c -storeMbInt name = maybe (return ()) (storeInt name) - -storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c -storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]] - -storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c -storeMbNum name = maybe (return ()) (storeNum name) - -storeText :: StorableText a => String -> a -> StoreRec c -storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]] - -storeMbText :: StorableText a => String -> Maybe a -> StoreRec c -storeMbText name = maybe (return ()) (storeText name) - -storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c -storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]] - -storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c -storeMbBinary name = maybe (return ()) (storeBinary name) - -storeDate :: StorableDate a => String -> a -> StoreRec c -storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]] - -storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c -storeMbDate name = maybe (return ()) (storeDate name) - -storeUUID :: StorableUUID a => String -> a -> StoreRec c -storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]] - -storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c -storeMbUUID name = maybe (return ()) (storeUUID name) - -storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c -storeRef name x = StoreRecM $ do - s <- ask - tell $ (:[]) $ do - ref <- store s x - return [(BC.pack name, RecRef ref)] - -storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c -storeMbRef name = maybe (return ()) (storeRef name) - -storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c -storeRawRef name ref = StoreRecM $ do - st <- ask - tell $ (:[]) $ do - ref' <- copyRef st ref - return [(BC.pack name, RecRef ref')] - -storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c -storeMbRawRef name = maybe (return ()) (storeRawRef name) - -storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c -storeZRef name x = StoreRecM $ do - s <- ask - tell $ (:[]) $ do - ref <- store s x - return $ if isZeroRef ref then [] - else [(BC.pack name, RecRef ref)] - -storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c -storeRecItems items = StoreRecM $ do - st <- ask - tell $ flip map items $ \( name, value ) -> do - value' <- copyRecItem st value - return [ ( name, value' ) ] - -loadBlob :: (ByteString -> a) -> Load a -loadBlob f = loadCurrentObject >>= \case - Blob x -> return $ f x - _ -> throwError "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" - -loadZero :: a -> Load a -loadZero x = loadCurrentObject >>= \case - ZeroObject -> return x - _ -> throwError "Expecting zero" - - -loadEmpty :: String -> LoadRec () -loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name - -loadMbEmpty :: String -> LoadRec (Maybe ()) -loadMbEmpty name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecEmpty) -> return (Just ()) - Just _ -> throwError $ "Expecting type int of record item '"++name++"'" - -loadInt :: Num a => String -> LoadRec a -loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name - -loadMbInt :: Num a => String -> LoadRec (Maybe a) -loadMbInt name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecInt x) -> return (Just $ fromInteger x) - Just _ -> throwError $ "Expecting type int of record item '"++name++"'" - -loadNum :: (Real a, Fractional a) => String -> LoadRec a -loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name - -loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a) -loadMbNum name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecNum x) -> return (Just $ fromRational x) - Just _ -> throwError $ "Expecting type number of record item '"++name++"'" - -loadText :: StorableText a => String -> LoadRec a -loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name - -loadMbText :: StorableText a => String -> LoadRec (Maybe a) -loadMbText name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecText x) -> Just <$> fromText x - Just _ -> throwError $ "Expecting type text of record item '"++name++"'" - -loadTexts :: StorableText a => String -> LoadRec [a] -loadTexts name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecText x -> fromText x - _ -> throwError $ "Expecting type text of record item '"++name++"'" - -loadBinary :: BA.ByteArray a => String -> LoadRec a -loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name - -loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) -loadMbBinary name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecBinary x) -> return $ Just $ BA.convert x - Just _ -> throwError $ "Expecting type binary of record item '"++name++"'" - -loadBinaries :: BA.ByteArray a => String -> LoadRec [a] -loadBinaries name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecBinary x -> return $ BA.convert x - _ -> throwError $ "Expecting type binary of record item '"++name++"'" - -loadDate :: StorableDate a => String -> LoadRec a -loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name - -loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) -loadMbDate name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecDate x) -> return $ Just $ fromDate x - Just _ -> throwError $ "Expecting type date of record item '"++name++"'" - -loadUUID :: StorableUUID a => String -> LoadRec a -loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name - -loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) -loadMbUUID name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecUUID x) -> return $ Just $ fromUUID x - Just _ -> throwError $ "Expecting type UUID of record item '"++name++"'" - -loadRawRef :: String -> LoadRec Ref -loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name - -loadMbRawRef :: String -> LoadRec (Maybe Ref) -loadMbRawRef name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecRef x) -> return (Just x) - Just _ -> throwError $ "Expecting type ref of record item '"++name++"'" - -loadRawRefs :: String -> LoadRec [Ref] -loadRawRefs name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecRef x -> return x - _ -> throwError $ "Expecting type ref of record item '"++name++"'" - -loadRef :: Storable a => String -> LoadRec a -loadRef name = load <$> loadRawRef name - -loadMbRef :: Storable a => String -> LoadRec (Maybe a) -loadMbRef name = fmap load <$> loadMbRawRef name - -loadRefs :: Storable a => String -> LoadRec [a] -loadRefs name = map load <$> loadRawRefs name - -loadZRef :: ZeroStorable a => String -> LoadRec a -loadZRef name = loadMbRef name >>= \case - Nothing -> do Ref st _ <- loadRecCurrentRef - return $ fromZero st - Just x -> return x - - -type Stored a = Stored' Complete a - -instance Storable a => Storable (Stored a) where - store st = copyRef st . storedRef - store' (Stored _ x) = store' x - load' = Stored <$> loadCurrentRef <*> load' - -instance ZeroStorable a => ZeroStorable (Stored a) where - fromZero st = Stored (zeroRef st) $ fromZero st - -fromStored :: Stored a -> a -fromStored (Stored _ x) = x - -storedRef :: Stored a -> Ref -storedRef (Stored ref _) = ref - -wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a) -wrappedStore st x = do ref <- liftIO $ store st x - return $ Stored ref x - -wrappedLoad :: Storable a => Ref -> Stored a -wrappedLoad ref = Stored ref (load ref) - -copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => - Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a)) -copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref' - --- |Passed function needs to preserve the object representation to be safe -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 - Just (n', d) -> let n = abs n' - in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." ++ - (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d))) - Nothing -> show (numerator r) ++ "/" ++ show (denominator r) - -decimalRatio :: Rational -> Maybe (Integer, Integer) -decimalRatio r = do - let n = numerator r - d = denominator r - (c2, d') = takeFactors 2 d - (c5, d'') = takeFactors 5 d' - guard $ d'' == 1 - let m = if c2 > c5 then 5 ^ (c2 - c5) - else 2 ^ (c5 - c2) - return (n * m, d * m) - -takeFactors :: Integer -> Integer -> (Integer, Integer) -takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f) - in (c+1, n') - | otherwise = (0, n) - -parseRatio :: ByteString -> Maybe Rational -parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of - (m:xs) | m == BC.pack "-" -> negate <$> positive xs - xs -> positive xs - where positive = \case - [bx] -> fromInteger . fst <$> BC.readInteger bx - [bx, op, by] -> do - (x, _) <- BC.readInteger bx - (y, _) <- BC.readInteger by - case BC.unpack op of - "." -> return $ (x % 1) + (y % (10 ^ BC.length by)) - "/" -> return $ x % y - _ -> Nothing - _ -> Nothing diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs index 5da79e3..9e52397 100644 --- a/src/Erebos/Storage/Key.hs +++ b/src/Erebos/Storage/Key.hs @@ -18,7 +18,7 @@ import System.Directory import System.FilePath import System.IO.Error -import Erebos.Storage +import Erebos.Object.Internal import Erebos.Storage.Internal class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs index a3b0fd7..d5d184e 100644 --- a/src/Erebos/Storage/Merge.hs +++ b/src/Erebos/Storage/Merge.hs @@ -31,7 +31,7 @@ import Data.Set qualified as S import System.IO.Unsafe (unsafePerformIO) -import Erebos.Storage +import Erebos.Object.Internal import Erebos.Storage.Internal import Erebos.Util diff --git a/src/Erebos/Sync.hs b/src/Erebos/Sync.hs index 04b5f11..71122f7 100644 --- a/src/Erebos/Sync.hs +++ b/src/Erebos/Sync.hs @@ -8,9 +8,9 @@ import Control.Monad.Reader import Data.List import Erebos.Identity +import Erebos.Object.Internal import Erebos.Service import Erebos.State -import Erebos.Storage import Erebos.Storage.Merge data SyncService = SyncPacket (Stored SharedState) -- cgit v1.2.3