diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/lib/RON/Storage.hs b/lib/RON/Storage.hs --- a/lib/RON/Storage.hs +++ b/lib/RON/Storage.hs @@ -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 () diff --git a/lib/RON/Storage/Backend.hs b/lib/RON/Storage/Backend.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Storage/Backend.hs @@ -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 diff --git a/lib/RON/Storage/FS.hs b/lib/RON/Storage/FS.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Storage/FS.hs @@ -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 diff --git a/lib/RON/Storage/IO.hs b/lib/RON/Storage/IO.hs deleted file mode 100644 --- a/lib/RON/Storage/IO.hs +++ /dev/null @@ -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 diff --git a/lib/RON/Storage/Test.hs b/lib/RON/Storage/Test.hs --- a/lib/RON/Storage/Test.hs +++ b/lib/RON/Storage/Test.hs @@ -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)) diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs --- a/prelude/Prelude.hs +++ b/prelude/Prelude.hs @@ -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 diff --git a/ron-storage.cabal b/ron-storage.cabal --- a/ron-storage.cabal +++ b/ron-storage.cabal @@ -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