ron 0.3 → 0.4
raw patch · 8 files changed
+248/−207 lines, 8 filesdep −data-default
Dependencies removed: data-default
Files
- lib/RON/Data/RGA.hs +8/−1
- lib/RON/Data/Time.hs +2/−2
- lib/RON/Schema.hs +21/−55
- lib/RON/Schema/EDN.hs +65/−73
- lib/RON/Schema/TH.hs +55/−14
- lib/RON/Storage.hs +23/−15
- lib/RON/Storage/IO.hs +67/−39
- ron.cabal +7/−8
lib/RON/Data/RGA.hs view
@@ -347,7 +347,7 @@ advanceToUuid stateVersion let newItems' = [Op Zero Zero $ toPayload item | item <- newItems]- let diff = getGroupedDiffBy ((==) `on` opPayload) stateBody newItems'+ let diff = getGroupedDiffBy eqAliveOnPayload stateBody newItems' (stateBody', Last lastEvent) <- runWriterT . fmap concat . for diff $ \case First removed -> for removed $ \case op@Op{opRef = Zero} -> do -- not deleted yet@@ -373,6 +373,13 @@ Map.insert (rgaType, objectId) state' objectFrame , .. }++ where+ eqAliveOnPayload+ Op{opRef = Zero, opPayload = p1}+ Op{opRef = Zero, opPayload = p2}+ = p1 == p2+ eqAliveOnPayload _ _ = False -- | Speciaization of 'edit' for 'Text' editText
lib/RON/Data/Time.hs view
@@ -10,7 +10,7 @@ import RON.Data (Replicated (..), ReplicatedAsPayload (..), payloadEncoding)-import RON.Schema (OpaqueAnnotations (..), RonType, def, opaqueAtoms)+import RON.Schema (RonType, opaqueAtoms_) import RON.Types (Atom (..)) instance Replicated Day where encoding = payloadEncoding@@ -28,4 +28,4 @@ -- | RON-Schema type for 'Day' day :: RonType-day = opaqueAtoms "Day" def{oaHaskellType = Just "Day"}+day = opaqueAtoms_ "Day"
lib/RON/Schema.hs view
@@ -1,12 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} module RON.Schema ( CaseTransform (..), Declaration (..), Field (..),- FieldAnnotations (..), Opaque (..), OpaqueAnnotations (..), RonType (..),@@ -14,26 +11,19 @@ StructAnnotations (..), StructLww (..), TAtom (..),+ TEnum (..), TComposite (..), TObject (..),- atomInteger,- atomString,- boole,- char,- def,- field,+ defaultOpaqueAnnotations,+ defaultStructAnnotations, opaqueAtoms,+ opaqueAtoms_, opaqueObject,- option,- orSet,- rgaString,- structLww,- versionVector, ) where import RON.Internal.Prelude -import Data.Default (Default, def)+import qualified Data.Text as Text data TAtom = TAInteger | TAString deriving (Show)@@ -45,10 +35,14 @@ | TOpaque Opaque deriving (Show) -newtype TComposite+data TComposite = TOption RonType+ | TEnum TEnum deriving (Show) +data TEnum = Enum {enumName :: Text, enumItems :: [Text]}+ deriving (Show)+ data TObject = TORSet RonType | TRga RonType@@ -69,35 +63,25 @@ } deriving (Show) -data CaseTransform = TitleCase- deriving (Show)--instance Default StructAnnotations where def = StructAnnotations "" Nothing+defaultStructAnnotations :: StructAnnotations+defaultStructAnnotations = StructAnnotations+ {saHaskellFieldPrefix = Text.empty, saHaskellFieldCaseTransform = Nothing} -data Field = Field{fieldType :: RonType, fieldAnnotations :: FieldAnnotations}+data CaseTransform = TitleCase deriving (Show) -field :: RonType -> Field-field fieldType = Field{fieldType, fieldAnnotations = def}--data FieldAnnotations = FieldAnnotations+newtype Field = Field{fieldType :: RonType} deriving (Show) -instance Default FieldAnnotations where- def = FieldAnnotations--data Declaration = DOpaque Opaque | DStructLww StructLww+data Declaration = DEnum TEnum | DOpaque Opaque | DStructLww StructLww type Schema = [Declaration] newtype OpaqueAnnotations = OpaqueAnnotations{oaHaskellType :: Maybe Text}- deriving (Default, Show)--char :: RonType-char = opaqueAtoms "Char" def{oaHaskellType = Just "Char"}+ deriving (Show) -rgaString :: RonType-rgaString = TObject $ TRga char+defaultOpaqueAnnotations :: OpaqueAnnotations+defaultOpaqueAnnotations = OpaqueAnnotations{oaHaskellType = Nothing} data Opaque = Opaque { opaqueIsObject :: Bool@@ -112,23 +96,5 @@ opaqueAtoms :: Text -> OpaqueAnnotations -> RonType opaqueAtoms name = TOpaque . Opaque False name -option :: RonType -> RonType-option = TComposite . TOption--structLww :: StructLww -> RonType-structLww = TObject . TStructLww--atomString :: RonType-atomString = TAtom TAString--atomInteger :: RonType-atomInteger = TAtom TAInteger--orSet :: RonType -> RonType-orSet = TObject . TORSet--versionVector :: RonType-versionVector = TObject TVersionVector--boole :: RonType-boole = opaqueAtoms "Boole" def{oaHaskellType = Just "Bool"}+opaqueAtoms_ :: Text -> RonType+opaqueAtoms_ name = TOpaque $ Opaque False name defaultOpaqueAnnotations
lib/RON/Schema/EDN.hs view
@@ -26,6 +26,7 @@ import Data.Text.Lazy.Builder (toLazyText) import qualified Data.Text.Lazy.Encoding as TextL +import RON.Data.Time (day) import RON.Schema newtype Env = Env {knownTypes :: Map Text RonType}@@ -34,112 +35,102 @@ startEnv :: Env startEnv = Env { knownTypes = Map.fromList- [ ("AtomInteger", atomInteger)- , ("AtomString", atomString)- , ("RgaString", rgaString)- , ("VersionVector", versionVector)+ [ ("Boole",+ opaqueAtoms "Boole" OpaqueAnnotations{oaHaskellType = Just "Bool"})+ , ("Day", day)+ , ("Integer", TAtom TAInteger)+ , ("RgaString", TObject $ TRga char)+ , ("String", TAtom TAString)+ , ("VersionVector", TObject TVersionVector) ] }+ where+ char = opaqueAtoms "Char" OpaqueAnnotations{oaHaskellType = Just "Char"} type Parser' = StateT Env Parser parseDeclaration :: Tagged Value -> Parser' Declaration parseDeclaration = withNoTag $ withList "declaration" $ \case- func : args -> do- func' <- withNoTag pure func- withSymbol "declaration name symbol" (go args) func'+ func : args -> go =<< parseText "declaration name" func+ where+ go = \case+ "enum" -> DEnum <$> parseEnum args+ "opaque" -> DOpaque <$> parseOpaque args+ "struct_lww" -> DStructLww <$> parseStructLww args+ name -> fail $ "unknown declaration " ++ Text.unpack name [] -> fail "empty declaration"- where- go args = withNoPrefix "declaration name" $ \case- "opaque" -> DOpaque <$> parseOpaque args- "struct_lww" -> DStructLww <$> parseStructLww args- name -> fail $ "unknown declaration " ++ decodeUtf8 name +parseEnum :: EDNList -> Parser' TEnum+parseEnum code = do+ enum <- case code of+ name : items -> Enum+ <$> parseText "enum name" name+ <*> traverse (parseText "enum item") items+ [] -> fail+ "Expected declaration in the form\+ \ (enum <name:symbol> <item:symbol>...)"+ insertKnownType (enumName enum) (TComposite $ TEnum enum)+ pure enum+ parseOpaque :: EDNList -> Parser' Opaque parseOpaque code = do- opaque@Opaque{opaqueName} <- case code of- kind' : name : annotations -> do- kind <- parseKind kind'- case kind of+ opaque <- case code of+ kind : name : annotations ->+ parseText "opaque kind" kind >>= \case "atoms" -> go False "object" -> go True _ -> fail "opaque kind must be either atoms or object" where go isObject =- Opaque isObject <$> parseName name <*> parseAnnotations- parseKind =- withNoTag $- withSymbol "opaque kind symbol" $- withNoPrefix "opaque kind" pure- parseName =- withNoTag $- withSymbol "opaque name symbol" $- withNoPrefix "opaque name" $- pure . Text.decodeUtf8+ Opaque+ isObject+ <$> parseText "opaque name" name+ <*> parseAnnotations parseAnnotations = case annotations of- [] -> pure def+ [] -> pure defaultOpaqueAnnotations _ -> fail "opaque annotations are not implemented yet" _ -> fail "Expected declaration in the form\ \ (opaque <kind:symbol> <name:symbol> <annotations>...)"- env@Env{knownTypes} <- get- case Map.lookup opaqueName knownTypes of- Nothing ->- put env { knownTypes =- Map.insert opaqueName (TOpaque opaque) knownTypes- }- Just _ ->- fail $ "duplicate declaration of type " ++ Text.unpack opaqueName+ insertKnownType (opaqueName opaque) (TOpaque opaque) pure opaque +insertKnownType :: Text -> RonType -> Parser' ()+insertKnownType name typ = do+ env@Env{knownTypes} <- get+ case Map.lookup name knownTypes of+ Nothing -> put env{knownTypes = Map.insert name typ knownTypes}+ Just _ -> fail $ "duplicate declaration of type " ++ Text.unpack name+ parseStructLww :: EDNList -> Parser' StructLww parseStructLww code = do- struct@StructLww{structName} <- case code of+ struct <- case code of name : body -> do let (annotations, fields) = span isTagged body StructLww- <$> parseName name+ <$> parseText "struct_lww name" name <*> parseFields fields <*> parseAnnotations annotations [] -> fail "Expected declaration in the form\ \ (struct_lww <name:symbol> <annotations>... <fields>...)"- env@Env{knownTypes} <- get- case Map.lookup structName knownTypes of- Nothing ->- put env { knownTypes =- Map.insert structName (structLww struct) knownTypes- }- Just _ ->- fail $ "duplicate declaration of type " ++ Text.unpack structName+ insertKnownType (structName struct) (TObject $ TStructLww struct) pure struct where - parseName =- withNoTag $- withSymbol "struct_lww name symbol" $- withNoPrefix "struct_lww name" $- pure . Text.decodeUtf8- parseFields = \case [] -> pure mempty nameAsTagged : typeAsTagged : cont -> do- name <- parseFieldName nameAsTagged+ name <- parseText "struct_lww field name" nameAsTagged typ <- parseType typeAsTagged- Map.insert name (Field typ FieldAnnotations) <$> parseFields cont+ Map.insert name (Field typ) <$> parseFields cont [f] -> fail $ "field " ++ showEdn f ++ " must have type"- where- parseFieldName =- withNoTag $- withSymbol "struct_lww field name symbol" $- withNoPrefix "struct_lww field name" $- pure . Text.decodeUtf8 parseAnnotations annTaggedValues = do annValues <- traverse unwrapTag annTaggedValues case lookup "haskell" annValues of- Nothing -> pure def+ Nothing -> pure defaultStructAnnotations Just annValue -> withMap "struct_lww haskell annotations map" go annValue where@@ -153,11 +144,9 @@ <$> m .:? Symbol "" "field_prefix" .!= "" <*> (m .:? Symbol "" "field_case" >>= traverse parseCaseTransform) -parseCaseTransform :: Value -> Parser CaseTransform-parseCaseTransform =- (runIdentityT .) $- withSymbol "case transformation symbol" $- withNoPrefix "case transformation" $ \case+parseCaseTransform :: Tagged Value -> Parser CaseTransform+parseCaseTransform v =+ runIdentityT (parseText "case transformation" v) >>= \case "title" -> pure TitleCase _ -> fail "unknown case transformation" @@ -191,17 +180,13 @@ func : args -> applyType func =<< traverse parseType args applyType :: Tagged Value -> [RonType] -> Parser' RonType-applyType func args =- withNoTag- (withSymbol "parametric type symbol" $- withNoPrefix "parametric type" go)- func+applyType func args = parseText "parametric type" func >>= go where go = \case- "Option" -> apply "Option" option- "ORSet" -> apply "ORSet" orSet- name -> fail $ "unknown parametric type " ++ decodeUtf8 name+ "Option" -> apply "Option" $ TComposite . TOption+ "ORSet" -> apply "ORSet" $ TObject . TORSet+ name -> fail $ "unknown parametric type " ++ Text.unpack name apply name wrapper = case args of [a] -> pure $ wrapper a@@ -239,6 +224,13 @@ withSymbol expected f = \case Symbol prefix symbol -> f prefix symbol value -> lift $ typeMismatch expected value++parseText+ :: (MonadTrans t, Monad (t Parser))+ => String -> Tagged Value -> t Parser Text+parseText name =+ withNoTag $ withSymbol (name ++ " symbol") $ withNoPrefix name $+ pure . Text.decodeUtf8 -- * ByteString helpers
lib/RON/Schema/TH.hs view
@@ -20,16 +20,18 @@ import Data.Char (toTitle) import qualified Data.Map.Strict as Map import qualified Data.Text as Text-import Language.Haskell.TH (Exp (VarE), bindS, conE, conP, conT,- dataD, doE, letS, listE, noBindS, recC,- recConE, sigD, varE, varP, varT)+import qualified Data.Text.Encoding as Text+import GHC.Stack (HasCallStack)+import Language.Haskell.TH (Exp (VarE), bindS, conE, conP, conT, doE,+ lamCaseE, letS, listE, noBindS, normalB,+ recC, recConE, sigD, varE, varP, varT) import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter), quoteDec, quoteExp, quotePat, quoteType)-import Language.Haskell.TH.Syntax (lift, liftData)+import Language.Haskell.TH.Syntax (dataToPatQ, lift, liftData) import RON.Data (Replicated (..), ReplicatedAsObject (..),- objectEncoding)+ ReplicatedAsPayload (..), objectEncoding) import RON.Data.Internal (getObjectStateChunk) import RON.Data.LWW (lwwType) import qualified RON.Data.LWW as LWW@@ -42,16 +44,17 @@ import RON.Types (Object (..), UUID) import qualified RON.UUID as UUID -mkReplicated :: QuasiQuoter+mkReplicated :: HasCallStack => QuasiQuoter mkReplicated = QuasiQuoter{quoteDec, quoteExp = e, quotePat = e, quoteType = e} where e = error "declaration only" quoteDec = EDN.parseSchema >=> mkReplicated' -- | Generate Haskell types from RON-Schema-mkReplicated' :: Schema -> TH.DecsQ+mkReplicated' :: HasCallStack => Schema -> TH.DecsQ mkReplicated' = fmap fold . traverse fromDecl where fromDecl decl = case decl of+ DEnum e -> mkEnum e DOpaque _ -> pure [] DStructLww s -> mkReplicatedStructLww s @@ -92,7 +95,7 @@ , field'Var :: TH.Name } -mkReplicatedStructLww :: StructLww -> TH.DecsQ+mkReplicatedStructLww :: HasCallStack => StructLww -> TH.DecsQ mkReplicatedStructLww struct = do fields <- for (Map.assocs structFields) $ \(field'Name, Field{fieldType}) -> case UUID.mkName . BSC.pack $ Text.unpack field'Name of@@ -120,12 +123,11 @@ objectT = [t| Object $structT |] - mkDataType = dataD (TH.cxt []) name [] Nothing+ mkDataType = TH.dataD (TH.cxt []) name [] Nothing [recC name [ TH.varBangType (mkNameT $ mkHaskellFieldName fieldName) $ TH.bangType (TH.bang TH.sourceNoUnpack TH.sourceStrict) viewType- | (fieldName, Field fieldType FieldAnnotations) <-- Map.assocs structFields+ | (fieldName, Field fieldType) <- Map.assocs structFields , let viewType = mkViewType fieldType ]] []@@ -232,13 +234,14 @@ mkNameT :: Text -> TH.Name mkNameT = TH.mkName . Text.unpack -mkViewType :: RonType -> TH.TypeQ+mkViewType :: HasCallStack => RonType -> TH.TypeQ mkViewType = \case TAtom atom -> case atom of TAInteger -> [t| Int64 |] TAString -> [t| Text |] TComposite t -> case t of- TOption u -> [t| Maybe $(mkViewType u) |]+ TEnum Enum{enumName} -> conT $ mkNameT enumName+ TOption u -> [t| Maybe $(mkViewType u) |] TObject t -> case t of TORSet item -> wrapList item TRga item -> wrapList item@@ -251,7 +254,7 @@ wrapList a = [t| [$(mkViewType a)] |] valD' :: TH.Name -> TH.ExpQ -> TH.DecQ-valD' name body = TH.valD (varP name) (TH.normalB body) []+valD' name body = TH.valD (varP name) (normalB body) [] isObjectType :: RonType -> Bool isObjectType = \case@@ -259,3 +262,41 @@ TComposite _ -> False TObject _ -> True TOpaque Opaque{opaqueIsObject} -> opaqueIsObject++mkEnum :: TEnum -> TH.DecsQ+mkEnum Enum{enumName, enumItems} = do+ itemsUuids <- for enumItems $ \item -> do+ uuid <- UUID.mkName $ Text.encodeUtf8 item+ pure (mkNameT item, uuid)+ dataType <- mkDataType+ [instanceReplicated] <- mkInstanceReplicated+ [instanceReplicatedAsPayload] <- mkInstanceReplicatedAsPayload itemsUuids+ pure [dataType, instanceReplicated, instanceReplicatedAsPayload]++ where++ typeName = conT $ mkNameT enumName++ mkDataType = TH.dataD (TH.cxt []) (mkNameT enumName) [] Nothing+ [TH.normalC (mkNameT item) [] | item <- enumItems] []++ mkInstanceReplicated = [d|+ instance Replicated $typeName where+ encoding = payloadEncoding+ |]++ mkInstanceReplicatedAsPayload itemsUuids = [d|+ instance ReplicatedAsPayload $typeName where+ toPayload = toPayload . $toUuid+ fromPayload = fromPayload >=> $fromUuid+ |]+ where+ toUuid = lamCaseE+ [match (conP name []) (liftData uuid) | (name, uuid) <- itemsUuids]+ fromUuid = lamCaseE+ $ [ match (liftDataP uuid) [| pure $(conE name) |]+ | (name, uuid) <- itemsUuids+ ]+ ++ [match TH.wildP [| fail "expected one of enum items" |]]+ liftDataP = dataToPatQ $ const Nothing+ match pat body = TH.match pat (normalB body) []
lib/RON/Storage.hs view
@@ -7,19 +7,20 @@ {-# LANGUAGE TypeApplications #-} -- | RON File Storage. For usage, see "RON.Storage.IO".-module RON.Storage- ( Collection (..)- , CollectionName- , DocId (..)- , Document (..)- , DocVersion- , MonadStorage (..)- , createDocument- , decodeDocId- , loadDocument- , modify- , readVersion- ) where+module RON.Storage (+ Collection (..),+ CollectionName,+ DocId (..),+ Document (..),+ DocVersion,+ MonadStorage (..),+ createDocument,+ decodeDocId,+ docIdFromUuid,+ loadDocument,+ modify,+ readVersion,+) where import Control.Monad (unless, when) import Control.Monad.Except (MonadError, catchError, liftEither,@@ -30,6 +31,7 @@ import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Traversable (for)+import Data.Typeable (Typeable) import System.FilePath ((</>)) import RON.Data (ReplicatedAsObject, reduceObject)@@ -44,6 +46,7 @@ -- | Document identifier (directory name), -- should be a RON-Base32-encoded RON-UUID. newtype DocId a = DocId FilePath+ deriving (Eq, Ord) instance Collection a => Show (DocId a) where show (DocId file) = collectionName @a </> file@@ -53,7 +56,7 @@ -- | A type that intended to be put in a separate collection must define a -- Collection instance.-class ReplicatedAsObject a => Collection a where+class (ReplicatedAsObject a, Typeable a) => Collection a where collectionName :: CollectionName @@ -131,7 +134,9 @@ | n > 0 = do versions0 <- getDocumentVersions docid case versions0 of- [] -> throwError $ "Empty document " ++ show docid+ [] ->+ throwError $+ "Document with id " ++ show docid ++ " has not found." v:vs -> do let versions = v :| vs let wrapDoc (value, isTouched) =@@ -205,3 +210,6 @@ -- | Create document assuming it doesn't exist yet. createDocument :: (Collection a, MonadStorage m) => Object a -> m () createDocument = createVersion Nothing++docIdFromUuid :: UUID -> DocId a+docIdFromUuid = DocId . UUID.encodeBase32
lib/RON/Storage/IO.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -22,22 +23,26 @@ -- @ module RON.Storage.IO ( module X,+ -- * Handle Handle,- Storage,+ OnDocumentChanged (..), newHandle,+ setOnDocumentChanged,+ -- * Storage+ Storage, 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.Extra (filterM, unless, when, whenJust) 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.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe, listToMaybe) import Data.Word (Word64) import Network.Info (MAC (MAC), getNetworkInterfaces, mac)@@ -53,15 +58,15 @@ import RON.Storage as X -- | Environment is the dataDir-newtype Storage a = Storage (ExceptT String (ReaderT FilePath EpochClock) a)+newtype Storage a = Storage (ExceptT String (ReaderT Handle 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+runStorage h@Handle{hReplica, hClock} (Storage action) = do res <- runEpochClock hReplica hClock $- (`runReaderT` hDataDir) $+ (`runReaderT` h) $ runExceptT action either fail pure res @@ -72,73 +77,96 @@ instance MonadStorage Storage where getCollections = Storage $ do- dataDir <- ask+ Handle{hDataDir} <- ask liftIO $- listDirectory dataDir- >>= filterM (doesDirectoryExist . (dataDir </>))+ listDirectory hDataDir+ >>= filterM (doesDirectoryExist . (hDataDir </>)) getDocuments :: forall doc. Collection doc => Storage [DocId doc] getDocuments = map DocId <$> listDirectoryIfExists (collectionName @doc) getDocumentVersions = listDirectoryIfExists . docDir - saveVersionContent docid version content =+ saveVersionContent docid version content = do Storage $ do- dataDir <- ask- let docdir = dataDir </> docDir docid+ Handle{hDataDir} <- ask+ let docdir = hDataDir </> docDir docid liftIO $ do createDirectoryIfMissing True docdir BSL.writeFile (docdir </> version) content+ emitDocumentChanged docid loadVersionContent docid version = Storage $ do- dataDir <- ask- liftIO $ BSL.readFile $ dataDir </> docDir docid </> version+ Handle{hDataDir} <- ask+ liftIO $ BSL.readFile $ hDataDir </> docDir docid </> version deleteVersion docid version = Storage $ do- dataDir <- ask+ Handle{hDataDir} <- ask liftIO $ do- let file = dataDir </> docDir docid </> version+ let file = hDataDir </> 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+ 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 $+ throwError $ unwords+ [ "changeDocId"+ , show old, "[", oldPath, "->", oldPathCanon, "]"+ , show new, "[", newPath, "->", newPathCanon, "]"+ , ": internal error: new document id is already taken"+ ]+ liftIO $ renameDirectory oldPath newPath+ pure pathsDiffer+ when renamed $ emitDocumentChanged new -- | Storage handle (uses the “Handle pattern”). data Handle = Handle- { hClock :: IORef EpochTime- , hDataDir :: FilePath- , hReplica :: ReplicaId+ { hClock :: IORef EpochTime+ , hDataDir :: FilePath+ , hReplica :: ReplicaId+ , hOnDocumentChanged :: IORef (Maybe OnDocumentChanged) } +-- | The handler is called as @onDocumentChanged docid@, where+-- @docid@ is the changed document id.+newtype OnDocumentChanged =+ OnDocumentChanged (forall a . Collection a => DocId a -> IO ())++emitDocumentChanged :: Collection a => DocId a -> Storage ()+emitDocumentChanged docid = Storage $ do+ Handle{hOnDocumentChanged} <- ask+ liftIO $ do+ mOnDocumentChanged <- readIORef hOnDocumentChanged+ whenJust mOnDocumentChanged $ \(OnDocumentChanged onDocumentChanged) ->+ onDocumentChanged docid+ -- | Create new storage handle newHandle :: FilePath -> IO Handle newHandle hDataDir = do time <- getCurrentEpochTime hClock <- newIORef time hReplica <- applicationSpecific <$> getMacAddress- pure Handle{hDataDir, hClock, hReplica}+ hOnDocumentChanged <- newIORef Nothing+ pure Handle{hDataDir, hClock, hReplica, hOnDocumentChanged} +setOnDocumentChanged :: Handle -> OnDocumentChanged -> IO ()+setOnDocumentChanged h handler =+ writeIORef (hOnDocumentChanged h) $ Just handler+ listDirectoryIfExists :: FilePath -> Storage [FilePath] listDirectoryIfExists relpath = Storage $ do- dataDir <- ask- let dir = dataDir </> relpath+ Handle{hDataDir} <- ask+ let dir = hDataDir </> relpath liftIO $ do exists <- doesDirectoryExist dir if exists then listDirectory dir else pure []
ron.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-version: 0.3+version: 0.4 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -21,11 +21,11 @@ > 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])+ > [mkReplicated|+ > (struct_lww Note+ > active Boole+ > text RgaString)+ > |] > > instance Collection Note where > collectionName = "note"@@ -36,7 +36,7 @@ > h <- Storage.newHandle dataDir > runStorage h $ do > obj <- newObject- > Note{active = True, text = "Выступить на FProg SPb"}+ > Note{active = True, text = "Write a task manager"} > createDocument obj build-type: Simple@@ -55,7 +55,6 @@ binary, bytestring, containers,- data-default, Diff, directory, errors,