ron-storage 0.6 → 0.7
raw patch · 8 files changed
+513/−328 lines, 8 files
Files
- CHANGELOG.md +127/−0
- lib/RON/Storage.hs +12/−133
- lib/RON/Storage/Backend.hs +144/−0
- lib/RON/Storage/FS.hs +187/−0
- lib/RON/Storage/IO.hs +0/−183
- lib/RON/Storage/Test.hs +6/−5
- prelude/Prelude.hs +29/−4
- ron-storage.cabal +8/−3
+ CHANGELOG.md view
@@ -0,0 +1,127 @@+# Changelog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0)+and this project adheres to+[Compatible Versioning](https://github.com/staltz/comver).++## [Unreleased]+### Added+- Module `RON.Storage.Rocks`++## [0.7] - 2019-04-25+### Changed+- Rename module `RON.Storage.{IO -> FS}`+- Moved from `RON.Storage` to `RON.Storage.Backend`:+ - `DocId` data constructor+ (the type is still available via `RON.Storage` module)+ - `Document` type+ - `DocVersion` type+ - `MonadStorage` class+ - `readVersion` function++## [0.6] - 2019-03-01+### Added+- `CollectionDocId` type+- `subscriveForever` function++### Changed+- `hOnDocumentChanged` type changed from `IORef (Maybe OnDocumentChanged)` to+ `TChan CollectionDocId`.+ Now, to subscribe to changes you need to `dupTChan` this.++### Removed+- `setOnDocumentChanged` function+- `OnDocumentChanged` type++## [0.5] - 2019-02-04+### Added+- `RON.UUID.liftName` function to create name UUIDs in compile time.+- `RON.Util.ByteStringL` type.+- `RON.Error` module with unified pretty errors.+- Organize `Replicated`, `ReplicatedAsPayload`, and `ReplicatedAsObject` in+ class hierarchy.+- Add `ORSet.removeValue` and `removeRef` implementation.+- Op "patterns" and patterns.++### Removed+- Type alias `ObjectId` since objects are identified by UUID.++### Changed+- Extracted `ron-storage` package.+- Extracted `ron-schema` package.+- Extracted `ron-rdt` package.+- Switched from `Either String a` to `MonadError String m => m a` in failable+ procedures.+- `ORSet.addRef` now adds item's frame, too.+- `ORSet.addNewRef` now returns the reference to the freshly created object.+- Change `StateFrame` key to UUID since objects are identified by UUID.+- Renamed `RawOp` to `ClosedOp` according to the fresh spec.++### Fixed+- Error handling in Boole decoder.++## [0.4] - 2019-01-09+### Added+- Schema `enum` declaration.+- `docIdFromUuid`.+- `OnDocumentChanged` is called each time when any document is changed.++### Changed+- Made GHC 8.6 default.++### Removed+- Schema embedded DSL helpers: `atomInteger`, `atomString`, `boole`, `char`,+ `field`, `option`, `orSet`, `rgaString`, `structLww`, `versionVector`.++### Fixed+- `RGA.edit` bug with re-adding deleted items (#39).++## [0.3] - 2018-12-05+### Added+- Encode/decode EpochTime.+- EDN-based schema DSL.++### Removed+- `RON.Storage.createVersion` from public API.+- `NFData` instances.++## [0.2] - 2018-11-20+### Added+- Schema boole type.+- RON.Storage and submodules are moved from ff project.+- RON.Schema is now re-exported via RON.Schema.TH.++### Changed+- Renamed UUID field "schema" to "version", according to changes in the+ specification.+- RGA: sequential UUIDs on initialization.+- Optimized `Base64.isLetter`.+- Extend `UUID.mkName` to accept any monad.+- Renamed `MonadStorage` methods `list...` -> `get...`+- Renamed `RON.Storage.saveDocument` -> `createDocument`++### Removed+- `RON.Storage.uuidToFileName` as it has no sense as an abstraction+- `RON.Storage.IO.runStorageT` with `StorageT`++## [0.1] - 2018-11-08+### Added+- Package `ron`+ - RON-text format+ - RON-binary format+ - RON-RDT:+ - LWW+ - RGA+ - OR-Set+ - VersionVector+ - RON-Schema+ - RON-Schema TemplateHaskell code generator++[Unreleased]: https://github.com/ff-notes/ron/compare/v0.6...HEAD+[0.6]: https://github.com/ff-notes/ron/compare/v0.5...v0.6+[0.5]: https://github.com/ff-notes/ron/compare/v0.4...v0.5+[0.4]: https://github.com/ff-notes/ron/compare/v0.3...v0.4+[0.3]: https://github.com/ff-notes/ron/compare/v0.2...v0.3+[0.2]: https://github.com/ff-notes/ron/compare/v0.1...v0.2+[0.1]: https://github.com/ff-notes/ron/tree/v0.1
lib/RON/Storage.hs view
@@ -1,133 +1,36 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} --- | RON File Storage. For usage, see "RON.Storage.IO".+-- | RON Storage interface. For usage, see "RON.Storage.FS". module RON.Storage ( Collection (..), CollectionDocId (..), CollectionName,- DocId (..),- Document (..),- DocVersion,- MonadStorage (..),+ DocId, createDocument, decodeDocId, docIdFromUuid, loadDocument, modify,- readVersion, ) where -import qualified Data.ByteString.Lazy.Char8 as BSLC-import Data.String (fromString) import qualified Data.Text as Text-import qualified Text.Show -import RON.Data (ReplicatedAsObject, reduceObject)-import RON.Error (Error (Error), MonadE, errorContext, liftMaybe,- throwErrorString)-import RON.Event (ReplicaClock, getEventUuid)-import RON.Text (parseStateFrame, serializeStateFrame)-import RON.Types (Object (Object, frame, id), UUID)-import RON.Util (ByteStringL)+import RON.Data (reduceObject)+import RON.Error (Error (Error), errorContext, throwErrorString)+import RON.Storage.Backend (Collection (..), CollectionName,+ DocId (DocId), Document (Document),+ IsTouched (IsTouched), MonadStorage,+ createVersion, decodeDocId,+ getDocumentVersions, isTouched,+ readVersion, value, versions)+import RON.Types (Object, UUID) import qualified RON.UUID as UUID --- | Document version identifier (file name)-type DocVersion = FilePath---- | Document identifier (directory name),--- should be a RON-Base32-encoded RON-UUID.-newtype DocId a = DocId FilePath- deriving (Eq, Ord)--instance Collection a => Show (DocId a) where- show (DocId file) = collectionName @a </> file- data CollectionDocId = forall a. Collection a => CollectionDocId (DocId a) --- | Collection (directory name)-type CollectionName = FilePath---- | A type that intended to be put in a separate collection must define a--- Collection instance.-class (ReplicatedAsObject a, Typeable a) => Collection a where-- collectionName :: CollectionName-- -- | Called when RON parser fails.- fallbackParse :: MonadE m => UUID -> ByteStringL -> m (Object a)- fallbackParse _ _ = throwError "no fallback parser implemented"---- | Storage backend interface-class (ReplicaClock m, MonadE m) => MonadStorage m where- getCollections :: m [CollectionName]-- -- | Must return @[]@ for non-existent collection- getDocuments :: Collection a => m [DocId a]-- -- | Must return @[]@ for non-existent document- getDocumentVersions :: Collection a => DocId a -> m [DocVersion]-- -- | Must create collection and document if not exist- saveVersionContent- :: Collection a => DocId a -> DocVersion -> ByteStringL -> m ()-- loadVersionContent :: Collection a => DocId a -> DocVersion -> m ByteStringL-- deleteVersion :: Collection a => DocId a -> DocVersion -> m ()-- changeDocId :: Collection a => DocId a -> DocId a -> m ()---- | Try decode UUID from a file name-decodeDocId- :: DocId a- -> Maybe (Bool, UUID) -- ^ Bool = is document id a valid UUID encoding-decodeDocId (DocId file) = do- uuid <- UUID.decodeBase32 file- pure (UUID.encodeBase32 uuid == file, uuid)---- | Load document version as an object-readVersion- :: MonadStorage m- => Collection a => DocId a -> DocVersion -> m (Object a, IsTouched)-readVersion docid version = do- (isObjectIdValid, id) <-- liftMaybe ("Bad Base32 UUID " <> show docid) $- decodeDocId docid- unless isObjectIdValid $- throwErrorString $ "Not a Base32 UUID " ++ show docid- contents <- loadVersionContent docid version- case parseStateFrame contents of- Right frame ->- pure (Object{id, frame}, IsTouched False)- Left ronError ->- do object <- fallbackParse id contents- pure (object, IsTouched True)- `catchError` \fallbackError ->- throwError $ case BSLC.head contents of- '{' -> fallbackError- _ -> fromString ronError---- | A thing (e.g. document) was fixed during loading.--- It it was fixed during loading it must be saved to the storage.-newtype IsTouched = IsTouched Bool- deriving Show---- | Result of DB reading, loaded document with information about its versions-data Document a = Document- { value :: Object a- -- ^ Merged value.- , versions :: NonEmpty DocVersion- , isTouched :: IsTouched- }- deriving Show- -- | Load all versions of a document loadDocument :: (Collection a, MonadStorage m) => DocId a -> m (Document a) loadDocument docid = loadRetry (3 :: Int)@@ -178,30 +81,6 @@ newObj <- execStateT f $ value oldDoc createVersion (Just (docid, oldDoc)) newObj pure newObj---- | Create new version of an object/document.--- If the document doesn't exist yet, it will be created.-createVersion- :: forall a m- . (Collection a, MonadStorage m)- => Maybe (DocId a, Document a)- -- ^ 'Just', if document exists already; 'Nothing' otherwise.- -> Object a- -> m ()-createVersion mDoc newObj = case mDoc of- Nothing -> save (DocId @a $ UUID.encodeBase32 id) []- Just (docid, oldDoc) -> do- let Document{value = oldObj, versions, isTouched = IsTouched isTouched}- = oldDoc- when (newObj /= oldObj || length versions /= 1 || isTouched) $- save docid $ toList versions- where- Object{id, frame} = newObj-- save docid oldVersions = do- newVersion <- UUID.encodeBase32 <$> getEventUuid- saveVersionContent docid newVersion (serializeStateFrame frame)- for_ oldVersions $ deleteVersion docid -- | Create document assuming it doesn't exist yet. createDocument :: (Collection a, MonadStorage m) => Object a -> m ()
+ lib/RON/Storage/Backend.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | RON Storage details. Use of this module only to implement a backend.+module RON.Storage.Backend (+ Collection (..),+ CollectionName,+ DocId (..),+ Document (..),+ DocVersion,+ IsTouched (..),+ MonadStorage (..),+ createVersion,+ decodeDocId,+ readVersion,+) where++import qualified Data.ByteString.Lazy.Char8 as BSLC+import Data.String (fromString)+import qualified Text.Show (show)++import RON.Data (ReplicatedAsObject)+import RON.Error (MonadE, liftMaybe, throwErrorString)+import RON.Event (ReplicaClock, getEventUuid)+import RON.Text (parseStateFrame, serializeStateFrame)+import RON.Types (Object (Object, frame, id), UUID)+import RON.Util (ByteStringL)+import qualified RON.UUID as UUID++-- | Document version identifier (file name)+type DocVersion = FilePath++-- | Document identifier (directory name),+-- should be a RON-Base32-encoded RON-UUID.+newtype DocId a = DocId FilePath+ deriving (Eq, Ord)++instance Collection a => Show (DocId a) where+ show (DocId file) = collectionName @a </> file++-- | Collection (directory name)+type CollectionName = FilePath++-- | A type that intended to be put in a separate collection must define a+-- Collection instance.+class (ReplicatedAsObject a, Typeable a) => Collection a where++ collectionName :: CollectionName++ -- | Called when RON parser fails.+ fallbackParse :: MonadE m => UUID -> ByteStringL -> m (Object a)+ fallbackParse _ _ = throwError "no fallback parser implemented"++-- | Storage backend interface+class (ReplicaClock m, MonadE m) => MonadStorage m where+ getCollections :: m [CollectionName]++ -- | Must return @[]@ for non-existent collection+ getDocuments :: Collection a => m [DocId a]++ -- | Must return @[]@ for non-existent document+ getDocumentVersions :: Collection a => DocId a -> m [DocVersion]++ -- | Must create collection and document if not exist+ saveVersionContent+ :: Collection a => DocId a -> DocVersion -> ByteStringL -> m ()++ loadVersionContent :: Collection a => DocId a -> DocVersion -> m ByteStringL++ deleteVersion :: Collection a => DocId a -> DocVersion -> m ()++ changeDocId :: Collection a => DocId a -> DocId a -> m ()++-- | Try decode UUID from a file name+decodeDocId+ :: DocId a+ -> Maybe (Bool, UUID) -- ^ Bool = is document id a valid UUID encoding+decodeDocId (DocId file) = do+ uuid <- UUID.decodeBase32 file+ pure (UUID.encodeBase32 uuid == file, uuid)++-- | Load document version as an object+readVersion+ :: MonadStorage m+ => Collection a => DocId a -> DocVersion -> m (Object a, IsTouched)+readVersion docid version = do+ (isObjectIdValid, id) <-+ liftMaybe ("Bad Base32 UUID " <> show docid) $+ decodeDocId docid+ unless isObjectIdValid $+ throwErrorString $ "Not a Base32 UUID " ++ show docid+ contents <- loadVersionContent docid version+ case parseStateFrame contents of+ Right frame ->+ pure (Object{id, frame}, IsTouched False)+ Left ronError ->+ do object <- fallbackParse id contents+ pure (object, IsTouched True)+ `catchError` \fallbackError ->+ throwError $ case BSLC.head contents of+ '{' -> fallbackError+ _ -> fromString ronError++-- | A thing (e.g. document) was fixed during loading.+-- It it was fixed during loading it must be saved to the storage.+newtype IsTouched = IsTouched Bool+ deriving Show++-- | Result of DB reading, loaded document with information about its versions+data Document a = Document+ { value :: Object a+ -- ^ Merged value.+ , versions :: NonEmpty DocVersion+ , isTouched :: IsTouched+ }+ deriving Show++-- | Create new version of an object/document.+-- If the document doesn't exist yet, it will be created.+createVersion+ :: forall a m+ . (Collection a, MonadStorage m)+ => Maybe (DocId a, Document a)+ -- ^ 'Just', if document exists already; 'Nothing' otherwise.+ -> Object a+ -> m ()+createVersion mDoc newObj = case mDoc of+ Nothing -> save (DocId @a $ UUID.encodeBase32 id) []+ Just (docid, oldDoc) -> do+ let Document{value = oldObj, versions, isTouched = IsTouched isTouched}+ = oldDoc+ when (newObj /= oldObj || length versions /= 1 || isTouched) $+ save docid $ toList versions+ where+ Object{id, frame} = newObj++ save docid oldVersions = do+ newVersion <- UUID.encodeBase32 <$> getEventUuid+ saveVersionContent docid newVersion (serializeStateFrame frame)+ for_ oldVersions $ deleteVersion docid
+ lib/RON/Storage/FS.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | A real-world file storage.+--+-- Typical usage:+--+-- @+-- import RON.Storage.FS as Storage+--+-- main = do+-- let dataDir = ".\/data\/"+-- h <- Storage.'newHandle' dataDir+-- 'runStorage' h $ do+-- obj <- 'newObject' Note{active = True, text = "Write an example"}+-- 'createDocument' obj+-- @+module RON.Storage.FS (+ module X,+ -- * Handle+ Handle,+ newHandle,+ -- * Storage+ Storage,+ runStorage,+ subscribeForever,+) where++import Control.Concurrent.STM (TChan, atomically, dupTChan,+ newBroadcastTChanIO, readTChan,+ writeTChan)+import Control.Monad (forever)+import Data.Bits (shiftL)+import qualified Data.ByteString.Lazy as BSL+import Network.Info (MAC (MAC), getNetworkInterfaces, mac)+import System.Directory (canonicalizePath, createDirectoryIfMissing,+ doesDirectoryExist, doesPathExist,+ listDirectory, removeFile, renameDirectory)+import System.IO.Error (isDoesNotExistError)++import RON.Epoch (EpochClock, getCurrentEpochTime, runEpochClock)+import RON.Error (Error, throwErrorString)+import RON.Event (EpochTime, ReplicaClock, ReplicaId, advance,+ applicationSpecific, getEvents, getPid)++import RON.Storage as X+import RON.Storage.Backend (DocId (DocId), MonadStorage, changeDocId,+ deleteVersion, getCollections,+ getDocumentVersions, getDocuments,+ loadVersionContent, saveVersionContent)++-- | Environment is the dataDir+newtype Storage a = Storage (ExceptT Error (ReaderT Handle EpochClock) a)+ deriving (Applicative, Functor, Monad, MonadError Error, MonadIO)++-- | Run a 'Storage' action+runStorage :: Handle -> Storage a -> IO a+runStorage h@Handle{hReplica, hClock} (Storage action) = do+ res <-+ runEpochClock hReplica hClock $+ (`runReaderT` h) $+ runExceptT action+ either throwIO pure res++instance ReplicaClock Storage where+ getPid = Storage . lift $ lift getPid+ getEvents = Storage . lift . lift . getEvents+ advance = Storage . lift . lift . advance++instance MonadStorage Storage where+ getCollections = Storage $ do+ Handle{hDataDir} <- ask+ liftIO $+ listDirectory hDataDir+ >>= filterM (doesDirectoryExist . (hDataDir </>))++ getDocuments :: forall doc. Collection doc => Storage [DocId doc]+ getDocuments = map DocId <$> listDirectoryIfExists (collectionName @doc)++ getDocumentVersions = listDirectoryIfExists . docDir++ saveVersionContent docid version content = do+ Storage $ do+ Handle{hDataDir} <- ask+ let docdir = hDataDir </> docDir docid+ liftIO $ do+ createDirectoryIfMissing True docdir+ BSL.writeFile (docdir </> version) content+ emitDocumentChanged docid++ loadVersionContent docid version = Storage $ do+ Handle{hDataDir} <- ask+ liftIO $ BSL.readFile $ hDataDir </> docDir docid </> version++ deleteVersion docid version = Storage $ do+ Handle{hDataDir} <- ask+ liftIO $ do+ let file = hDataDir </> docDir docid </> version+ removeFile file+ `catch` \e ->+ unless (isDoesNotExistError e) $ throwIO e++ changeDocId old new = do+ renamed <- Storage $ do+ Handle{hDataDir} <- ask+ let oldPath = hDataDir </> docDir old+ newPath = hDataDir </> docDir new+ oldPathCanon <- liftIO $ canonicalizePath oldPath+ newPathCanon <- liftIO $ canonicalizePath newPath+ let pathsDiffer = newPathCanon /= oldPathCanon+ when pathsDiffer $ do+ newPathExists <- liftIO $ doesPathExist newPath+ when newPathExists $+ throwErrorString $ unwords+ [ "changeDocId"+ , show old, "[", oldPath, "->", oldPathCanon, "]"+ , show new, "[", newPath, "->", newPathCanon, "]"+ , ": internal error: new document id is already taken"+ ]+ liftIO $ renameDirectory oldPath newPath+ pure pathsDiffer+ when renamed $ emitDocumentChanged new++-- | Storage handle (uses the “Handle pattern”).+data Handle = Handle+ { hClock :: IORef EpochTime+ , hDataDir :: FilePath+ , hReplica :: ReplicaId+ , hOnDocumentChanged :: TChan CollectionDocId+ }++emitDocumentChanged :: Collection a => DocId a -> Storage ()+emitDocumentChanged docid = Storage $ do+ Handle{hOnDocumentChanged} <- ask+ liftIO . atomically $ writeTChan hOnDocumentChanged $ CollectionDocId docid++-- | Create new storage handle+newHandle :: FilePath -> IO Handle+newHandle hDataDir = do+ time <- getCurrentEpochTime+ hClock <- newIORef time+ hReplica <- applicationSpecific <$> getMacAddress+ hOnDocumentChanged <- newBroadcastTChanIO+ pure Handle{hDataDir, hClock, hReplica, hOnDocumentChanged}++listDirectoryIfExists :: FilePath -> Storage [FilePath]+listDirectoryIfExists relpath = Storage $ do+ Handle{hDataDir} <- ask+ let dir = hDataDir </> relpath+ liftIO $ do+ exists <- doesDirectoryExist dir+ if exists then listDirectory dir else pure []++docDir :: forall a . Collection a => DocId a -> FilePath+docDir (DocId dir) = collectionName @a </> dir++-- MAC address++getMacAddress :: IO Word64+getMacAddress = decodeMac <$> getMac where+ getMac+ = fromMaybe+ (error "Can't get any non-zero MAC address of this machine")+ . listToMaybe+ . filter (/= minBound)+ . map mac+ <$> getNetworkInterfaces+ decodeMac (MAC b5 b4 b3 b2 b1 b0)+ = fromIntegral b5 `shiftL` 40+ + fromIntegral b4 `shiftL` 32+ + fromIntegral b3 `shiftL` 24+ + fromIntegral b2 `shiftL` 16+ + fromIntegral b1 `shiftL` 8+ + fromIntegral b0++subscribeForever :: Handle -> (CollectionDocId -> IO ()) -> IO ()+subscribeForever Handle{hOnDocumentChanged} action = do+ childChan <- atomically $ dupTChan hOnDocumentChanged+ forever $ do+ docId <- atomically $ readTChan childChan+ action docId
− lib/RON/Storage/IO.hs
@@ -1,183 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- | A real-world file storage.------ Typical usage:------ @--- import RON.Storage.IO as Storage------ main = do--- let dataDir = ".\/data\/"--- h <- Storage.'newHandle' dataDir--- 'runStorage' h $ do--- obj <- 'newObject' Note{active = True, text = "Write an example"}--- 'createDocument' obj--- @-module RON.Storage.IO (- module X,- -- * Handle- Handle,- newHandle,- -- * Storage- Storage,- runStorage,- subscribeForever,-) where--import Control.Concurrent.STM (TChan, atomically, dupTChan,- newBroadcastTChanIO, readTChan,- writeTChan)-import Control.Monad (forever)-import Data.Bits (shiftL)-import qualified Data.ByteString.Lazy as BSL-import Network.Info (MAC (MAC), getNetworkInterfaces, mac)-import System.Directory (canonicalizePath, createDirectoryIfMissing,- doesDirectoryExist, doesPathExist,- listDirectory, removeFile, renameDirectory)-import System.IO.Error (isDoesNotExistError)--import RON.Epoch (EpochClock, getCurrentEpochTime, runEpochClock)-import RON.Error (Error, throwErrorString)-import RON.Event (EpochTime, ReplicaClock, ReplicaId, advance,- applicationSpecific, getEvents, getPid)--import RON.Storage as X---- | Environment is the dataDir-newtype Storage a = Storage (ExceptT Error (ReaderT Handle EpochClock) a)- deriving (Applicative, Functor, Monad, MonadError Error, MonadIO)---- | Run a 'Storage' action-runStorage :: Handle -> Storage a -> IO a-runStorage h@Handle{hReplica, hClock} (Storage action) = do- res <-- runEpochClock hReplica hClock $- (`runReaderT` h) $- runExceptT action- either throwIO pure res--instance ReplicaClock Storage where- getPid = Storage . lift $ lift getPid- getEvents = Storage . lift . lift . getEvents- advance = Storage . lift . lift . advance--instance MonadStorage Storage where- getCollections = Storage $ do- Handle{hDataDir} <- ask- liftIO $- listDirectory hDataDir- >>= filterM (doesDirectoryExist . (hDataDir </>))-- getDocuments :: forall doc. Collection doc => Storage [DocId doc]- getDocuments = map DocId <$> listDirectoryIfExists (collectionName @doc)-- getDocumentVersions = listDirectoryIfExists . docDir-- saveVersionContent docid version content = do- Storage $ do- Handle{hDataDir} <- ask- let docdir = hDataDir </> docDir docid- liftIO $ do- createDirectoryIfMissing True docdir- BSL.writeFile (docdir </> version) content- emitDocumentChanged docid-- loadVersionContent docid version = Storage $ do- Handle{hDataDir} <- ask- liftIO $ BSL.readFile $ hDataDir </> docDir docid </> version-- deleteVersion docid version = Storage $ do- Handle{hDataDir} <- ask- liftIO $ do- let file = hDataDir </> docDir docid </> version- removeFile file- `catch` \e ->- unless (isDoesNotExistError e) $ throwIO e-- changeDocId old new = do- renamed <- Storage $ do- Handle{hDataDir} <- ask- let oldPath = hDataDir </> docDir old- newPath = hDataDir </> docDir new- oldPathCanon <- liftIO $ canonicalizePath oldPath- newPathCanon <- liftIO $ canonicalizePath newPath- let pathsDiffer = newPathCanon /= oldPathCanon- when pathsDiffer $ do- newPathExists <- liftIO $ doesPathExist newPath- when newPathExists $- throwErrorString $ unwords- [ "changeDocId"- , show old, "[", oldPath, "->", oldPathCanon, "]"- , show new, "[", newPath, "->", newPathCanon, "]"- , ": internal error: new document id is already taken"- ]- liftIO $ renameDirectory oldPath newPath- pure pathsDiffer- when renamed $ emitDocumentChanged new---- | Storage handle (uses the “Handle pattern”).-data Handle = Handle- { hClock :: IORef EpochTime- , hDataDir :: FilePath- , hReplica :: ReplicaId- , hOnDocumentChanged :: TChan CollectionDocId- }--emitDocumentChanged :: Collection a => DocId a -> Storage ()-emitDocumentChanged docid = Storage $ do- Handle{hOnDocumentChanged} <- ask- liftIO . atomically $ writeTChan hOnDocumentChanged $ CollectionDocId docid---- | Create new storage handle-newHandle :: FilePath -> IO Handle-newHandle hDataDir = do- time <- getCurrentEpochTime- hClock <- newIORef time- hReplica <- applicationSpecific <$> getMacAddress- hOnDocumentChanged <- newBroadcastTChanIO- pure Handle{hDataDir, hClock, hReplica, hOnDocumentChanged}--listDirectoryIfExists :: FilePath -> Storage [FilePath]-listDirectoryIfExists relpath = Storage $ do- Handle{hDataDir} <- ask- let dir = hDataDir </> relpath- liftIO $ do- exists <- doesDirectoryExist dir- if exists then listDirectory dir else pure []--docDir :: forall a . Collection a => DocId a -> FilePath-docDir (DocId dir) = collectionName @a </> dir---- MAC address--getMacAddress :: IO Word64-getMacAddress = decodeMac <$> getMac where- getMac- = fromMaybe- (error "Can't get any non-zero MAC address of this machine")- . listToMaybe- . filter (/= minBound)- . map mac- <$> getNetworkInterfaces- decodeMac (MAC b5 b4 b3 b2 b1 b0)- = fromIntegral b5 `shiftL` 40- + fromIntegral b4 `shiftL` 32- + fromIntegral b3 `shiftL` 24- + fromIntegral b2 `shiftL` 16- + fromIntegral b1 `shiftL` 8- + fromIntegral b0--subscribeForever :: Handle -> (CollectionDocId -> IO ()) -> IO ()-subscribeForever Handle{hOnDocumentChanged} action = do- childChan <- atomically $ dupTChan hOnDocumentChanged- forever $ do- docId <- atomically $ readTChan childChan- action docId
lib/RON/Storage/Test.hs view
@@ -17,11 +17,12 @@ import RON.Event.Simulation (ReplicaSim, runNetworkSim, runReplicaSim) import RON.Util (ByteStringL) -import RON.Storage (Collection, CollectionName, DocId (DocId),- DocVersion, MonadStorage, changeDocId,- collectionName, deleteVersion, getCollections,- getDocumentVersions, getDocuments,- loadVersionContent, saveVersionContent)+import RON.Storage (Collection, CollectionName, collectionName)+import RON.Storage.Backend (DocId (DocId), DocVersion, MonadStorage,+ changeDocId, deleteVersion,+ getCollections, getDocumentVersions,+ getDocuments, loadVersionContent,+ saveVersionContent) type TestDB = Map CollectionName (Map DocumentId (Map DocVersion Document))
prelude/Prelude.hs view
@@ -5,13 +5,18 @@ module X, fmapL, foldr1,+ headMay, identity, lastDef, maximumDef, maxOn, minOn,+ note,+ replicateM2,+ replicateM3, show, whenJust,+ (!!), (?:), ) where @@ -40,10 +45,11 @@ import Data.Int as X (Int, Int16, Int32, Int64, Int8) import Data.IORef as X (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)-import Data.List as X (filter, genericLength, intercalate, isPrefixOf,- isSuffixOf, lookup, map, partition, repeat,- replicate, sortBy, sortOn, span, splitAt, take,- takeWhile, unlines, unwords, zip, (++))+import Data.List as X (drop, filter, genericLength, intercalate,+ isPrefixOf, isSuffixOf, lookup, map, partition,+ repeat, replicate, sortBy, sortOn, span,+ splitAt, take, takeWhile, unlines, unwords,+ zip, (++)) import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty) import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList)@@ -131,6 +137,11 @@ foldr1 :: (a -> a -> a) -> NonEmpty a -> a foldr1 = Data.Foldable.foldr1 +headMay :: [a] -> Maybe a+headMay = \case+ [] -> Nothing+ a:_ -> Just a+ identity :: a -> a identity x = x @@ -151,11 +162,25 @@ minOn :: Ord b => (a -> b) -> a -> a -> a minOn f x y = if f x < f y then x else y +note :: e -> Maybe a -> Either e a+note e = maybe (Left e) Right++replicateM2 :: Applicative m => m a -> m (a, a)+replicateM2 ma = (,) <$> ma <*> ma++replicateM3 :: Applicative m => m a -> m (a, a, a)+replicateM3 ma = (,,) <$> ma <*> ma <*> ma+ show :: (Show a, IsString s) => a -> s show = fromString . Text.Show.show whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust m f = maybe (pure ()) f m++(!!) :: [a] -> Int -> Maybe a+xs !! i+ | i < 0 = Nothing+ | otherwise = headMay $ drop i xs -- | An infix form of 'fromMaybe' with arguments flipped. (?:) :: Maybe a -> a -> a
ron-storage.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-storage-version: 0.6+version: 0.7 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -19,7 +19,7 @@ . > import RON.Data > import RON.Schema.TH- > import RON.Storage.IO as Storage+ > import RON.Storage.FS as Storage > > [mkReplicated| > (struct_lww Note@@ -41,6 +41,9 @@ build-type: Simple +extra-source-files:+ CHANGELOG.md+ common language build-depends: base >= 4.10 && < 4.13, integer-gmp default-extensions: MonadFailDesugaring StrictData@@ -66,6 +69,8 @@ ron-rdt exposed-modules: RON.Storage- RON.Storage.IO+ RON.Storage.Backend+ RON.Storage.FS+ -- RON.Storage.Rocks RON.Storage.Test hs-source-dirs: lib