ron 0.1 → 0.2
raw patch · 16 files changed
+657/−116 lines, 16 filesdep +directorydep +filepathdep +network-infodep ~base
Dependencies added: directory, filepath, network-info
Dependency ranges changed: base
Files
- LICENSE +29/−0
- lib/RON/Base64.hs +21/−15
- lib/RON/Data.hs +2/−1
- lib/RON/Data/Internal.hs +21/−3
- lib/RON/Data/RGA.hs +22/−32
- lib/RON/Event.hs +4/−4
- lib/RON/Event/Simulation.hs +8/−11
- lib/RON/Schema.hs +4/−0
- lib/RON/Schema/TH.hs +7/−13
- lib/RON/Storage.hs +208/−0
- lib/RON/Storage/IO.hs +166/−0
- lib/RON/Storage/Test.hs +92/−0
- lib/RON/Text/Parse.hs +13/−13
- lib/RON/Text/Serialize/UUID.hs +4/−4
- lib/RON/UUID.hs +18/−16
- ron.cabal +38/−4
+ LICENSE view
@@ -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.
lib/RON/Base64.hs view
@@ -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) .|.
lib/RON/Data.hs view
@@ -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
lib/RON/Data/Internal.hs view
@@ -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"
lib/RON/Data/RGA.hs view
@@ -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
lib/RON/Event.hs view
@@ -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
lib/RON/Event/Simulation.hs view
@@ -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)
lib/RON/Schema.hs view
@@ -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"}
lib/RON/Schema/TH.hs view
@@ -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
+ lib/RON/Storage.hs view
@@ -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
+ lib/RON/Storage/IO.hs view
@@ -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
+ lib/RON/Storage/Test.hs view
@@ -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)
lib/RON/Text/Parse.hs view
@@ -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
lib/RON/Text/Serialize/UUID.hs view
@@ -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 -> '+'
lib/RON/UUID.hs view
@@ -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
ron.cabal view
@@ -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 <haskell@cblp.su> 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