summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Erebos/Attach.hs2
-rw-r--r--src/Erebos/Chatroom.hs3
-rw-r--r--src/Erebos/Contact.hs2
-rw-r--r--src/Erebos/Conversation.hs6
-rw-r--r--src/Erebos/DirectMessage.hs (renamed from src/Erebos/Message.hs)10
-rw-r--r--src/Erebos/Discovery.hs3
-rw-r--r--src/Erebos/ICE.chs2
-rw-r--r--src/Erebos/Identity.hs2
-rw-r--r--src/Erebos/Network.hs3
-rw-r--r--src/Erebos/Network.hs-boot2
-rw-r--r--src/Erebos/Network/Channel.hs (renamed from src/Erebos/Channel.hs)4
-rw-r--r--src/Erebos/Network/Protocol.hs4
-rw-r--r--src/Erebos/Object.hs22
-rw-r--r--src/Erebos/Object/Internal.hs812
-rw-r--r--src/Erebos/Pairing.hs3
-rw-r--r--src/Erebos/PubKey.hs2
-rw-r--r--src/Erebos/Service.hs3
-rw-r--r--src/Erebos/Set.hs3
-rw-r--r--src/Erebos/State.hs4
-rw-r--r--src/Erebos/Storable.hs41
-rw-r--r--src/Erebos/Storage.hs1084
-rw-r--r--src/Erebos/Storage/Head.hs348
-rw-r--r--src/Erebos/Storage/Internal.hs5
-rw-r--r--src/Erebos/Storage/Key.hs2
-rw-r--r--src/Erebos/Storage/Merge.hs3
-rw-r--r--src/Erebos/Sync.hs2
26 files changed, 1274 insertions, 1103 deletions
diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs
index bd2f521..aac7297 100644
--- a/src/Erebos/Attach.hs
+++ b/src/Erebos/Attach.hs
@@ -20,7 +20,7 @@ import Erebos.Pairing
import Erebos.PubKey
import Erebos.Service
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
import Erebos.Storage.Key
type AttachService = PairingService AttachIdentity
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index 8833450..814e1af 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -53,7 +53,8 @@ import Erebos.PubKey
import Erebos.Service
import Erebos.Set
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
+import Erebos.Storage.Head
import Erebos.Storage.Merge
import Erebos.Util
diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs
index d90aa50..0e92e41 100644
--- a/src/Erebos/Contact.hs
+++ b/src/Erebos/Contact.hs
@@ -28,7 +28,7 @@ import Erebos.PubKey
import Erebos.Service
import Erebos.Set
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
import Erebos.Storage.Merge
data Contact = Contact
diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs
index 63475bd..fce8780 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.Message hiding (formatMessage)
+import Erebos.DirectMessage
+import Erebos.Identity
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
data Message = DirectMessageMessage DirectMessage Bool
diff --git a/src/Erebos/Message.hs b/src/Erebos/DirectMessage.hs
index 5ef27f3..39d453c 100644
--- a/src/Erebos/Message.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -1,4 +1,4 @@
-module Erebos.Message (
+module Erebos.DirectMessage (
DirectMessage(..),
sendDirectMessage,
@@ -13,7 +13,6 @@ module Erebos.Message (
messageThreadView,
watchReceivedMessages,
- formatMessage,
formatDirectMessage,
) where
@@ -33,7 +32,8 @@ import Erebos.Identity
import Erebos.Network
import Erebos.Service
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
+import Erebos.Storage.Head
import Erebos.Storage.Merge
data DirectMessage = DirectMessage
@@ -259,10 +259,6 @@ watchReceivedMessages h f = do
forM_ (map fromStored sms) $ \ms -> do
mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms
-{-# DEPRECATED formatMessage "use formatDirectMessage instead" #-}
-formatMessage :: TimeZone -> DirectMessage -> String
-formatMessage = formatDirectMessage
-
formatDirectMessage :: TimeZone -> DirectMessage -> String
formatDirectMessage tzone msg = concat
[ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
index 48df9c3..459af71 100644
--- a/src/Erebos/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -19,8 +19,9 @@ import Network.Socket
import Erebos.ICE
import Erebos.Identity
import Erebos.Network
+import Erebos.Object
import Erebos.Service
-import Erebos.Storage
+import Erebos.Storable
keepaliveSeconds :: Int
diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs
index 096ee0d..2d3177d 100644
--- a/src/Erebos/ICE.chs
+++ b/src/Erebos/ICE.chs
@@ -40,6 +40,8 @@ import Foreign.Ptr
import Foreign.StablePtr
import Erebos.Flow
+import Erebos.Object
+import Erebos.Storable
import Erebos.Storage
#include "pjproject.h"
diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs
index 577e5ac..e75999d 100644
--- a/src/Erebos/Identity.hs
+++ b/src/Erebos/Identity.hs
@@ -41,7 +41,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Erebos.PubKey
-import Erebos.Storage
+import Erebos.Storable
import Erebos.Storage.Merge
import Erebos.Util
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 2064d1c..364597f 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -57,12 +57,13 @@ import qualified Network.Socket.ByteString as S
import Foreign.C.Types
import Foreign.Marshal.Alloc
-import Erebos.Channel
#ifdef ENABLE_ICE_SUPPORT
import Erebos.ICE
#endif
import Erebos.Identity
+import Erebos.Network.Channel
import Erebos.Network.Protocol
+import Erebos.Object.Internal
import Erebos.PubKey
import Erebos.Service
import Erebos.State
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/Channel.hs b/src/Erebos/Network/Channel.hs
index 5f66637..17e1a37 100644
--- a/src/Erebos/Channel.hs
+++ b/src/Erebos/Network/Channel.hs
@@ -1,4 +1,4 @@
-module Erebos.Channel (
+module Erebos.Network.Channel (
Channel,
ChannelRequest, ChannelRequestData(..),
ChannelAccept, ChannelAcceptData(..),
@@ -27,7 +27,7 @@ import Data.List
import Erebos.Identity
import Erebos.PubKey
-import Erebos.Storage
+import Erebos.Storable
data Channel = Channel
{ chPeers :: [Stored (Signed IdentityData)]
diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index cfbaea3..c657759 100644
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -64,10 +64,12 @@ import Data.Void
import System.Clock
-import Erebos.Channel
import Erebos.Flow
import Erebos.Identity
+import Erebos.Network.Channel
+import Erebos.Object
import Erebos.Service
+import Erebos.Storable
import Erebos.Storage
diff --git a/src/Erebos/Object.hs b/src/Erebos/Object.hs
new file mode 100644
index 0000000..26ca09f
--- /dev/null
+++ b/src/Erebos/Object.hs
@@ -0,0 +1,22 @@
+{-|
+Description: Core Erebos objects and references
+
+Data types and functions for working with "raw" Erebos objects and references.
+-}
+
+module Erebos.Object (
+ Object, PartialObject, Object'(..),
+ serializeObject, deserializeObject, deserializeObjects,
+ ioLoadObject, ioLoadBytes,
+ storeRawBytes, lazyLoadBytes,
+
+ RecItem, RecItem'(..),
+
+ Ref, PartialRef, RefDigest,
+ refDigest,
+ readRef, showRef, showRefDigest,
+ refDigestFromByteString, hashToRefDigest,
+ copyRef, partialRef, partialRefFromDigest,
+) where
+
+import Erebos.Object.Internal
diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs
new file mode 100644
index 0000000..f08e734
--- /dev/null
+++ b/src/Erebos/Object/Internal.hs
@@ -0,0 +1,812 @@
+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,
+
+ 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,
+) 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 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.UUID (UUID)
+import qualified Data.UUID as U
+
+import System.Directory
+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)
+
+
+deriving instance StorableUUID HeadID
+deriving instance StorableUUID HeadTypeID
+
+
+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
+
+
+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 = listToMaybe . mapMaybe p <$> loadRecItems
+ where
+ bname = BC.pack name
+ p ( name', RecEmpty ) | name' == bname
+ = Just ()
+ p _ = Nothing
+
+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 = listToMaybe . mapMaybe p <$> loadRecItems
+ where
+ bname = BC.pack name
+ p ( name', RecInt x ) | name' == bname
+ = Just (fromInteger x)
+ p _ = Nothing
+
+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 = listToMaybe . mapMaybe p <$> loadRecItems
+ where
+ bname = BC.pack name
+ p ( name', RecNum x ) | name' == bname
+ = Just (fromRational x)
+ p _ = Nothing
+
+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 = listToMaybe <$> loadTexts name
+
+loadTexts :: StorableText a => String -> LoadRec [a]
+loadTexts name = sequence . mapMaybe p =<< loadRecItems
+ where
+ bname = BC.pack name
+ p ( name', RecText x ) | name' == bname
+ = Just (fromText x)
+ p _ = Nothing
+
+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 = listToMaybe <$> loadBinaries name
+
+loadBinaries :: BA.ByteArray a => String -> LoadRec [a]
+loadBinaries name = mapMaybe p <$> loadRecItems
+ where
+ bname = BC.pack name
+ p ( name', RecBinary x ) | name' == bname
+ = Just (BA.convert x)
+ p _ = Nothing
+
+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 = listToMaybe . mapMaybe p <$> loadRecItems
+ where
+ bname = BC.pack name
+ p ( name', RecDate x ) | name' == bname
+ = Just (fromDate x)
+ p _ = Nothing
+
+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 = listToMaybe . mapMaybe p <$> loadRecItems
+ where
+ bname = BC.pack name
+ p ( name', RecUUID x ) | name' == bname
+ = Just (fromUUID x)
+ p _ = Nothing
+
+loadRawRef :: String -> LoadRec Ref
+loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name
+
+loadMbRawRef :: String -> LoadRec (Maybe Ref)
+loadMbRawRef name = listToMaybe <$> loadRawRefs name
+
+loadRawRefs :: String -> LoadRec [Ref]
+loadRawRefs name = mapMaybe p <$> loadRecItems
+ where
+ bname = BC.pack name
+ p ( name', RecRef x ) | name' == bname = Just x
+ p _ = Nothing
+
+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)
+
+
+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..da6a9b4 100644
--- a/src/Erebos/Pairing.hs
+++ b/src/Erebos/Pairing.hs
@@ -27,10 +27,11 @@ import Data.Word
import Erebos.Identity
import Erebos.Network
+import Erebos.Object
import Erebos.PubKey
import Erebos.Service
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
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..bea208b 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.Storable
import Erebos.Storage.Key
data PublicKey = PublicKey ED.PublicKey
diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs
index f8428d1..f640feb 100644
--- a/src/Erebos/Service.hs
+++ b/src/Erebos/Service.hs
@@ -35,7 +35,8 @@ import qualified Data.UUID as U
import Erebos.Identity
import {-# SOURCE #-} Erebos.Network
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
+import Erebos.Storage.Head
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..270c0ba 100644
--- a/src/Erebos/Set.hs
+++ b/src/Erebos/Set.hs
@@ -19,7 +19,8 @@ import Data.Map qualified as M
import Data.Maybe
import Data.Ord
-import Erebos.Storage
+import Erebos.Object
+import Erebos.Storable
import Erebos.Storage.Merge
import Erebos.Util
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs
index 3012064..79f17b7 100644
--- a/src/Erebos/State.hs
+++ b/src/Erebos/State.hs
@@ -35,8 +35,10 @@ import Data.UUID qualified as U
import System.IO
import Erebos.Identity
+import Erebos.Object
import Erebos.PubKey
-import Erebos.Storage
+import Erebos.Storable
+import Erebos.Storage.Head
import Erebos.Storage.Merge
data LocalState = LocalState
diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs
new file mode 100644
index 0000000..ee389ce
--- /dev/null
+++ b/src/Erebos/Storable.hs
@@ -0,0 +1,41 @@
+{-|
+Description: Encoding custom types into Erebos objects
+
+Module provides the 'Storable' class for types that can be serialized to/from
+Erebos objects, along with various helpers, mostly for encoding using records.
+
+The 'Stored' wrapper for objects actually encoded and stored in some storage is
+defined here as well.
+-}
+
+module Erebos.Storable (
+ Storable(..), ZeroStorable(..),
+ StorableText(..), StorableDate(..), StorableUUID(..),
+
+ Store, StoreRec,
+ 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,
+ 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,
+
+ Storage, MonadStorage(..),
+) where
+
+import Erebos.Object.Internal
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs
index 61bb2fa..4344b75 100644
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -1,1087 +1,27 @@
+{-|
+Description: Working with storage and heads
+
+Provides functions for opening 'Storage' backed either by disk or memory. For
+conveniance also function for working with 'Head's are reexported here.
+-}
+
module Erebos.Storage (
- Storage, PartialStorage, StorageCompleteness,
+ Storage, PartialStorage,
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,
+ Head, HeadType,
+ HeadID, HeadTypeID,
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 = listToMaybe . mapMaybe p <$> loadRecItems
- where
- bname = BC.pack name
- p ( name', RecEmpty ) | name' == bname
- = Just ()
- p _ = Nothing
-
-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 = listToMaybe . mapMaybe p <$> loadRecItems
- where
- bname = BC.pack name
- p ( name', RecInt x ) | name' == bname
- = Just (fromInteger x)
- p _ = Nothing
-
-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 = listToMaybe . mapMaybe p <$> loadRecItems
- where
- bname = BC.pack name
- p ( name', RecNum x ) | name' == bname
- = Just (fromRational x)
- p _ = Nothing
-
-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 = listToMaybe <$> loadTexts name
-
-loadTexts :: StorableText a => String -> LoadRec [a]
-loadTexts name = sequence . mapMaybe p =<< loadRecItems
- where
- bname = BC.pack name
- p ( name', RecText x ) | name' == bname
- = Just (fromText x)
- p _ = Nothing
-
-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 = listToMaybe <$> loadBinaries name
-
-loadBinaries :: BA.ByteArray a => String -> LoadRec [a]
-loadBinaries name = mapMaybe p <$> loadRecItems
- where
- bname = BC.pack name
- p ( name', RecBinary x ) | name' == bname
- = Just (BA.convert x)
- p _ = Nothing
-
-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 = listToMaybe . mapMaybe p <$> loadRecItems
- where
- bname = BC.pack name
- p ( name', RecDate x ) | name' == bname
- = Just (fromDate x)
- p _ = Nothing
-
-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 = listToMaybe . mapMaybe p <$> loadRecItems
- where
- bname = BC.pack name
- p ( name', RecUUID x ) | name' == bname
- = Just (fromUUID x)
- p _ = Nothing
-
-loadRawRef :: String -> LoadRec Ref
-loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name
-
-loadMbRawRef :: String -> LoadRec (Maybe Ref)
-loadMbRawRef name = listToMaybe <$> loadRawRefs name
-
-loadRawRefs :: String -> LoadRec [Ref]
-loadRawRefs name = mapMaybe p <$> loadRecItems
- where
- bname = BC.pack name
- p ( name', RecRef x ) | name' == bname = Just x
- p _ = Nothing
-
-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
+import Erebos.Object.Internal
+import Erebos.Storage.Head
diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs
new file mode 100644
index 0000000..dc8b7bc
--- /dev/null
+++ b/src/Erebos/Storage/Head.hs
@@ -0,0 +1,348 @@
+{-|
+Description: Define, use and watch heads
+
+Provides data types and functions for reading, writing or watching `Head's.
+Type class `HeadType' is used to define custom new `Head' types.
+-}
+
+module Erebos.Storage.Head (
+ -- * Head type and accessors
+ Head, HeadType(..),
+ HeadID, HeadTypeID, mkHeadTypeID,
+ headId, headStorage, headRef, headObject, headStoredObject,
+
+ -- * Loading and storing heads
+ loadHeads, loadHead, reloadHead,
+ storeHead, replaceHead, updateHead, updateHead_,
+ loadHeadRaw, storeHeadRaw, replaceHeadRaw,
+
+ -- * Watching heads
+ WatchedHead,
+ watchHead, watchHeadWith, unwatchHead,
+ watchHeadRaw,
+) where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+
+import Data.Bifunctor
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.List
+import Data.Maybe
+import Data.Typeable
+import Data.UUID qualified as U
+import Data.UUID.V4 qualified as U
+
+import System.Directory
+import System.FSNotify
+import System.FilePath
+import System.IO.Error
+
+import Erebos.Object
+import Erebos.Storable
+import Erebos.Storage.Internal
+
+
+-- | Represents loaded Erebos storage head, along with the object it pointed to
+-- at the time it was loaded.
+--
+-- Each possible head type has associated unique ID, represented as
+-- `HeadTypeID'. For each type, there can be multiple individual heads in given
+-- storage, each also identified by unique ID (`HeadID').
+data Head a = Head HeadID (Stored a)
+ deriving (Eq, Show)
+
+-- | Instances of this class can be used as objects pointed to by heads in
+-- Erebos storage. Each such type must be `Storable' and have a unique ID.
+--
+-- To create a custom head type, generate a new UUID and assign it to the type using
+-- `mkHeadTypeID':
+--
+-- > instance HeadType MyType where
+-- > headTypeID _ = mkHeadTypeID "86e8033d-c476-4f81-9b7c-fd36b9144475"
+class Storable a => HeadType a where
+ headTypeID :: proxy a -> HeadTypeID
+ -- ^ Get the ID of the given head type; must be unique for each `HeadType' instance.
+
+instance MonadIO m => MonadStorage (ReaderT (Head a) m) where
+ getStorage = asks $ headStorage
+
+
+-- | Get `HeadID' associated with given `Head'.
+headId :: Head a -> HeadID
+headId (Head uuid _) = uuid
+
+-- | Get storage from which the `Head' was loaded.
+headStorage :: Head a -> Storage
+headStorage = refStorage . headRef
+
+-- | Get `Ref' of the `Head'\'s associated object.
+headRef :: Head a -> Ref
+headRef (Head _ sx) = storedRef sx
+
+-- | Get the object the `Head' pointed to when it was loaded.
+headObject :: Head a -> a
+headObject (Head _ sx) = fromStored sx
+
+-- | Get the object the `Head' pointed to when it was loaded as a `Stored' value.
+headStoredObject :: Head a -> Stored a
+headStoredObject (Head _ sx) = sx
+
+-- | Create `HeadTypeID' from string representation of UUID.
+mkHeadTypeID :: String -> HeadTypeID
+mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString
+
+
+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
+
+-- | Load all `Head's of type @a@ from storage.
+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
+
+-- | Try to load a `Head' of type @a@ from storage.
+loadHead
+ :: forall a m. (HeadType a, MonadIO m)
+ => Storage -- ^ Storage from which to load the head
+ -> HeadID -- ^ ID of the particular head
+ -> m (Maybe (Head a)) -- ^ Head object, or `Nothing' if not found
+loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid
+
+-- | Try to load `Head' using a raw head and type IDs, getting `Ref' if found.
+loadHeadRaw
+ :: forall m. MonadIO m
+ => Storage -- ^ Storage from which to load the head
+ -> HeadTypeID -- ^ ID of the head type
+ -> HeadID -- ^ ID of the particular head
+ -> m (Maybe Ref) -- ^ `Ref' pointing to the head object, or `Nothing' if not found
+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
+
+-- | Reload the given head from storage, returning `Head' with updated object,
+-- or `Nothing' if there is no longer head with the particular ID in storage.
+reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a))
+reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid
+
+-- | Store a new `Head' of type 'a' in the storage.
+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
+
+-- | Store a new `Head' in the storage, using the raw `HeadTypeID' and `Ref',
+-- the function returns the assigned `HeadID' of the new head.
+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
+
+-- | Try to replace existing `Head' of type @a@ in the storage. Function fails
+-- if the head value in storage changed after being loaded here; for automatic
+-- retry see `updateHead'.
+replaceHead
+ :: forall a m. (HeadType a, MonadIO m)
+ => Head a -- ^ Existing head, associated object is supposed to match the one in storage
+ -> Stored a -- ^ Intended new value
+ -> m (Either (Maybe (Head a)) (Head a))
+ -- ^
+ -- [@`Left' `Nothing'@]:
+ -- Nothing was stored – the head no longer exists in storage.
+ -- [@`Left' (`Just' h)@]:
+ -- Nothing was stored – the head value in storage does not match
+ -- the first parameter, but is @h@ instead.
+ -- [@`Right' h@]:
+ -- Head value was updated in storage, the new head is @h@ (which is
+ -- the same as first parameter with associated object replaced by
+ -- the second parameter).
+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)
+
+-- | Try to replace existing head using raw IDs and `Ref's.
+replaceHeadRaw
+ :: forall m. MonadIO m
+ => Storage -- ^ Storage to use
+ -> HeadTypeID -- ^ ID of the head type
+ -> HeadID -- ^ ID of the particular head
+ -> Ref -- ^ Expected value in storage
+ -> Ref -- ^ Intended new value
+ -> m (Either (Maybe Ref) Ref)
+ -- ^
+ -- [@`Left' `Nothing'@]:
+ -- Nothing was stored – the head no longer exists in storage.
+ -- [@`Left' (`Just' r)@]:
+ -- Nothing was stored – the head value in storage does not match
+ -- the expected value, but is @r@ instead.
+ -- [@`Right' r@]:
+ -- Head value was updated in storage, the new head value is @r@
+ -- (which is the same as the indended value).
+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
+
+-- | Update existing existing `Head' of type @a@ in the storage, using a given
+-- function. The update function may be called multiple times in case the head
+-- content changes concurrently during evaluation.
+updateHead
+ :: (HeadType a, MonadIO m)
+ => Head a -- ^ Existing head to be updated
+ -> (Stored a -> m ( Stored a, b ))
+ -- ^ Function that gets current value of the head and returns updated
+ -- value, along with a custom extra value to be returned from
+ -- `updateHead' call. The function may be called multiple times.
+ -> m ( Maybe (Head a), b )
+ -- ^ First element contains either the new head as @`Just' h@, or
+ -- `Nothing' in case the head no longer exists in storage. Second
+ -- element is the value from last call to the update function.
+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
+
+-- | Update existing existing `Head' of type @a@ in the storage, using a given
+-- function. The update function may be called multiple times in case the head
+-- content changes concurrently during evaluation.
+updateHead_
+ :: (HeadType a, MonadIO m)
+ => Head a -- ^ Existing head to be updated
+ -> (Stored a -> m (Stored a))
+ -- ^ Function that gets current value of the head and returns updated
+ -- value; may be called multiple times.
+ -> m (Maybe (Head a))
+ -- ^ The new head as @`Just' h@, or `Nothing' in case the head no
+ -- longer exists in storage.
+updateHead_ h = fmap fst . updateHead h . (fmap (,()) .)
+
+
+-- | Represents a handle of a watched head, which can be used to cancel the
+-- watching.
+data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a)
+
+-- | Watch the given head. The callback will be called with the current head
+-- value, and then again each time the head changes.
+watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead
+watchHead h = watchHeadWith h id
+
+-- | Watch the given head using custom selector function. The callback will be
+-- called with the value derived from current head state, and then again each
+-- time the selected value changes according to its `Eq' instance.
+watchHeadWith
+ :: forall a b. (HeadType a, Eq b)
+ => Head a -- ^ Head to watch
+ -> (Head a -> b) -- ^ Selector function
+ -> (b -> IO ()) -- ^ Callback
+ -> IO WatchedHead -- ^ Watched head handle
+watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do
+ watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb
+
+-- | Watch the given head using raw IDs and a selector from `Ref'.
+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
+
+-- | Stop watching previously watched head.
+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
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index 8b794d8..3e8d8b6 100644
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -159,12 +159,11 @@ readHex = return . BA.concat <=< readHex'
newtype Generation = Generation Int
deriving (Eq, Show)
-data Head' c a = Head HeadID (Stored' c a)
- deriving (Eq, Show)
-
+-- | UUID of individual Erebos storage head.
newtype HeadID = HeadID UUID
deriving (Eq, Ord, Show)
+-- | UUID of Erebos storage head type.
newtype HeadTypeID = HeadTypeID UUID
deriving (Eq, Ord)
diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs
index 5da79e3..626d684 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.Storable
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..41725af 100644
--- a/src/Erebos/Storage/Merge.hs
+++ b/src/Erebos/Storage/Merge.hs
@@ -31,7 +31,8 @@ import Data.Set qualified as S
import System.IO.Unsafe (unsafePerformIO)
-import Erebos.Storage
+import Erebos.Object
+import Erebos.Storable
import Erebos.Storage.Internal
import Erebos.Util
diff --git a/src/Erebos/Sync.hs b/src/Erebos/Sync.hs
index 04b5f11..32e2e22 100644
--- a/src/Erebos/Sync.hs
+++ b/src/Erebos/Sync.hs
@@ -10,7 +10,7 @@ import Data.List
import Erebos.Identity
import Erebos.Service
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
import Erebos.Storage.Merge
data SyncService = SyncPacket (Stored SharedState)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 05:23:32 +0000