ron-storage 0.9 → 0.10
raw patch · 5 files changed
+191/−136 lines, 5 filesdep +tf-random
Dependencies added: tf-random
Files
- CHANGELOG.md +8/−3
- lib/RON/Storage.hs +1/−2
- lib/RON/Storage/FS.hs +175/−126
- lib/RON/Storage/Test.hs +5/−4
- ron-storage.cabal +2/−1
CHANGELOG.md view
@@ -7,11 +7,15 @@ ## [Unreleased] -## [0.9] - 2019-08-10+## [0.10] - 2019-09-06 ### Added-- Type alias Payload = [Atom]+- Function `newHandleWithReplicaId` ### Changed+- Function `newHandle` takes random replica id if cannot get MAC address++## [0.9] - 2019-08-10+### Changed - `modify` now pops result of action (to use with `getObject`, for instance). - Renamed `ObjectState` to `ObjectFrame` - Renamed `Document.value` to `objectFrame`@@ -133,7 +137,8 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ron/compare/ron-storage-0.9...HEAD+[Unreleased]: https://github.com/ff-notes/ron/compare/ron-storage-0.10...HEAD+[0.10]: https://github.com/ff-notes/ron/compare/ron-storage-0.9...ron-storage-0.10 [0.9]: https://github.com/ff-notes/ron/compare/ron-storage-0.8...ron-storage-0.9 [0.8]: https://github.com/ff-notes/ron/compare/ron-storage-0.7...ron-storage-0.8 [0.7]: https://github.com/ff-notes/ron/compare/ron-storage-0.6...ron-storage-0.7
lib/RON/Storage.hs view
@@ -84,8 +84,7 @@ try ma = (Right <$> ma) `catchError` (pure . Left) -- | Load document, apply changes and put it back to storage-modify- :: (Collection a, MonadStorage m) => DocId a -> ObjectStateT a m b -> m b+modify :: (Collection a, MonadStorage m) => DocId a -> ObjectStateT a m b -> m b modify docid f = do oldDoc <- loadDocument docid (b, objectFrame') <- runObjectState (objectFrame oldDoc) f
lib/RON/Storage/FS.hs view
@@ -21,170 +21,219 @@ -- obj <- 'newObjectState' Note{active = True, text = "Write an example"} -- 'createDocument' obj -- @-module RON.Storage.FS (- module X,+module RON.Storage.FS+ ( module X, -- * Handle Handle, newHandle,+ newHandleWithReplicaId, -- * Storage Storage, runStorage,- subscribeForever,-) where--import RON.Prelude+ subscribeForever+ )+where -import Control.Concurrent.STM (TChan, atomically, dupTChan,- newBroadcastTChanIO, readTChan,- writeTChan)-import Control.Monad (forever)-import Data.Bits (shiftL)+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.FilePath ((</>))-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)+import Network.Info (MAC (MAC), getNetworkInterfaces, mac)+import RON.Epoch (EpochClock, getCurrentEpochTime, runEpochClock)+import RON.Error (Error, throwErrorString)+import RON.Event+ ( EpochTime,+ ReplicaClock,+ ReplicaId,+ advance,+ applicationSpecific,+ getEvents,+ getPid+ )+import RON.Prelude+import RON.Storage as X+import RON.Storage.Backend+ ( DocId (DocId),+ MonadStorage,+ changeDocId,+ deleteVersion,+ getCollections,+ getDocumentVersions,+ getDocuments,+ loadVersionContent,+ saveVersionContent+ )+import System.Directory+ ( canonicalizePath,+ createDirectoryIfMissing,+ doesDirectoryExist,+ doesPathExist,+ listDirectory,+ removeFile,+ renameDirectory+ )+import System.FilePath ((</>))+import System.IO.Error (isDoesNotExistError)+import System.Random.TF (newTFGen)+import System.Random.TF.Instances (random) -- | Environment is the dataDir newtype Storage a = Storage (ExceptT Error (ReaderT Handle EpochClock) a)- deriving (Applicative, Functor, Monad, MonadError Error, MonadIO)+ 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+runStorage h@Handle {replica, clock} (Storage action) = do+ res <-+ runEpochClock replica clock+ $ (`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 + 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)+ getCollections = Storage $ do+ Handle {dataDir} <- ask+ liftIO+ $ listDirectory dataDir+ >>= filterM (doesDirectoryExist . (dataDir </>)) - getDocumentVersions = listDirectoryIfExists . docDir+ getDocuments :: forall doc. Collection doc => Storage [DocId doc]+ getDocuments = map DocId <$> listDirectoryIfExists (collectionName @doc) - 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+ getDocumentVersions = listDirectoryIfExists . docDir - loadVersionContent docid version = Storage $ do- Handle{hDataDir} <- ask- liftIO $ BSL.readFile $ hDataDir </> docDir docid </> version+ saveVersionContent docid version content = do+ Storage $ do+ Handle {dataDir} <- ask+ let docdir = dataDir </> docDir docid+ liftIO $ do+ createDirectoryIfMissing True docdir+ BSL.writeFile (docdir </> version) content+ emitDocumentChanged docid - 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+ loadVersionContent docid version = Storage $ do+ Handle {dataDir} <- ask+ liftIO $ BSL.readFile $ dataDir </> docDir docid </> version - 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+ deleteVersion docid version = Storage $ do+ Handle {dataDir} <- ask+ liftIO $ do+ let file = dataDir </> docDir docid </> version+ removeFile file+ `catch` \e ->+ unless (isDoesNotExistError e) $ throwIO e + changeDocId old new = do+ renamed <- x+ when renamed $ emitDocumentChanged new+ where+ x = Storage $ do+ Handle {dataDir} <- ask+ let oldPath = dataDir </> docDir old+ newPath = dataDir </> 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+ -- | Storage handle (uses the “Handle pattern”).-data Handle = Handle- { hClock :: IORef EpochTime- , hDataDir :: FilePath- , hReplica :: ReplicaId- , hOnDocumentChanged :: TChan CollectionDocId- }+data Handle+ = Handle+ { clock :: IORef EpochTime,+ dataDir :: FilePath,+ replica :: ReplicaId,+ onDocumentChanged :: TChan CollectionDocId+ } emitDocumentChanged :: Collection a => DocId a -> Storage () emitDocumentChanged docid = Storage $ do- Handle{hOnDocumentChanged} <- ask- liftIO . atomically $ writeTChan hOnDocumentChanged $ CollectionDocId docid+ Handle {onDocumentChanged} <- ask+ liftIO . atomically $ writeTChan onDocumentChanged $ CollectionDocId docid --- | Create new storage handle+-- | Create new storage handle.+-- Uses MAC address for replica id or generates a random one. newHandle :: FilePath -> IO Handle newHandle hDataDir = do- time <- getCurrentEpochTime- hClock <- newIORef time- hReplica <- applicationSpecific <$> getMacAddress- hOnDocumentChanged <- newBroadcastTChanIO- pure Handle{hDataDir, hClock, hReplica, hOnDocumentChanged}+ macAddress <- getMacAddress+ replicaId <-+ case macAddress of+ Just macAddress' -> pure macAddress'+ Nothing -> fst . random <$> newTFGen+ newHandleWithReplicaId hDataDir replicaId +newHandleWithReplicaId :: FilePath -> Word64 -> IO Handle+newHandleWithReplicaId dataDir replicaId = do+ time <- getCurrentEpochTime+ clock <- newIORef time+ let replica = applicationSpecific replicaId+ onDocumentChanged <- newBroadcastTChanIO+ pure Handle {dataDir, clock, replica, onDocumentChanged}+ 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 []+ Handle {dataDir} <- ask+ let dir = dataDir </> relpath+ liftIO $ do+ exists <- doesDirectoryExist dir+ if exists then listDirectory dir else pure [] -docDir :: forall a . Collection a => DocId a -> FilePath+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+getMacAddress :: IO (Maybe Word64)+getMacAddress = do+ macAddress <- getMac+ pure $ decodeMac <$> macAddress+ where+ getMac =+ 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+subscribeForever Handle {onDocumentChanged} action = do+ childChan <- atomically $ dupTChan onDocumentChanged+ forever $ do+ docId <- atomically $ readTChan childChan+ action docId
lib/RON/Storage/Test.hs view
@@ -15,7 +15,8 @@ import RON.Error (Error) import RON.Event (ReplicaClock, applicationSpecific)-import RON.Event.Simulation (ReplicaSim, runNetworkSim, runReplicaSim)+import RON.Event.Simulation (ReplicaSimT, runNetworkSimT,+ runReplicaSimT) import RON.Util (ByteStringL) import RON.Storage (Collection, CollectionName, collectionName)@@ -33,13 +34,13 @@ -- * Storage simulation -newtype StorageSim a = StorageSim (StateT TestDB (ExceptT Error ReplicaSim) a)+newtype StorageSim a = StorageSim (StateT TestDB (ReplicaSimT (Either Error)) a) deriving (Applicative, Functor, Monad, MonadError Error, ReplicaClock) runStorageSim :: TestDB -> StorageSim a -> Either Error (a, TestDB) runStorageSim db (StorageSim action) =- runNetworkSim $ runReplicaSim (applicationSpecific 34) $- runExceptT $ runStateT action db+ runNetworkSimT $ runReplicaSimT (applicationSpecific 34) $+ runStateT action db instance MonadStorage StorageSim where getCollections = StorageSim $ gets Map.keys
ron-storage.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-storage-version: 0.9+version: 0.10 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -40,6 +40,7 @@ stm, text, transformers,+ tf-random, -- project ron, ron-rdt