diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/lib/RON/Storage.hs b/lib/RON/Storage.hs --- a/lib/RON/Storage.hs +++ b/lib/RON/Storage.hs @@ -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 diff --git a/lib/RON/Storage/FS.hs b/lib/RON/Storage/FS.hs --- a/lib/RON/Storage/FS.hs +++ b/lib/RON/Storage/FS.hs @@ -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 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 @@ -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 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.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