ot (empty) → 0.1.1.1

raw patch · 9 files changed

+530/−0 lines, 9 filesdep +QuickCheckdep +aesondep +attoparsecsetup-changed

Dependencies added: QuickCheck, aeson, attoparsec, base, binary, ot, test-framework, test-framework-quickcheck2, text

Files

• LICENSE +20/−0
• Setup.hs +2/−0
• ot.cabal +52/−0
• src/Control/OperationalTransformation.hs +140/−0
• src/Control/OperationalTransformation/Client.hs +66/−0
• src/Control/OperationalTransformation/Properties.hs +45/−0
• src/Control/OperationalTransformation/Server.hs +44/−0
• src/Control/OperationalTransformation/Text.hs +151/−0
• test/TestSuite.hs +10/−0

@@ -0,0 +1,20 @@+The MIT License (MIT)+Copyright © 2011-2012 Tim Baumann, http://timbaumann.info++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the “Software”), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,52 @@+Name:                ot+Version:             0.1.1.1+Synopsis:            Real-time collaborative editing with Operational Transformation+-- A longer description of the package.+-- Description:         +Homepage:            https://github.com/timjb/ot.hs+License:             MIT+License-file:        LICENSE+Author:              Tim Baumann+Maintainer:          tim@timbaumann.info++-- A copyright notice.+-- Copyright:           ++Category:            Text+Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:         >= 1.8+++Library+  Ghc-options:         -Wall+  Hs-source-dirs:      src+  Exposed-modules:     Control.OperationalTransformation, Control.OperationalTransformation.Text, Control.OperationalTransformation.Properties, Control.OperationalTransformation.Client, Control.OperationalTransformation.Server+  Build-depends:       base >= 4 && < 5,+                       text >= 0.11.1 && < 0.12,+                       aeson >= 0.6.0.2 && < 0.7,+                       attoparsec >= 0.10.1.1 && < 1,+                       QuickCheck >= 2.4.2 && < 2.6,+                       binary >= 0.5.1.0++  -- Modules not exported by this package.+  -- Other-modules:       ++Test-suite tests+  Ghc-options:         -Wall -rtsopts+  Hs-source-dirs:      test+  type:                exitcode-stdio-1.0+  main-is:             TestSuite.hs+  Build-depends:       ot,+                       QuickCheck,+                       base,+                       text,+                       aeson,+                       test-framework >= 0.6 && < 0.7,+                       test-framework-quickcheck2 >= 0.2.12.2 && < 0.3,+                       binary >= 0.5.1.0

