diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2018, Yuriy Syrovetskiy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/lib/RON/Base64.hs b/lib/RON/Base64.hs --- a/lib/RON/Base64.hs +++ b/lib/RON/Base64.hs @@ -4,7 +4,8 @@ -- | RON version of Base64 encoding module RON.Base64 - ( decode + ( alphabet + , decode , decode60 , decode60base32 , decode64 @@ -26,19 +27,24 @@ import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -import Data.Char (isAlphaNum, ord) +import Data.Char (ord) import RON.Internal.Word (Word4, Word6 (W6), Word60, leastSignificant4, leastSignificant6, leastSignificant60, safeCast) +-- | Base64 alphabet alphabet :: ByteString alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~" -- | Check if a character is in the Base64 alphabet. --- TODO use approach from 'isUpperHexDigit' -isLetter :: Char -> Bool -isLetter c = isAlphaNum c || c == '_' || c == '~' +isLetter :: Word8 -> Bool +isLetter c + = c - ord0 <= 9 + || c - ordA <= 25 + || c - orda <= 25 + || c == ord_ + || c == ordõ -- | Convert a Base64 letter to a number [0-63] decodeLetter :: Word8 -> Maybe Word6 @@ -108,18 +114,18 @@ <=< traverse (fmap safeCast . decodeLetter) . BS.unpack where go :: Int -> [Word8] -> Maybe Word64 - go n - | n > 0 = \case - [] -> Just 0 - [a] -> Just $ decode4 a 0 0 0 - [a, b] -> Just $ decode4 a b 0 0 - [a, b, c] -> Just $ decode4 a b c 0 - a:b:c:d:rest -> do + go n = \case + [] | n >= 0 -> Just 0 + [a] | n >= 1 -> Just $ decode4 a 0 0 0 + [a, b] + | n >= 2 -> Just $ decode4 a b 0 0 + [a, b, c] + | n >= 3 -> Just $ decode4 a b c 0 + (a:b:c:d:rest) + | n >= 4 -> do lowerPart <- go (n - 4) rest pure $ decode4 a b c d .|. (lowerPart `shiftR` 24) - | otherwise = \case - [] -> Just 0 - _ -> Nothing -- extra input + _ -> Nothing -- extra input decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Word64 decode4 a b c d = (safeCast a `shiftL` 54) .|. diff --git a/lib/RON/Data.hs b/lib/RON/Data.hs --- a/lib/RON/Data.hs +++ b/lib/RON/Data.hs @@ -67,7 +67,8 @@ reduceWireFrameByType :: (UUID, UUID) -> NonEmpty WireChunk -> [WireChunk] reduceWireFrameByType (typ, obj) = case reducers !? typ of - Nothing -> toList -- TODO use default reducer + Nothing -> + toList -- TODO(2018-11-08, cblp, #27) use default reducer Just Reducer{wireReducer} -> wireReducer obj isQuery :: WireChunk -> Bool diff --git a/lib/RON/Data/Internal.hs b/lib/RON/Data/Internal.hs --- a/lib/RON/Data/Internal.hs +++ b/lib/RON/Data/Internal.hs @@ -31,7 +31,7 @@ -- | Unapplied patches and raw ops type Unapplied = ([ReducedChunk], [Op]) --- TODO(2018-08-24, cblp) Semilattice a? +-- TODO(2018-08-24, cblp, #26) Semilattice a? -- | Untyped-reducible types. -- Untyped means if this type is a container then the types of data contained in -- it is not considered. @@ -220,10 +220,10 @@ eqPayload a atoms = toPayload a == atoms pattern None :: Atom -pattern None = AUuid (UUID 0xcb3ca9000000000 0) +pattern None = AUuid (UUID 0xcb3ca9000000000 0) -- none pattern Some :: Atom -pattern Some = AUuid (UUID 0xdf3c69000000000 0) +pattern Some = AUuid (UUID 0xdf3c69000000000 0) -- some instance Replicated a => Replicated (Maybe a) where encoding = Encoding @@ -244,3 +244,21 @@ Some : atoms -> Just <$> fromPayload atoms [None] -> pure Nothing _ -> Left "Bad Option" + +pattern ATrue :: Atom +pattern ATrue = AUuid (UUID 0xe36e69000000000 0) + +pattern AFalse :: Atom +pattern AFalse = AUuid (UUID 0xaa5c37a40000000 0) + +instance Replicated Bool where encoding = payloadEncoding + +instance ReplicatedAsPayload Bool where + toPayload b + | b = [ATrue] + | otherwise = [AFalse] + + fromPayload = \case + [ATrue] -> pure True + [AFalse] -> pure False + _ -> fail "Expected single UUID" diff --git a/lib/RON/Data/RGA.hs b/lib/RON/Data/RGA.hs --- a/lib/RON/Data/RGA.hs +++ b/lib/RON/Data/RGA.hs @@ -29,15 +29,17 @@ getGroupedDiffBy) import Data.Bifunctor (bimap) import qualified Data.HashMap.Strict as HashMap +import Data.List (genericLength) import qualified Data.Map.Strict as Map import Data.Monoid (Last (..)) import qualified Data.Text as Text import RON.Data.Internal -import RON.Event (ReplicaClock, advanceToUuid, getEventUuid) -import RON.Internal.Word (pattern B11) +import RON.Event (ReplicaClock, advanceToUuid, getEventUuid, + getEventUuids) +import RON.Internal.Word (pattern B11, ls60) import RON.Types (Object (..), Op (..), StateChunk (..), UUID) -import RON.UUID (pattern Zero, uuidScheme) +import RON.UUID (pattern Zero, uuidVersion) import qualified RON.UUID as UUID -- | opEvent = vertex id @@ -45,12 +47,7 @@ -- 0 = value is alive, -- _ = tombstone event, value is backup for undo -- opPayload: the value --- TODO record pattern synonyms -newtype Vertex = Vertex Op - deriving (Eq, Show) - -unVertex :: Vertex -> Op -unVertex (Vertex op) = op +type Vertex = Op data VertexListItem = VertexListItem { itemValue :: Vertex @@ -58,7 +55,6 @@ } deriving (Eq, Show) --- | TODO(2018-11-07, cblp) MonoFoldable? data VertexList = VertexList { listHead :: UUID , listItems :: HashMap UUID VertexListItem @@ -68,8 +64,8 @@ instance Semigroup VertexList where (<>) = merge -vertexListToList :: Maybe VertexList -> [Vertex] -vertexListToList mv = case mv of +vertexListToOps :: Maybe VertexList -> [Vertex] +vertexListToOps mv = case mv of Nothing -> [] Just VertexList{..} -> go listHead listItems where @@ -87,12 +83,9 @@ Nothing -> [] in itemValue : rest -vertexListToOps :: Maybe VertexList -> [Op] -vertexListToOps = map unVertex . vertexListToList - -vertexListFromList :: [Vertex] -> Maybe VertexList -vertexListFromList = foldr go mempty where - go v@(Vertex Op{opEvent = vid}) vlist = +vertexListFromOps :: [Vertex] -> Maybe VertexList +vertexListFromOps = foldr go mempty where + go v@Op{opEvent = vid} vlist = Just $ VertexList{listHead = vid, listItems = vlist'} where item itemNext = VertexListItem{itemValue = v, itemNext} @@ -101,9 +94,6 @@ Just VertexList{listHead, listItems} -> HashMap.insert vid (item $ Just listHead) listItems -vertexListFromOps :: [Op] -> Maybe VertexList -vertexListFromOps = vertexListFromList . map Vertex - -- | Untyped RGA newtype RgaRaw = RgaRaw (Maybe VertexList) deriving (Eq, Monoid, Semigroup, Show) @@ -141,7 +131,7 @@ HashMap.singleton opEvent VertexListItem - { itemValue = Vertex op{opRef = Zero} + { itemValue = op{opRef = Zero} , itemNext = Nothing } } @@ -149,7 +139,7 @@ patchSetFromChunk :: ReducedChunk -> PatchSet patchSetFromChunk ReducedChunk{rcRef, rcBody} = - case uuidScheme $ UUID.split rcRef of + case uuidVersion $ UUID.split rcRef of B11 -> -- derived event -- rm-patch compatibility foldMap patchSetFromRawOp rcBody @@ -285,15 +275,15 @@ -> HashMap UUID VertexListItem -> Maybe (HashMap UUID VertexListItem) applyRemoval parent tombstone targetItems = do - item@VertexListItem{itemValue = Vertex v@Op{opRef}} <- + item@VertexListItem{itemValue = v@Op{opRef}} <- HashMap.lookup parent targetItems - let item' = item{itemValue = Vertex v{opRef = max opRef tombstone}} + let item' = item{itemValue = v{opRef = max opRef tombstone}} pure $ HashMap.insert parent item' targetItems merge :: VertexList -> VertexList -> VertexList merge v1 v2 = - fromMaybe undefined . vertexListFromList $ - (merge' `on` vertexListToList . Just) v1 v2 + fromMaybe undefined . vertexListFromOps $ + (merge' `on` vertexListToOps . Just) v1 v2 merge' :: [Vertex] -> [Vertex] -> [Vertex] merge' [] vs2 = vs2 @@ -304,11 +294,11 @@ GT -> v1 : merge' vs1 w2 EQ -> mergeVertices : merge' vs1 vs2 where - Vertex Op{opEvent = e1, opRef = tombstone1, opPayload = p1} = v1 - Vertex Op{opEvent = e2, opRef = tombstone2, opPayload = p2} = v2 + Op{opEvent = e1, opRef = tombstone1, opPayload = p1} = v1 + Op{opEvent = e2, opRef = tombstone2, opPayload = p2} = v2 -- priority of deletion - mergeVertices = Vertex Op + mergeVertices = Op { opEvent = e1 , opRef = max tombstone1 tombstone2 , opPayload = maxOn length p1 p2 @@ -328,8 +318,8 @@ objectOpType = rgaType newObject (RGA items) = collectFrame $ do - ops <- for items $ \item -> do - vertexId <- lift getEventUuid + vertexIds <- lift $ getEventUuids $ ls60 $ genericLength items + ops <- for (zip items vertexIds) $ \(item, vertexId) -> do payload <- newRon item pure $ Op vertexId Zero payload oid <- lift getEventUuid diff --git a/lib/RON/Event.hs b/lib/RON/Event.hs --- a/lib/RON/Event.hs +++ b/lib/RON/Event.hs @@ -41,8 +41,8 @@ leastSignificant24, leastSignificant4, leastSignificant6, ls12, ls24, ls6, ls60, safeCast) -import RON.UUID (UUID, UuidFields (UuidFields), uuidOrigin, - uuidScheme, uuidValue, uuidVariant, uuidVariety) +import RON.UUID (UUID, UuidFields (UuidFields), uuidOrigin, uuidValue, + uuidVariant, uuidVariety, uuidVersion) import qualified RON.UUID as UUID -- | Calendar format. See https://github.com/gritzko/ron/issues/19. @@ -222,7 +222,7 @@ { uuidVariety , uuidValue , uuidVariant = B00 - , uuidScheme = B10 + , uuidVersion = B10 , uuidOrigin } where @@ -272,7 +272,7 @@ -- nanosecond -> Maybe CalendarTime mkCalendarDateTimeNano (y, m, d) (hh, mm, ss) ns = - -- TODO(2018-08-19, cblp) check bounds + -- TODO(2018-08-19, cblp, #24) validate bounds pure CalendarTime { months = ls12 $ (y - 2010) * 12 + m - 1 , days = ls6 $ d - 1 diff --git a/lib/RON/Event/Simulation.hs b/lib/RON/Event/Simulation.hs --- a/lib/RON/Event/Simulation.hs +++ b/lib/RON/Event/Simulation.hs @@ -22,11 +22,10 @@ import Data.Functor.Identity (Identity) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) import RON.Event (EpochEvent (EpochEvent), ReplicaClock, ReplicaId, advance, getEvents, getPid) -import RON.Internal.Word (Word60, Word64, ls60, word60add) +import RON.Internal.Word (Word60, ls60, word60add) -- | Lamport clock simulation. Key is 'ReplicaId'. -- Non-present value is equivalent to (0, initial). @@ -52,10 +51,14 @@ getEvents n' = ReplicaSim $ do rid <- ask - t0 <- lift $ preIncreaseTime rid - pure [EpochEvent t rid | t <- [t0 .. t0 `word60add` n]] + (t0, t1) <- + lift $ NetworkSim $ state $ \replicaStates -> let + t0 = HM.lookupDefault (ls60 1) rid replicaStates + t1 = t0 `word60add` n + in ((t0, t1), HM.insert rid t1 replicaStates) + pure [EpochEvent t rid | t <- [t0 .. t1]] where - n = max n' (ls60 (1 :: Word64)) + n = max n' (ls60 1) advance time = ReplicaSim $ do rid <- ask @@ -91,9 +94,3 @@ runReplicaSimT :: ReplicaId -> ReplicaSimT m a -> NetworkSimT m a runReplicaSimT rid (ReplicaSim action) = runReaderT action rid - --- | Increase time by rid and return new value -preIncreaseTime :: Monad m => ReplicaId -> NetworkSimT m Word60 -preIncreaseTime rid = NetworkSim $ state $ \pss -> - let time = succ $ fromMaybe (ls60 0) $ HM.lookup rid pss - in (time, HM.insert rid time pss) diff --git a/lib/RON/Schema.hs b/lib/RON/Schema.hs --- a/lib/RON/Schema.hs +++ b/lib/RON/Schema.hs @@ -17,6 +17,7 @@ , TOpaque (..) , atomInteger , atomString + , boole , char , def , field @@ -119,3 +120,6 @@ versionVector :: RonType versionVector = TObject TVersionVector + +boole :: RonType +boole = opaqueAtoms def{oaHaskellType = Just "Bool"} diff --git a/lib/RON/Schema/TH.hs b/lib/RON/Schema/TH.hs --- a/lib/RON/Schema/TH.hs +++ b/lib/RON/Schema/TH.hs @@ -4,9 +4,10 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module RON.Schema.TH - ( mkReplicated - ) where +module RON.Schema.TH( + module X, + mkReplicated, +) where import Prelude hiding (read) import RON.Internal.Prelude @@ -32,11 +33,7 @@ import RON.Data.RGA (RGA (..)) import RON.Data.VersionVector (VersionVector) import RON.Event (ReplicaClock) -import RON.Schema (Declaration (..), Field (..), - FieldAnnotations (..), OpaqueAnnotations (..), - RonType (..), Schema, StructAnnotations (..), - StructLww (..), TAtom (..), TComposite (..), - TObject (..), TOpaque (..)) +import RON.Schema as X import RON.Types (Object (..), UUID) import qualified RON.UUID as UUID @@ -85,14 +82,11 @@ mkReplicatedStructLww :: StructLww -> TH.DecsQ mkReplicatedStructLww struct = do - fields <- for (Map.assocs structFields) $ \(field'Name, field) -> let - Field{fieldType} = field - field'Type = fieldType - in + fields <- for (Map.assocs structFields) $ \(field'Name, Field{fieldType}) -> case UUID.mkName . BSC.pack $ Text.unpack field'Name of Just field'RonName -> do field'Var <- TH.newName $ Text.unpack field'Name - pure Field'{..} + pure Field'{field'Type = fieldType, ..} Nothing -> fail $ "Field name is not representable in RON: " ++ show field'Name dataType <- mkDataType diff --git a/lib/RON/Storage.hs b/lib/RON/Storage.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Storage.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +-- | RON File Storage. For usage, see "RON.Storage.IO". +module RON.Storage + ( Collection (..) + , CollectionName + , DocId (..) + , Document (..) + , DocVersion + , MonadStorage (..) + , createDocument + , createVersion + , decodeDocId + , loadDocument + , modify + , readVersion + ) where + +import Control.Monad (unless, when) +import Control.Monad.Except (MonadError, catchError, liftEither, + throwError) +import Control.Monad.State.Strict (StateT, execStateT) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Foldable (for_) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Traversable (for) +import System.FilePath (()) + +import RON.Data (ReplicatedAsObject, reduceObject) +import RON.Event (ReplicaClock, getEventUuid) +import RON.Text (parseStateFrame, serializeStateFrame) +import RON.Types (Object (Object), UUID, objectFrame, objectId) +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 + +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 => Collection a where + + collectionName :: CollectionName + + -- | Called when RON parser fails. + fallbackParse :: UUID -> ByteString -> Either String (Object a) + fallbackParse _ _ = Left "no fallback parser implemented" + +-- | Storage backend interface +class (ReplicaClock m, MonadError String 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 -> ByteString -> m () + + loadVersionContent :: Collection a => DocId a -> DocVersion -> m ByteString + + 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, objectId) <- + liftEither $ + maybe (Left $ "Bad Base32 UUID " ++ show docid) Right $ + decodeDocId docid + unless isObjectIdValid $ throwError $ "Not a Base32 UUID " ++ show docid + contents <- loadVersionContent docid version + case parseStateFrame contents of + Right objectFrame -> + pure (Object{objectId, objectFrame}, IsTouched False) + Left ronError -> case fallbackParse objectId contents of + Right object -> pure (object, IsTouched True) + Left fallbackError -> throwError $ case BSLC.head contents of + '{' -> fallbackError + _ -> 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) + where + loadRetry n + | n > 0 = do + versions0 <- getDocumentVersions docid + case versions0 of + [] -> throwError $ "Empty document " ++ show docid + v:vs -> do + let versions = v :| vs + let wrapDoc (value, isTouched) = + Document{value, versions, isTouched} + e1 <- + for versions $ \ver -> do + let ctx = "document " ++ show docid + ++ ", version " ++ ver + ++ ": " + e1 <- try $ readVersion docid ver + pure $ fmapL (ctx ++) e1 + liftEither $ wrapDoc <$> vsconcat e1 + | otherwise = throwError "Maximum retries exceeded" + +-- | Validation-like version of 'sconcat'. +vsconcat + :: NonEmpty (Either String (Object a, IsTouched)) + -> Either String (Object a, IsTouched) +vsconcat = foldr1 vappend + where + vappend (Left e1) (Left e2) = Left $ e1 ++ "\n" ++ e2 + vappend e1@(Left _ ) (Right _ ) = e1 + vappend (Right _ ) e2@(Left _ ) = e2 + vappend (Right r1) (Right r2) = + (, IsTouched (t1 || t2)) <$> reduceObject a1 a2 where + (a1, IsTouched t1) = r1 + (a2, IsTouched t2) = r2 + +try :: MonadError e m => m a -> m (Either e a) +try ma = (Right <$> ma) `catchError` (pure . Left) + +fmapL :: (a -> b) -> Either a c -> Either b c +fmapL f = \case + Left a -> Left $ f a + Right c -> Right c + +-- | Load document, apply changes and put it back to storage +modify + :: (Collection a, MonadStorage m) + => DocId a -> StateT (Object a) m () -> m (Object a) +modify docid f = do + oldDoc <- loadDocument docid + 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 objectId) [] + Just (docid, oldDoc) -> do + let Document{value = oldObj, versions, isTouched = IsTouched isTouched} + = oldDoc + when (newObj /= oldObj || length versions /= 1 || isTouched) $ + save docid versions + where + Object{objectId, objectFrame} = newObj + + save docid oldVersions = do + newVersion <- UUID.encodeBase32 <$> getEventUuid + saveVersionContent docid newVersion (serializeStateFrame objectFrame) + for_ oldVersions $ deleteVersion docid + +-- | Create document assuming it doesn't exist yet. +createDocument :: (Collection a, MonadStorage m) => Object a -> m () +createDocument = createVersion Nothing diff --git a/lib/RON/Storage/IO.hs b/lib/RON/Storage/IO.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Storage/IO.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# 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, + Storage, + newHandle, + runStorage, +) where + +import Control.Exception (catch, throwIO) +import Control.Monad (filterM, unless, when) +import Control.Monad.Except (ExceptT (ExceptT), MonadError, + runExceptT, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ReaderT (ReaderT), ask, runReaderT) +import Control.Monad.Trans (lift) +import Data.Bits (shiftL) +import qualified Data.ByteString.Lazy as BSL +import Data.IORef (IORef, newIORef) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Word (Word64) +import Network.Info (MAC (MAC), getNetworkInterfaces, mac) +import RON.Epoch (EpochClock, getCurrentEpochTime, runEpochClock) +import RON.Event (EpochTime, ReplicaClock, ReplicaId, advance, + applicationSpecific, getEvents, getPid) +import System.Directory (canonicalizePath, createDirectoryIfMissing, + doesDirectoryExist, doesPathExist, + listDirectory, removeFile, renameDirectory) +import System.FilePath (()) +import System.IO.Error (isDoesNotExistError) + +import RON.Storage as X + +-- | Environment is the dataDir +newtype Storage a = Storage (ExceptT String (ReaderT FilePath EpochClock) a) + deriving (Applicative, Functor, Monad, MonadError String, MonadIO) + +-- | Run a 'Storage' action +runStorage :: Handle -> Storage a -> IO a +runStorage Handle{hReplica, hDataDir, hClock} (Storage action) = do + res <- + runEpochClock hReplica hClock $ + (`runReaderT` hDataDir) $ + runExceptT action + either fail 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 + dataDir <- ask + liftIO $ + listDirectory dataDir + >>= filterM (doesDirectoryExist . (dataDir )) + + getDocuments :: forall doc. Collection doc => Storage [DocId doc] + getDocuments = map DocId <$> listDirectoryIfExists (collectionName @doc) + + getDocumentVersions = listDirectoryIfExists . docDir + + saveVersionContent docid version content = + Storage $ do + dataDir <- ask + let docdir = dataDir docDir docid + liftIO $ do + createDirectoryIfMissing True docdir + BSL.writeFile (docdir version) content + + loadVersionContent docid version = Storage $ do + dataDir <- ask + liftIO $ BSL.readFile $ dataDir docDir docid version + + deleteVersion docid version = Storage $ do + dataDir <- ask + liftIO $ do + let file = dataDir docDir docid version + removeFile file + `catch` \e -> + unless (isDoesNotExistError e) $ throwIO e + + changeDocId old new = Storage $ do + db <- ask + let oldPath = db docDir old + newPath = db docDir new + oldPathCanon <- liftIO $ canonicalizePath oldPath + newPathCanon <- liftIO $ canonicalizePath newPath + when (newPathCanon /= oldPathCanon) $ do + newPathExists <- liftIO $ doesPathExist newPath + when newPathExists $ + throwError $ unwords + [ "changeDocId" + , show old, "[", oldPath, "->", oldPathCanon, "]" + , show new, "[", newPath, "->", newPathCanon, "]" + , ": internal error: new document id is already taken" + ] + when (newPath /= oldPath) $ + liftIO $ renameDirectory oldPath newPath + +-- | Storage handle (uses the “Handle pattern”). +data Handle = Handle + { hClock :: IORef EpochTime + , hDataDir :: FilePath + , hReplica :: ReplicaId + } + +-- | Create new storage handle +newHandle :: FilePath -> IO Handle +newHandle hDataDir = do + time <- getCurrentEpochTime + hClock <- newIORef time + hReplica <- applicationSpecific <$> getMacAddress + pure Handle{hDataDir, hClock, hReplica} + +listDirectoryIfExists :: FilePath -> Storage [FilePath] +listDirectoryIfExists relpath = Storage $ do + 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 (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 diff --git a/lib/RON/Storage/Test.hs b/lib/RON/Storage/Test.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Storage/Test.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module RON.Storage.Test (TestDB, runStorageSim) where + +import Control.Monad.Except (ExceptT, MonadError, runExceptT) +import Control.Monad.State.Strict (StateT, get, gets, modify, + runStateT) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Functor.Compose (Compose (Compose), getCompose) +import Data.Map.Strict (Map, (!), (!?)) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import RON.Event (ReplicaClock, applicationSpecific) +import RON.Event.Simulation (ReplicaSim, runNetworkSim, runReplicaSim) + +import RON.Storage (Collection, CollectionName, DocId (DocId), + DocVersion, MonadStorage, changeDocId, + collectionName, deleteVersion, getCollections, + getDocumentVersions, getDocuments, + loadVersionContent, saveVersionContent) + +type ByteStringL = BSL.ByteString + +type TestDB = Map CollectionName (Map DocumentId (Map DocVersion Document)) + +type Document = [ByteStringL] + +type DocumentId = FilePath + +-- * Storage simulation + +newtype StorageSim a = StorageSim (StateT TestDB (ExceptT String ReplicaSim) a) + deriving (Applicative, Functor, Monad, MonadError String, ReplicaClock) + +runStorageSim :: TestDB -> StorageSim a -> Either String (a, TestDB) +runStorageSim db (StorageSim action) = + runNetworkSim $ runReplicaSim (applicationSpecific 34) $ + runExceptT $ runStateT action db + +instance MonadStorage StorageSim where + getCollections = StorageSim $ gets Map.keys + + getDocuments :: forall a . Collection a => StorageSim [DocId a] + getDocuments = StorageSim $ do + db <- get + pure $ map DocId $ Map.keys $ db !. collectionName @a + + getDocumentVersions (DocId doc :: DocId a) = StorageSim $ do + db <- get + pure $ Map.keys $ db !. collectionName @a !. doc + + saveVersionContent (DocId docid :: DocId a) version content = do + let document = BSLC.lines content + let insertDocumentVersion = + Just . Map.insertWith (<>) version document . fromMaybe mempty + let alterDocument + = Just + . Map.alter insertDocumentVersion docid + . fromMaybe mempty + let alterCollection = Map.alter alterDocument (collectionName @a) + StorageSim $ modify alterCollection + + loadVersionContent (DocId dir :: DocId a) version = StorageSim $ do + db <- get + pure $ BSLC.unlines $ db !. collectionName @a !. dir ! version + + deleteVersion (DocId doc :: DocId a) version + = StorageSim + . modify + . (`Map.adjust` collectionName @a) + . (`Map.adjust` doc) + $ Map.delete version + + changeDocId (DocId old :: DocId a) (DocId new :: DocId a) = StorageSim $ + modify $ (`Map.adjust` collectionName @a) $ \collection -> + maybe collection (uncurry $ Map.insert new) $ + mapTake old collection + +(!.) :: Ord a => Map a (Map b c) -> a -> Map b c +m !. a = fromMaybe Map.empty $ m !? a + +mapTake :: Ord k => k -> Map k a -> Maybe (a, Map k a) +mapTake k = getCompose . Map.alterF (Compose . f) k where + f = \case + Nothing -> Nothing + Just a -> Just (a, Nothing) diff --git a/lib/RON/Text/Parse.hs b/lib/RON/Text/Parse.hs --- a/lib/RON/Text/Parse.hs +++ b/lib/RON/Text/Parse.hs @@ -26,9 +26,9 @@ label, manyTill, parseOnlyL, satisfy, (<+>), (??)) import qualified Data.Aeson as Json +import Data.Attoparsec.ByteString (takeWhile1) import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, double, - signed, skipSpace, takeWhile, - takeWhile1) + signed, skipSpace, takeWhile) import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC @@ -183,9 +183,9 @@ guard $ BS.length rawX == 11 x <- Base64.decode64 rawX ?? fail "Base64.decode64" skipSpace - rawScheme <- optional pScheme - rawOrigin <- optional $ base64word $ maybe 11 (const 10) rawScheme - y <- case (rawScheme, BS.length <$> rawOrigin) of + rawUuidVersion <- optional pUuidVersion + rawOrigin <- optional $ base64word $ maybe 11 (const 10) rawUuidVersion + y <- case (rawUuidVersion, BS.length <$> rawOrigin) of (Nothing, Just 11) -> case rawOrigin of Nothing -> pure 0 @@ -194,7 +194,7 @@ origin <- case rawOrigin of Nothing -> pure $ ls60 0 Just origin -> Base64.decode60 origin ?? fail "Base64.decode60" - pure $ UUID.buildY b00 (fromMaybe b00 rawScheme) origin + pure $ UUID.buildY b00 (fromMaybe b00 rawUuidVersion) origin pure $ UUID x y data UuidZipBase = PrevOpSameKey | SameOpPrevUuid @@ -206,7 +206,7 @@ rawReuseValue <- optional pReuse rawValue <- optional $ base64word60 $ 10 - fromMaybe 0 rawReuseValue skipSpace - rawScheme <- optional pScheme + rawUuidVersion <- optional pUuidVersion rawReuseOrigin <- optional pReuse rawOrigin <- optional $ base64word60 $ 10 - fromMaybe 0 rawReuseOrigin @@ -216,7 +216,7 @@ || ( not changeZipBase && isNothing rawReuseValue && isJust rawValue && isNothing rawReuseOrigin - && (isNothing rawScheme || isJust rawOrigin) + && (isNothing rawUuidVersion || isJust rawOrigin) ) if isSimple then @@ -224,14 +224,14 @@ { uuidVariety = fromMaybe b0000 rawVariety , uuidValue = fromMaybe (ls60 0) rawValue , uuidVariant = b00 - , uuidScheme = fromMaybe b00 rawScheme + , uuidVersion = fromMaybe b00 rawUuidVersion , uuidOrigin = fromMaybe (ls60 0) rawOrigin } else do uuidVariety <- pure $ fromMaybe (uuidVariety prev) rawVariety uuidValue <- pure $ reuse rawReuseValue rawValue (uuidValue prev) let uuidVariant = b00 - uuidScheme <- pure $ fromMaybe (uuidScheme prev) rawScheme + uuidVersion <- pure $ fromMaybe (uuidVersion prev) rawUuidVersion uuidOrigin <- pure $ reuse rawReuseOrigin rawOrigin (uuidOrigin prev) pure $ UUID.build UuidFields{..} @@ -293,14 +293,14 @@ letter <- satisfy isUpperHexDigit <* "/" Base64.decodeLetter4 letter ?? fail "Base64.decodeLetter4" -pScheme :: Parser Word2 -pScheme = label "scheme" $ +pUuidVersion :: Parser Word2 +pUuidVersion = label "UUID-version" $ anyChar >>= \case '$' -> pure b00 '%' -> pure b01 '+' -> pure b10 '-' -> pure b11 - _ -> fail "not a scheme" + _ -> fail "not a UUID-version" payload :: UUID -> Parser [Atom] payload = label "payload" . go diff --git a/lib/RON/Text/Serialize/UUID.hs b/lib/RON/Text/Serialize/UUID.hs --- a/lib/RON/Text/Serialize/UUID.hs +++ b/lib/RON/Text/Serialize/UUID.hs @@ -83,10 +83,10 @@ B0000 -> "" _ -> BS.singleton (Base64.encodeLetter4 uuidVariety) <> "/" x' = variety <> Base64.encode60short uuidValue - y' = case (uuidScheme, uuidOrigin) of + y' = case (uuidVersion, uuidOrigin) of (B00, safeCast -> 0 :: Word64) -> "" _ -> - serializeScheme uuidScheme + serializeVersion uuidVersion `BSC.cons` Base64.encode60short uuidOrigin zipUuid :: UuidFields -> UuidFields -> Maybe ByteString @@ -116,8 +116,8 @@ 0 -> "" w -> Base64.encode60short $ ls60 w -serializeScheme :: Word2 -> Char -serializeScheme = \case +serializeVersion :: Word2 -> Char +serializeVersion = \case B00 -> '$' B01 -> '%' B10 -> '+' diff --git a/lib/RON/UUID.hs b/lib/RON/UUID.hs --- a/lib/RON/UUID.hs +++ b/lib/RON/UUID.hs @@ -67,11 +67,11 @@ B0000 -> "" _ -> chr (fromIntegral $ Base64.encodeLetter4 uuidVariety) : "/" x' = variety <> BSC.unpack (Base64.encode60short uuidValue) - y' = case (uuidScheme, uuidOrigin) of + y' = case (uuidVersion, uuidOrigin) of (B00, safeCast -> 0 :: Word64) -> "" - _ -> scheme : BSC.unpack (Base64.encode60short uuidOrigin) + _ -> version : BSC.unpack (Base64.encode60short uuidOrigin) generic = BSC.unpack $ Base64.encode64 x <> Base64.encode64 y - scheme = case uuidScheme of + version = case uuidVersion of B00 -> '$' B01 -> '%' B10 -> '+' @@ -82,7 +82,7 @@ { uuidVariety :: !Word4 , uuidValue :: !Word60 , uuidVariant :: !Word2 - , uuidScheme :: !Word2 + , uuidVersion :: !Word2 , uuidOrigin :: !Word60 } deriving (Eq, Show) @@ -93,7 +93,7 @@ { uuidVariety = leastSignificant4 $ x `shiftR` 60 , uuidValue = leastSignificant60 x , uuidVariant = leastSignificant2 $ y `shiftR` 62 - , uuidScheme = leastSignificant2 $ y `shiftR` 60 + , uuidVersion = leastSignificant2 $ y `shiftR` 60 , uuidOrigin = leastSignificant60 y } @@ -101,7 +101,7 @@ build :: UuidFields -> UUID build UuidFields{..} = UUID (buildX uuidVariety uuidValue) - (buildY uuidVariant uuidScheme uuidOrigin) + (buildY uuidVariant uuidVersion uuidOrigin) -- | Build former 64 bits of UUID from parts buildX :: Word4 -> Word60 -> Word64 @@ -110,30 +110,32 @@ -- | Build latter 64 bits of UUID from parts buildY :: Word2 -> Word2 -> Word60 -> Word64 -buildY uuidVariant uuidScheme uuidOrigin +buildY uuidVariant uuidVersion uuidOrigin = (safeCast uuidVariant `shiftL` 62) - .|. (safeCast uuidScheme `shiftL` 60) + .|. (safeCast uuidVersion `shiftL` 60) .|. safeCast uuidOrigin -- | Make an unscoped (unqualified) name mkName - :: ByteString -- ^ name, max 10 Base64 letters - -> Maybe UUID + :: Monad m + => ByteString -- ^ name, max 10 Base64 letters + -> m UUID mkName nam = mkScopedName nam "" -- | Make a scoped (qualified) name mkScopedName - :: ByteString -- ^ scope, max 10 Base64 letters + :: Monad m + => ByteString -- ^ scope, max 10 Base64 letters -> ByteString -- ^ local name, max 10 Base64 letters - -> Maybe UUID + -> m UUID mkScopedName scope nam = do - scope' <- Base64.decode60 scope - nam' <- Base64.decode60 nam + scope' <- maybe (fail "Bad scope") pure $ Base64.decode60 scope + nam' <- maybe (fail "Bad name") pure $ Base64.decode60 nam pure $ build UuidFields { uuidVariety = B0000 , uuidValue = scope' , uuidVariant = B00 - , uuidScheme = B00 + , uuidVersion = B00 , uuidOrigin = nam' } @@ -143,7 +145,7 @@ -> Maybe (ByteString, ByteString) -- ^ @(scope, name)@ for a scoped name; @(name, "")@ for a global name getName uuid = case split uuid of - UuidFields{uuidVariety = B0000, uuidVariant = B00, uuidScheme = B00, ..} -> + UuidFields{uuidVariety = B0000, uuidVariant = B00, uuidVersion = B00, ..} -> Just (x, y) where x = Base64.encode60short uuidValue diff --git a/ron.cabal b/ron.cabal --- a/ron.cabal +++ b/ron.cabal @@ -1,21 +1,49 @@ cabal-version: 2.2 name: ron -version: 0.1 +version: 0.2 +bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database copyright: 2018 Yuriy Syrovetskiy -description: Replicated Object Notation (RON), data types (RDT), - and RON-Schema +homepage: https://github.com/ff-notes/ron license: BSD-3-Clause +license-file: LICENSE maintainer: Yuriy Syrovetskiy synopsis: RON, RON-RDT, and RON-Schema +description: + Replicated Object Notation (RON), data types (RDT), and RON-Schema + . + Typical usage: + . + > import RON.Data + > import RON.Schema.TH + > import RON.Storage.IO as Storage + > + > $(let note = StructLww "Note" + > [ ("active", field boole) + > , ("text", field rgaString) ] + > def{saHaskellDeriving = ["Eq", "Show"]} + > in mkReplicated [DStructLww note]) + > + > instance Collection Note where + > collectionName = "note" + > + > main :: IO () + > main = do + > let dataDir = "./data/" + > h <- Storage.newHandle dataDir + > runStorage h $ do + > obj <- newObject + > Note{active = True, text = "Выступить на FProg SPb"} + > createDocument obj + build-type: Simple common language build-depends: - base >= 4.11.1.0 && < 4.12, + base >= 4.10 && < 4.13, default-extensions: StrictData default-language: Haskell2010 @@ -30,10 +58,13 @@ data-default, deepseq, Diff, + directory, errors, extra, + filepath, hashable, mtl, + network-info, safe, stringsearch, template-haskell, @@ -61,6 +92,9 @@ RON.Internal.Word RON.Schema RON.Schema.TH + RON.Storage + RON.Storage.IO + RON.Storage.Test RON.Text RON.Text.Parse RON.Text.Serialize