summaryrefslogtreecommitdiff
path: root/src/Erebos
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos')
-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.hs4
-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.chs4
-rw-r--r--src/Erebos/Identity.hs2
-rw-r--r--src/Erebos/Network.hs3
-rw-r--r--src/Erebos/Network/Channel.hs (renamed from src/Erebos/Channel.hs)4
-rw-r--r--src/Erebos/Network/Protocol.hs6
-rw-r--r--src/Erebos/Object.hs22
-rw-r--r--src/Erebos/Object/Internal.hs275
-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.hs27
-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
25 files changed, 477 insertions, 306 deletions
diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs
index e0a240e..aac7297 100644
--- a/src/Erebos/Attach.hs
+++ b/src/Erebos/Attach.hs
@@ -16,11 +16,11 @@ import qualified Data.Text as T
import Erebos.Identity
import Erebos.Network
-import Erebos.Object.Internal
import Erebos.Pairing
import Erebos.PubKey
import Erebos.Service
import Erebos.State
+import Erebos.Storable
import Erebos.Storage.Key
type AttachService = PairingService AttachIdentity
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index 25c8c17..814e1af 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -49,11 +49,12 @@ import Data.Text (Text)
import Data.Time
import Erebos.Identity
-import Erebos.Object.Internal
import Erebos.PubKey
import Erebos.Service
import Erebos.Set
import Erebos.State
+import Erebos.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 0af434f..0e92e41 100644
--- a/src/Erebos/Contact.hs
+++ b/src/Erebos/Contact.hs
@@ -23,12 +23,12 @@ import qualified Data.Text as T
import Erebos.Identity
import Erebos.Network
-import Erebos.Object.Internal
import Erebos.Pairing
import Erebos.PubKey
import Erebos.Service
import Erebos.Set
import Erebos.State
+import Erebos.Storable
import Erebos.Storage.Merge
data Contact = Contact
diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs
index 4c68830..fce8780 100644
--- a/src/Erebos/Conversation.hs
+++ b/src/Erebos/Conversation.hs
@@ -30,10 +30,10 @@ import Data.Time.Format
import Data.Time.LocalTime
import Erebos.Chatroom
+import Erebos.DirectMessage
import Erebos.Identity
-import Erebos.Message hiding (formatMessage)
-import Erebos.Object.Internal
import Erebos.State
+import Erebos.Storable
data Message = DirectMessageMessage DirectMessage Bool
diff --git a/src/Erebos/Message.hs b/src/Erebos/DirectMessage.hs
index a558d1a..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
@@ -31,9 +30,10 @@ import Data.Time.LocalTime
import Erebos.Identity
import Erebos.Network
-import Erebos.Object.Internal
import Erebos.Service
import Erebos.State
+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 d89a7fa..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.Internal
+import Erebos.Object
import Erebos.Service
+import Erebos.Storable
keepaliveSeconds :: Int
diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs
index 787ce51..2d3177d 100644
--- a/src/Erebos/ICE.chs
+++ b/src/Erebos/ICE.chs
@@ -40,7 +40,9 @@ import Foreign.Ptr
import Foreign.StablePtr
import Erebos.Flow
-import Erebos.Object.Internal
+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 fdfacfc..e75999d 100644
--- a/src/Erebos/Identity.hs
+++ b/src/Erebos/Identity.hs
@@ -40,8 +40,8 @@ import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
-import Erebos.Object.Internal
import Erebos.PubKey
+import Erebos.Storable
import Erebos.Storage.Merge
import Erebos.Util
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 358bb7c..364597f 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -57,16 +57,17 @@ 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
+import Erebos.Storage
import Erebos.Storage.Key
import Erebos.Storage.Merge
diff --git a/src/Erebos/Channel.hs b/src/Erebos/Network/Channel.hs
index c17c9ab..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(..),
@@ -26,8 +26,8 @@ import Data.ByteString.Lazy qualified as BL
import Data.List
import Erebos.Identity
-import Erebos.Object.Internal
import Erebos.PubKey
+import Erebos.Storable
data Channel = Channel
{ chPeers :: [Stored (Signed IdentityData)]
diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index bceb355..c657759 100644
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -64,11 +64,13 @@ import Data.Void
import System.Clock
-import Erebos.Channel
import Erebos.Flow
import Erebos.Identity
-import Erebos.Object.Internal
+import Erebos.Network.Channel
+import Erebos.Object
import Erebos.Service
+import Erebos.Storable
+import Erebos.Storage
protocolVersion :: Text
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
index 312c3af..f08e734 100644
--- a/src/Erebos/Object/Internal.hs
+++ b/src/Erebos/Object/Internal.hs
@@ -16,17 +16,6 @@ module Erebos.Object.Internal (
storeObject,
collectObjects, collectStoredObjects,
- Head, HeadType(..),
- HeadTypeID, mkHeadTypeID,
- headId, headStorage, headRef, headObject, headStoredObject,
- loadHeads, loadHead, reloadHead,
- storeHead, replaceHead, updateHead, updateHead_,
- loadHeadRaw, storeHeadRaw, replaceHeadRaw,
-
- WatchedHead,
- watchHead, watchHeadWith, unwatchHead,
- watchHeadRaw,
-
MonadStorage(..),
Storable(..), ZeroStorable(..),
@@ -56,12 +45,6 @@ module Erebos.Object.Internal (
wrappedStore, wrappedLoad,
copyStored,
unsafeMapStored,
-
- StoreInfo(..), makeStoreInfo,
-
- StoredHistory,
- fromHistory, fromHistoryAt, storedFromHistory, storedHistoryList,
- beginHistory, modifyHistory,
) where
import Control.Applicative
@@ -84,7 +67,6 @@ 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
@@ -98,13 +80,10 @@ 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
@@ -404,194 +383,9 @@ collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items
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
@@ -605,9 +399,6 @@ class Monad m => MonadStorage m where
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
@@ -981,72 +772,6 @@ unsafeMapStored :: (a -> b) -> Stored a -> Stored b
unsafeMapStored f (Stored ref x) = Stored ref (f x)
-data StoreInfo = StoreInfo
- { infoDate :: ZonedTime
- , infoNote :: Maybe Text
- }
- deriving (Show)
-
-makeStoreInfo :: IO StoreInfo
-makeStoreInfo = StoreInfo
- <$> getZonedTime
- <*> pure Nothing
-
-storeInfoRec :: StoreInfo -> StoreRec c
-storeInfoRec info = do
- storeDate "date" $ infoDate info
- storeMbText "note" $ infoNote info
-
-loadInfoRec :: LoadRec StoreInfo
-loadInfoRec = StoreInfo
- <$> loadDate "date"
- <*> loadMbText "note"
-
-
-data History a = History StoreInfo (Stored a) (Maybe (StoredHistory a))
- deriving (Show)
-
-type StoredHistory a = Stored (History a)
-
-instance Storable a => Storable (History a) where
- store' (History si x prev) = storeRec $ do
- storeInfoRec si
- storeMbRef "prev" prev
- storeRef "item" x
-
- load' = loadRec $ History
- <$> loadInfoRec
- <*> loadRef "item"
- <*> loadMbRef "prev"
-
-fromHistory :: StoredHistory a -> a
-fromHistory = fromStored . storedFromHistory
-
-fromHistoryAt :: ZonedTime -> StoredHistory a -> Maybe a
-fromHistoryAt zat = fmap (fromStored . snd) . listToMaybe . dropWhile ((at<) . zonedTimeToUTC . fst) . storedHistoryTimedList
- where at = zonedTimeToUTC zat
-
-storedFromHistory :: StoredHistory a -> Stored a
-storedFromHistory sh = let History _ item _ = fromStored sh
- in item
-
-storedHistoryList :: StoredHistory a -> [Stored a]
-storedHistoryList = map snd . storedHistoryTimedList
-
-storedHistoryTimedList :: StoredHistory a -> [(ZonedTime, Stored a)]
-storedHistoryTimedList sh = let History hinfo item prev = fromStored sh
- in (infoDate hinfo, item) : maybe [] storedHistoryTimedList prev
-
-beginHistory :: Storable a => Storage -> StoreInfo -> a -> IO (StoredHistory a)
-beginHistory st si x = do sx <- wrappedStore st x
- wrappedStore st $ History si sx Nothing
-
-modifyHistory :: Storable a => StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a)
-modifyHistory si f prev@(Stored (Ref st _) _) = do
- sx <- wrappedStore st $ f $ fromHistory prev
- wrappedStore st $ History si sx (Just prev)
-
-
showRatio :: Rational -> String
showRatio r = case decimalRatio r of
Just (n, 1) -> show n
diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs
index 772eda0..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.Internal
+import Erebos.Object
import Erebos.PubKey
import Erebos.Service
import Erebos.State
+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 5d0cf62..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.Object.Internal
+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 5341c52..f640feb 100644
--- a/src/Erebos/Service.hs
+++ b/src/Erebos/Service.hs
@@ -34,8 +34,9 @@ import qualified Data.UUID as U
import Erebos.Identity
import {-# SOURCE #-} Erebos.Network
-import Erebos.Object.Internal
import Erebos.State
+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 1dc96ee..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.Object.Internal
+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 40896f7..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.Internal
+import Erebos.Object
import Erebos.PubKey
+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
new file mode 100644
index 0000000..4344b75
--- /dev/null
+++ b/src/Erebos/Storage.hs
@@ -0,0 +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,
+ openStorage, memoryStorage,
+ deriveEphemeralStorage, derivePartialStorage,
+
+ Head, HeadType,
+ HeadID, HeadTypeID,
+ headId, headStorage, headRef, headObject, headStoredObject,
+ loadHeads, loadHead, reloadHead,
+ storeHead, replaceHead, updateHead, updateHead_,
+
+ WatchedHead,
+ watchHead, watchHeadWith, unwatchHead,
+ watchHeadRaw,
+
+ MonadStorage(..),
+) where
+
+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 9e52397..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.Object.Internal
+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 d5d184e..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.Object.Internal
+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 71122f7..32e2e22 100644
--- a/src/Erebos/Sync.hs
+++ b/src/Erebos/Sync.hs
@@ -8,9 +8,9 @@ import Control.Monad.Reader
import Data.List
import Erebos.Identity
-import Erebos.Object.Internal
import Erebos.Service
import Erebos.State
+import Erebos.Storable
import Erebos.Storage.Merge
data SyncService = SyncPacket (Stored SharedState)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 03:31:15 +0000