@@ -0,0 +1,140 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}++module Control.OperationalTransformation+  ( OTOperation (..)+  , OTComposableOperation (..)+  , OTSystem (..)+  ) where++import Control.Monad (foldM)+import Control.Monad.Instances ()++class OTOperation op where+  -- | Transforms two concurrent operations /a/ and /b/, producing /a'/ and /b'/ +  -- such that @b' ∘ a == a' ∘ b@.+  transform :: op -> op -> Either String (op, op)++class (OTOperation op) => OTComposableOperation op where+  -- | Composes two operations /a/ and /b/, producing /c/, such that /c/ has the+  -- same effect when applied to a document as applying /a/ and /b/ one after+  -- another.+  compose :: op -> op -> Either String op++class (OTOperation op) => OTSystem doc op where+  -- | Apply an operation to a document, producing a new document.+  apply :: op -> doc -> Either String doc++instance (OTOperation op) => OTOperation [op] where+  transform = transformList2+    where+      transformList1 o [] = return (o, [])+      transformList1 o (p:ps) = do+        (o', p') <- transform o p+        (o'', ps') <- transformList1 o' ps+        return (o'', p':ps')++      transformList2 [] ps = return ([], ps)+      transformList2 (o:os) ps = do+        (o', ps') <- transformList1 o ps+        (os', ps'') <- transformList2 os ps'+        return (o':os', ps'')++instance (OTOperation op) => OTComposableOperation [op] where+  compose a b = return $ a ++ b++instance (OTSystem doc op) => OTSystem doc [op] where+  apply = flip $ foldM $ flip apply+++instance (OTOperation a, OTOperation b) => OTOperation (a, b) where+  transform (a1, a2) (b1, b2) = do+    (a1', b1') <- transform a1 b1+    (a2', b2') <- transform a2 b2+    return ((a1', a2'), (b1', b2'))++instance (OTComposableOperation a, OTComposableOperation b) => OTComposableOperation (a, b) where+  compose (a1, a2) (b1, b2) = do+    c1 <- compose a1 b1+    c2 <- compose a2 b2+    return (c1, c2)++instance (OTSystem doca a, OTSystem docb b) => OTSystem (doca, docb) (a, b) where+  apply (a, b) (doca, docb) = do+    doca' <- apply a doca+    docb' <- apply b docb+    return (doca', docb')+++instance (OTOperation a, OTOperation b, OTOperation c) => OTOperation (a, b, c) where+  transform (a1, a2, a3) (b1, b2, b3) = do+    (a1', b1') <- transform a1 b1+    (a2', b2') <- transform a2 b2+    (a3', b3') <- transform a3 b3+    return ((a1', a2', a3'), (b1', b2', b3'))++instance (OTComposableOperation a, OTComposableOperation b, OTComposableOperation c) => OTComposableOperation (a, b, c) where+  compose (a1, a2, a3) (b1, b2, b3) = do+    c1 <- compose a1 b1+    c2 <- compose a2 b2+    c3 <- compose a3 b3+    return (c1, c2, c3)++instance (OTSystem doca a, OTSystem docb b, OTSystem docc c) => OTSystem (doca, docb, docc) (a, b, c) where+  apply (a, b, c) (doca, docb, docc) = do+    doca' <- apply a doca+    docb' <- apply b docb+    docc' <- apply c docc+    return (doca', docb', docc')+++instance (OTOperation a, OTOperation b, OTOperation c, OTOperation d) => OTOperation (a, b, c, d) where+  transform (a1, a2, a3, a4) (b1, b2, b3, b4) = do+    (a1', b1') <- transform a1 b1+    (a2', b2') <- transform a2 b2+    (a3', b3') <- transform a3 b3+    (a4', b4') <- transform a4 b4+    return ((a1', a2', a3', a4'), (b1', b2', b3', b4'))++instance (OTComposableOperation a, OTComposableOperation b, OTComposableOperation c, OTComposableOperation d) => OTComposableOperation (a, b, c, d) where+  compose (a1, a2, a3, a4) (b1, b2, b3, b4) = do+    c1 <- compose a1 b1+    c2 <- compose a2 b2+    c3 <- compose a3 b3+    c4 <- compose a4 b4+    return (c1, c2, c3, c4)++instance (OTSystem doca a, OTSystem docb b, OTSystem docc c, OTSystem docd d) => OTSystem (doca, docb, docc, docd) (a, b, c, d) where+  apply (a, b, c, d) (doca, docb, docc, docd) = do+    doca' <- apply a doca+    docb' <- apply b docb+    docc' <- apply c docc+    docd' <- apply d docd+    return (doca', docb', docc', docd')+++instance (OTOperation a, OTOperation b, OTOperation c, OTOperation d, OTOperation e) => OTOperation (a, b, c, d, e) where+  transform (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) = do+    (a1', b1') <- transform a1 b1+    (a2', b2') <- transform a2 b2+    (a3', b3') <- transform a3 b3+    (a4', b4') <- transform a4 b4+    (a5', b5') <- transform a5 b5+    return ((a1', a2', a3', a4', a5'), (b1', b2', b3', b4', b5'))++instance (OTComposableOperation a, OTComposableOperation b, OTComposableOperation c, OTComposableOperation d, OTComposableOperation e) => OTComposableOperation (a, b, c, d, e) where+  compose (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5) = do+    c1 <- compose a1 b1+    c2 <- compose a2 b2+    c3 <- compose a3 b3+    c4 <- compose a4 b4+    c5 <- compose a5 b5+    return (c1, c2, c3, c4, c5)++instance (OTSystem doca a, OTSystem docb b, OTSystem docc c, OTSystem docd d, OTSystem doce e) => OTSystem (doca, docb, docc, docd, doce) (a, b, c, d, e) where+  apply (a, b, c, d, e) (doca, docb, docc, docd, doce) = do+    doca' <- apply a doca+    docb' <- apply b docb+    docc' <- apply c docc+    docd' <- apply d docd+    doce' <- apply e doce+    return (doca', docb', docc', docd', doce')

