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 @@ -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 diff --git a/lib/RON/Data/Time.hs b/lib/RON/Data/Time.hs --- a/lib/RON/Data/Time.hs +++ b/lib/RON/Data/Time.hs @@ -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" diff --git a/lib/RON/Schema.hs b/lib/RON/Schema.hs --- a/lib/RON/Schema.hs +++ b/lib/RON/Schema.hs @@ -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 diff --git a/lib/RON/Schema/EDN.hs b/lib/RON/Schema/EDN.hs --- a/lib/RON/Schema/EDN.hs +++ b/lib/RON/Schema/EDN.hs @@ -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 ...)" + 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 ...)" - 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 ... ...)" - 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 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 @@ -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) [] diff --git a/lib/RON/Storage.hs b/lib/RON/Storage.hs --- a/lib/RON/Storage.hs +++ b/lib/RON/Storage.hs @@ -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 diff --git a/lib/RON/Storage/IO.hs b/lib/RON/Storage/IO.hs --- a/lib/RON/Storage/IO.hs +++ b/lib/RON/Storage/IO.hs @@ -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 [] diff --git a/ron.cabal b/ron.cabal --- a/ron.cabal +++ b/ron.cabal @@ -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,