@@ -0,0 +1,66 @@+module Control.OperationalTransformation.Client+  ( ClientState (..)+  , initialClientState+  , applyClient+  , applyServer+  , serverAck+  ) where++import Control.OperationalTransformation++-- | At every moment, the client is in one of three states.+data ClientState op+  -- | All of the client's operations have been acknowledged by the server.+  = ClientSynchronized+  -- | The client has sent an operation to the server and it is still waiting+  -- for an acknowledgement.+  | ClientWaiting op+  -- | The client is waiting for an acknowledgement for a pending operation and+  -- the client is buffering local changes.+  | ClientWaitingWithBuffer op op+  deriving (Eq, Show, Read)++-- | The state a newly connected client starts in (synonym for+-- 'ClientSynchronized').+initialClientState :: ClientState op+initialClientState = ClientSynchronized++-- | Handle user-generated operations.+applyClient :: (OTComposableOperation op)+            => ClientState op+            -> op+            -- ^ The operation the user has performed on the local document.+            -> Either String (Bool, ClientState op)+            -- ^ Whether to send the operation to the server and the new client+            -- state (or an error).+applyClient ClientSynchronized op = Right (True, ClientWaiting op)+applyClient (ClientWaiting w) op = Right (False, ClientWaitingWithBuffer w op)+applyClient (ClientWaitingWithBuffer w b) op = case compose b op of+  Left err -> Left $ "operations couldn't be composed: " ++ err+  Right b' -> Right (False, ClientWaitingWithBuffer w b')++-- | Handle incoming operations from the server.+applyServer :: (OTComposableOperation op)+            => ClientState op+            -> op+            -> Either String (op, ClientState op)+            -- ^ The transformed operation that must be applied to local+            -- document and the new state (or an error).+applyServer ClientSynchronized op = Right (op, ClientSynchronized)+applyServer (ClientWaiting w) op = case transform w op of+  Left err -> Left $ "transform failed: " ++ err+  Right (w', op') -> Right (op', ClientWaiting w')+applyServer (ClientWaitingWithBuffer w b) op = case transform w op of+  Left err -> Left $ "transform failed: " ++ err+  Right (w', op') -> case transform b op' of+    Left err -> Left $ "transform failed: " ++ err+    Right (b', op'') -> Right (op'', ClientWaitingWithBuffer w' b')++-- | Handle acknowledgements.+serverAck :: ClientState op+          -> Maybe (Maybe op, ClientState op)+          -- ^ An optional operation that must be sent to the server if present+          -- and the new state.+serverAck ClientSynchronized            = Nothing+serverAck (ClientWaiting _)             = Just (Nothing, ClientSynchronized)+serverAck (ClientWaitingWithBuffer _ b) = Just (Just b, ClientWaiting b)

@@ -0,0 +1,45 @@+module Control.OperationalTransformation.Properties+  ( prop_compose_apply+  , prop_transform_apply+  ) where++import Control.OperationalTransformation+import Test.QuickCheck hiding (Result, reason)+import Test.QuickCheck.Property+import Control.Monad (liftM2, liftM3)++(==?) :: (Eq a, Show a) => a -> a -> Result+a ==? b | a == b    = succeeded+        | otherwise = failed { reason = "expected " ++ show a ++ " to be " ++ show b }++eitherProperty :: (Either String a) -> (a -> Property) -> Property+eitherProperty (Left err) _ = property $ failed { reason = err }+eitherProperty (Right res) prop = prop res++-- | @(b ∘ a)(d) = a(b(d))@ where /a/ and /b/ are two consecutive operations+-- and /d/ is the initial document.+prop_compose_apply :: (OTSystem doc op, OTComposableOperation op, Arbitrary doc, Show doc, Eq doc)+                   => (doc -> Gen op) -> Property+prop_compose_apply genOperation = do+  doc <- arbitrary+  a <- genOperation doc+  eitherProperty (apply a doc) $ \doc' -> do+    b <- genOperation doc'+    eitherProperty (apply b doc') $ \doc'' -> do+      eitherProperty (compose a b) $ \ab -> do+        property $ Right doc'' ==? apply ab doc++-- | @b'(a(d)) = b'(a(d))@ where /a/ and /b/ are random operations, /d/ is the+-- initial document and @(a', b') = transform(a, b)@.+prop_transform_apply :: (OTSystem doc op, Arbitrary doc, Show doc, Eq doc)+                     => (doc -> Gen op)+                     -> Property+prop_transform_apply genOperation = do+  doc <- arbitrary+  a <- genOperation doc+  b <- genOperation doc+  let res1 = liftM3 (,,) (apply a doc) (apply b doc) (transform a b)+  eitherProperty res1 $ \(doca, docb, (a', b')) -> do+    let res2 = liftM2 (,) (apply b' doca) (apply a' docb)+    eitherProperty res2 $ \(docab', docba') ->+      property $ docab' ==? docba'

@@ -0,0 +1,44 @@+module Control.OperationalTransformation.Server+  ( Revision+  , ServerState (..)+  , initialServerState+  , applyOperation+  ) where++import Control.OperationalTransformation+import Control.Monad (foldM)++type Revision = Integer++-- | The server keeps the current revision number and a list of previous+-- operations to transform incoming operations against.+data ServerState doc op = ServerState Revision doc [op]++initialServerState :: doc -> ServerState doc op+initialServerState doc = ServerState 0 doc []++-- | Handles incoming operations.+applyOperation :: (OTSystem doc op)+               => ServerState doc op+               -> Revision+               -- ^ The latest operation that the client has received from the server when it sent the operation.+               -> op+               -- ^ The operation received from the client.+               -> Either String (op, ServerState doc op)+               -- ^ The operation to broadcast to all connected clients+               -- (except the client which has created the operation; that+               -- client must be sent an acknowledgement) and the new state+               -- (or an error).+applyOperation (ServerState rev doc ops) oprev op = do+  concurrentOps <- if oprev > rev || rev - oprev > fromIntegral (length ops)+    then Left "unknown revision number"+    else Right $ take (fromInteger $ rev - oprev) ops+  op' <- foldM transformFst op (reverse concurrentOps)+  doc' <- case apply op' doc of+    Left err -> Left $ "apply failed: " ++ err+    Right d -> Right d+  return $ (op', ServerState (rev+1) doc' (op':ops))+  where+    transformFst a b = case transform a b of+      Left err -> Left $ "transform failed: " ++ err+      Right (a', _) -> Right a'

@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Control.OperationalTransformation.Text+  ( Action (..)+  , TextOperation (..)+  , invertOperation+  ) where++import Control.OperationalTransformation+import qualified Data.Text as T+import Data.Monoid (mappend)+import Data.Aeson (Value (..), FromJSON (..), ToJSON (..))+import Data.Binary (Binary (..), putWord8, getWord8)+import Data.Attoparsec.Number (Number (..))+import Data.Typeable (Typeable)+import Data.Text (pack, unpack)+import Control.Applicative ((<$>))+++-- | An action changes the text at the current position or advances the cursor.+data Action = Retain !Int    -- ^ Skip the next n characters.+            | Insert !T.Text -- ^ Insert the given text at the current position.+            | Delete !Int    -- ^ Delete the next n characters.+            deriving (Eq, Read, Show, Typeable)++instance Binary Action where+  put (Retain n) = putWord8 0 >> put n+  put (Insert i) = putWord8 1 >> put (unpack i)+  put (Delete n) = putWord8 2 >> put n+  get = do+    t <- getWord8+    case t of+      0 -> Retain <$> get+      1 -> Insert . pack <$> get+      _ -> Delete <$> get++instance ToJSON Action where+  toJSON (Retain n) = Number $ I (toInteger n)+  toJSON (Insert t) = String t+  toJSON (Delete n) = Number $ I (toInteger (-n))++instance FromJSON Action where+  parseJSON (Number (I n)) | n > 0 = return $ Retain (fromInteger n)+                           | n < 0 = return $ Delete (fromInteger (-n))+  parseJSON (String i) = return $ Insert i+  parseJSON _ = fail "expected a non-zero integer or a string"++-- | An edit on plain text documents. An operation consists of multiple actions+-- that change the document at the current cursor position or advance the+-- cursor. After applying all actions, the cursor must be at the end of the+-- document.+newtype TextOperation = TextOperation [Action] deriving (Eq, Read, Show, Binary, Typeable, FromJSON, ToJSON)++addRetain :: Int -> [Action] -> [Action]+addRetain n (Retain m : xs) = Retain (n+m) : xs+addRetain n xs = Retain n : xs++addInsert :: T.Text -> [Action] -> [Action]+addInsert s (Insert t : xs) = Insert (t `mappend` s) : xs+addInsert s xs = Insert s : xs++addDelete :: Int -> [Action] -> [Action]+addDelete n (Delete m : xs) = Delete (n+m) : xs+addDelete n xs = Delete n : xs++instance OTOperation TextOperation where+  transform (TextOperation o1) (TextOperation o2) = both (TextOperation . reverse) `fmap` loop o1 o2 [] []+    where+      both :: (a -> b) -> (a, a) -> (b, b)+      both f (a, b) = (f a, f b)++      loop [] [] xs ys = Right (xs, ys)+      loop aa@(a:as) bb@(b:bs) xs ys = case (a, b) of+        (Insert i, _) -> loop as bb (addInsert i xs) (addRetain (T.length i) ys)+        (_, Insert i) -> loop aa bs (addRetain (T.length i) xs) (addInsert i ys)+        (Retain n, Retain m) -> case compare n m of+          LT -> loop as (Retain (m-n) : bs) (addRetain n xs) (addRetain n ys)+          EQ -> loop as bs (addRetain n xs) (addRetain n ys)+          GT -> loop (Retain (n-m) : as) bs (addRetain m xs) (addRetain m ys)+        (Delete n, Delete m) -> case compare n m of+          LT -> loop as (Delete (m-n) : bs) xs ys+          EQ -> loop as bs xs ys+          GT -> loop (Delete (n-m) : as) bs xs ys+        (Retain r, Delete d) -> case compare r d of+          LT -> loop as (Delete (d-r) : bs) xs (addDelete r ys)+          EQ -> loop as bs xs (addDelete d ys)+          GT -> loop (Retain (r-d) : as) bs xs (addDelete d ys)+        (Delete d, Retain r) -> case compare d r of+          LT -> loop as (Retain (r-d) : bs) (addDelete d xs) ys+          EQ -> loop as bs (addDelete d xs) ys+          GT -> loop (Delete (d-r) : as) bs (addDelete r xs) ys+      loop [] (Insert i : bs) xs ys = loop [] bs (addRetain (T.length i) xs) (addInsert i ys)+      loop (Insert i : as) [] xs ys = loop as [] (addInsert i xs) (addRetain (T.length i) ys)+      loop _ _ _ _ = Left "the operations couldn't be transformed because they haven't been applied to the same document"++instance OTComposableOperation TextOperation where+  compose (TextOperation o1) (TextOperation o2) = (TextOperation . reverse) `fmap` loop o1 o2 []+    where+      loop [] [] xs = Right xs+      loop aa@(a:as) bb@(b:bs) xs = case (a, b) of+        (Delete d, _) -> loop as bb (addDelete d xs)+        (_, Insert i) -> loop aa bs (addInsert i xs)+        (Retain n, Retain m) -> case compare n m of+          LT -> loop as (Retain (m-n) : bs) (addRetain n xs)+          EQ -> loop as bs (addRetain n xs)+          GT -> loop (Retain (n-m) : as) bs (addRetain m xs)+        (Retain r, Delete d) -> case compare r d of+          LT -> loop as (Delete (d-r) : bs) (addDelete r xs)+          EQ -> loop as bs (addDelete d xs)+          GT -> loop (Retain (r-d) : as) bs (addDelete d xs)+        (Insert i, Retain m) -> case compare (T.length i) m of+          LT -> loop as (Retain (m - T.length i) : bs) (addInsert i xs)+          EQ -> loop as bs (addInsert i xs)+          GT -> let (before, after) = T.splitAt m i+                in loop (Insert after : as) bs (addInsert before xs)+        (Insert i, Delete d) -> case compare (T.length i) d of+          LT -> loop as (Delete (d - T.length i) : bs) xs+          EQ -> loop as bs xs+          GT -> loop (Insert (T.drop d i) : as) bs xs+      loop (Delete d : as) [] xs = loop as [] (addDelete d xs)+      loop [] (Insert i : bs) xs = loop [] bs (addInsert i xs)+      loop _ _ _ = Left "the operations couldn't be composed since their lengths don't match"++instance OTSystem T.Text TextOperation where+  apply (TextOperation actions) input = loop actions input ""+    where+      loop [] "" ot = Right ot+      loop (op:ops) it ot = case op of+        Retain r -> if T.length it < r+          then Left "operation can't be applied to the document: operation is longer than the text"+          else let (before, after) = T.splitAt r it+               in loop ops after (ot `mappend` before)+        Insert i -> loop ops it (ot `mappend` i)+        Delete d -> if d > T.length it+          then Left "operation can't be applied to the document: operation is longer than the text"+          else loop ops (T.drop d it) ot+      loop _ _ _ = Left "operation can't be applied to the document: text is longer than the operation"++-- | Computes the inverse of an operation. Useful for implementing undo.+invertOperation :: TextOperation               -- ^ An operation.+                -> T.Text                      -- ^ Document before the operation was applied.+                -> Either String TextOperation+invertOperation (TextOperation actions) doc = loop actions doc []+  where+    loop (op:ops) text inv = case op of+      (Retain n) -> loop ops (T.drop n text) (Retain n : inv)+      (Insert i) -> loop ops text (Delete (T.length i) : inv)+      (Delete d) -> let (before, after) = T.splitAt d text+                    in loop ops after (Insert before : inv)+    loop [] "" inv = Right . TextOperation . reverse $ inv+    loop [] _ _ = Left "invert failed: text is longer than the operation"

@@ -0,0 +1,10 @@+import Test.Framework++import qualified Control.OperationalTransformation.Text.Tests+import qualified Control.OperationalTransformation.ClientServerTests++main :: IO ()+main = defaultMain+  [ Control.OperationalTransformation.Text.Tests.tests+  , Control.OperationalTransformation.ClientServerTests.tests+  ]