add a separate server for operational transformation

build.sh

@@ -50,7 +50,7 @@ run .  cabal_install ./funblocks-server \
                      ./codeworld-game-api \
                      ./codeworld-prediction \
                      ./codeworld-api \
-                     ./codeworld-game-server
+                     ./codeworld-collab-server
 
 # Build the JavaScript client code for FunBlocks, the block-based UI.
 run .  cabal_install --ghcjs ./funblocks-client

codeworld-game-server/codeworld-game-server.cabal → codeworld-collab-server/codeworld-collab-server.cabal

@@ -10,22 +10,33 @@ Build-type:          Simple
 Extra-source-files:  ChangeLog.md
 Cabal-version:       >=1.10
 
-Executable codeworld-game-server
+Executable codeworld-collab-server
   Main-is:             Main.hs
   Other-modules:       CodeWorld.GameServer
   Build-depends:       base >=4.8 && <4.10,
                        aeson,
+                       directory,
+                       engine-io,
+                       engine-io-snap,
+                       filepath,
+                       hashable,
+                       http-conduit,
+                       mtl,
+                       ot,
                        text,
                        websockets == 0.9.*,
                        websockets-snap == 0.10.*,
                        snap-core == 1.0.*,
                        snap-server == 1.0.*,
+                       socket-io,
+                       stm,
                        transformers,
                        bytestring,
                        random,
                        unordered-containers,
                        time,
-                       codeworld-game-api
+                       codeworld-game-api,
+                       codeworld-server
   Hs-source-dirs:      src
   Default-language:    Haskell2010
   Ghc-options:         -threaded -rtsopts "-with-rtsopts=-N"

codeworld-collab-server/src/CodeWorld/CollabModel.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-
+  Copyright 2017 The CodeWorld Authors. All rights reserved.
+
+  Licensed under the Apache License, Version 2.0 (the "License");
+  you may not use this file except in compliance with the License.
+  You may obtain a copy of the License at
+
+      http://www.apache.org/licenses/LICENSE-2.0
+
+  Unless required by applicable law or agreed to in writing, software
+  distributed under the License is distributed on an "AS IS" BASIS,
+  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+  See the License for the specific language governing permissions and
+  limitations under the License.
+-}
+
+module CodeWorld.CollabModel where
+
+import qualified Control.Concurrent.STM as STM
+import           Control.OperationalTransformation.Selection (Selection)
+import           Control.OperationalTransformation.Server (ServerState)
+import           Control.OperationalTransformation.Text (TextOperation)
+import           Data.Aeson
+import           GHC.Generics (Generic)
+import           Data.Hashable (Hashable)
+import qualified Data.HashMap.Strict as HM
+import           Data.Text (Text)
+import           Data.Time.Clock (UTCTime)
+
+data CollabServerState = CollabServerState
+    { collabProjects :: STM.TVar CollabProjects
+    , started        :: UTCTime
+    }
+
+type CollabProjects = HM.HashMap CollabId (STM.TVar CollabProject)
+
+data CollabProject = CollabProject
+    { totalUsers  :: !Int
+    , collabKey   :: CollabId
+    , collabState :: ServerState Text TextOperation
+    , users       :: [CollabUserState]
+    }
+
+data CollabUserState = CollabUserState
+    { suserId       :: !Text
+    , suserIdent    :: !Text
+    , userSelection :: !Selection
+    }
+
+instance ToJSON CollabUserState where
+    toJSON (CollabUserState _ userIdent' sel) =
+      object $ [ "name" .= userIdent' ] ++ (if sel == mempty then [] else [ "selection" .= sel ])
+
+newtype CollabId = CollabId { unCollabId :: Text } deriving (Eq, Generic)
+
+instance Hashable CollabId

codeworld-collab-server/src/CodeWorld/CollabServer.hs

@@ -0,0 +1,209 @@
+{-# LANGUAGE BangPatterns       #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-
+  Copyright 2017 The CodeWorld Authors. All rights reserved.
+
+  Licensed under the Apache License, Version 2.0 (the "License");
+  you may not use this file except in compliance with the License.
+  You may obtain a copy of the License at
+
+      http://www.apache.org/licenses/LICENSE-2.0
+
+  Unless required by applicable law or agreed to in writing, software
+  distributed under the License is distributed on an "AS IS" BASIS,
+  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+  See the License for the specific language governing permissions and
+  limitations under the License.
+-}
+
+module CodeWorld.CollabServer
+    ( initCollabServer
+    , collabServer
+    ) where
+
+import qualified Control.Concurrent.STM as STM
+import           Control.Monad (when)
+import           Control.Monad.State.Strict (StateT)
+import           Control.Monad.Trans
+import           Control.Monad.Trans.Reader (ReaderT)
+import qualified Control.OperationalTransformation.Selection as Sel
+import qualified Control.OperationalTransformation.Server as OTS
+import           Data.Aeson
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.HashMap.Strict as HM
+import           Data.Maybe (fromJust)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import           Data.Time.Clock
+import           DataUtil
+import           Model
+import           Network.HTTP.Conduit (simpleHttp)
+import qualified Network.SocketIO as SIO
+import           Snap.Core
+import           SnapUtil
+import           System.Directory
+import           System.FilePath
+
+import CodeWorld.CollabModel
+
+-- Initialize Collab Server
+
+initCollabServer :: IO CollabServerState
+initCollabServer = do
+    started <- getCurrentTime
+    collabProjects <- STM.newTVarIO HM.empty
+    return CollabServerState {..}
+
+-- Collaboration requests helpers
+
+getRequestParams :: ClientId -> Snap (User, FilePath)
+getRequestParams clientId = do
+    user <- getUser clientId
+    mode <- getBuildMode
+    Just path' <- fmap (splitDirectories . BC.unpack) <$> getParam "path"
+    Just name <- getParam "name"
+    let projectId = nameToProjectId $ T.decodeUtf8 name
+        finalDir = joinPath $ map (dirBase . nameToDirId . T.pack) path'
+        file = userProjectDir mode (userId user) </> finalDir </> projectFile projectId
+    case (length path', path' !! 0) of
+        (0, _) -> return (user, file)
+        (_, x) | x /= "commentables" -> return (user, file)
+
+initCollaborationHandler :: CollabServerState -> ClientId -> Snap (Text, Text, CollabId)
+initCollaborationHandler state clientId = do
+    (user, filePath) <- getRequestParams clientId
+    collabHashPath <- liftIO $ BC.unpack <$> B.readFile filePath
+    let collabHash = take (length collabHashPath - 3) . takeFileName $ collabHashPath
+    Just (currentUsers :: [UserDump]) <- liftIO $ decodeStrict <$>
+      B.readFile (collabHashPath <.> "users")
+    let userIdent' = uuserIdent $ (filter (\x -> uuserId x == userId user) currentUsers) !! 0
+    Just (project :: Project) <- liftIO $ decodeStrict <$>
+      B.readFile collabHashPath
+    liftIO $ addNewCollaborator state (userId user) userIdent' (projectSource project) $
+      CollabId . T.pack $ collabHash
+    return ((userId user), userIdent', CollabId . T.pack $ collabHash)
+
+getCollabProject :: CollabServerState -> CollabId -> STM.STM (STM.TVar CollabProject)
+getCollabProject state collabHash = do
+    fromJust . HM.lookup collabHash <$> STM.readTVar (collabProjects state)
+
+addNewCollaborator :: CollabServerState -> Text -> Text -> Text -> CollabId -> IO ()
+addNewCollaborator state userId' userIdent' projectSource collabHash = do
+    let collabUser = CollabUserState userId' userIdent' mempty
+    STM.atomically $ do
+        hm <- STM.readTVar $ collabProjects state
+        case HM.lookup collabHash hm of
+            Just collabProjectTV -> do
+                collabProject <- STM.readTVar collabProjectTV
+                case userId' `elem` (map suserId $ users collabProject) of
+                    True -> do
+                        let collabProject' = collabProject
+                                { users = map (\x -> if suserId x == userId'
+                                                     then collabUser
+                                                     else x) $ users collabProject
+                                }
+                        collabProjectTV' <- STM.newTVar collabProject'
+                        STM.modifyTVar (collabProjects state) $
+                          \x -> HM.adjust (\_ -> collabProjectTV') collabHash x
+                    False -> do
+                        let collabProject' = collabProject
+                                { totalUsers = totalUsers collabProject + 1
+                                , users      = collabUser : users collabProject
+                                }
+                        collabProjectTV' <- STM.newTVar collabProject'
+                        STM.modifyTVar (collabProjects state) $
+                          \x -> HM.adjust (\_ -> collabProjectTV') collabHash x
+            Nothing -> do
+                let collabProject = CollabProject
+                        { totalUsers  = 1
+                        , collabKey   = collabHash
+                        , collabState = OTS.initialServerState projectSource
+                        , users       = [collabUser]
+                        }
+                collabProjectTV <- STM.newTVar collabProject
+                STM.modifyTVar (collabProjects state) $
+                  \x -> HM.insert collabHash collabProjectTV x
+
+cleanUp :: CollabServerState -> Text -> STM.TVar CollabProject -> STM.STM ()
+cleanUp state userId' collabProjectTV = do
+    collabProject <- STM.readTVar collabProjectTV
+    case null (filter ((/= userId') . suserId) $ users collabProject) of
+        True -> do
+            STM.modifyTVar collabProjectTV (\collabProject' -> collabProject'
+                                                { totalUsers = 0
+                                                , users = []
+                                                })
+            let collabHash = collabKey collabProject
+            STM.modifyTVar (collabProjects state) $ HM.delete collabHash
+        False -> do
+            STM.modifyTVar collabProjectTV (\collabProject' -> collabProject'
+                                                { totalUsers = totalUsers collabProject' - 1
+                                                , users = filter ((/= userId') . suserId) $
+                                                    users collabProject'
+                                                })
+
+-- Collaboration requests handler
+
+collabServer :: CollabServerState -> ClientId -> StateT SIO.RoutingTable (ReaderT SIO.Socket Snap) ()
+collabServer state clientId = do
+    (userId', userIdent', collabHash) <- liftSnap $ initCollaborationHandler state clientId
+    let userHash = hashToId "U" . BC.pack $ (show userId') ++ (show . unCollabId $ collabHash)
+    SIO.broadcastJSON "set_name" [toJSON userHash, toJSON userIdent']
+    SIO.broadcast "add_user" userIdent'
+    SIO.emitJSON "logged_in" []
+    currentUsers' <- liftIO . STM.atomically $ do
+        collabProjectTV <- getCollabProject state collabHash
+        (\x -> map suserIdent $ users x) <$> STM.readTVar collabProjectTV
+    collabProjectTV' <- liftIO . STM.atomically $ getCollabProject state collabHash
+    OTS.ServerState rev' doc _ <- liftIO $ collabState <$> STM.readTVarIO collabProjectTV'
+    SIO.emit "doc" $ object
+        [ "str"      .= doc
+        , "revision" .= rev'
+        , "clients"  .= currentUsers'
+        ]
+
+    SIO.on "operation" $ \rev op (sel :: Sel.Selection) -> do
+        res <- liftIO . STM.atomically $ do
+            collabProjectTV <- getCollabProject state collabHash
+            serverState <- collabState <$> STM.readTVar collabProjectTV
+            case OTS.applyOperation serverState rev op sel of
+                Left err -> return $ Left err
+                Right (op', sel', serverState') -> do
+                    STM.modifyTVar collabProjectTV (\collabProject ->
+                      collabProject { collabState = serverState' })
+                    STM.modifyTVar (collabProjects state) $
+                      \x -> HM.adjust (\_ -> collabProjectTV) collabHash x
+                    return $ Right (op', sel')
+        case res of
+            Left _ -> return ()
+            Right (op', sel') -> do
+                SIO.emitJSON "ack" []
+                SIO.broadcastJSON "operation" [toJSON userHash, toJSON op', toJSON sel']
+
+    SIO.on "selection" $ \sel -> do
+        liftIO . STM.atomically $ do
+            collabProjectTV <- getCollabProject state collabHash
+            currentUsers <- users <$> STM.readTVar collabProjectTV
+            let currentUsers'' = map (\x -> if ((/= userId') . suserId) x
+                                               then x
+                                               else x{ userSelection = sel }) currentUsers
+            STM.modifyTVar collabProjectTV (\collabProject ->
+              collabProject { users = currentUsers'' })
+            STM.modifyTVar (collabProjects state) $
+              \x -> HM.adjust (\_ -> collabProjectTV) collabHash x
+        SIO.broadcastJSON "selection" [toJSON userHash, toJSON sel]
+
+    SIO.appendDisconnectHandler $ do
+        liftIO . STM.atomically $ do
+            collabProjectTV <- getCollabProject state collabHash
+            cleanUp state userId' collabProjectTV
+        SIO.broadcast "client_left" userHash
+        SIO.broadcast "remove_user" userIdent'

codeworld-collab-server/src/Main.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{-
+  Copyright 2017 The CodeWorld Authors. All rights reserved.
+
+  Licensed under the Apache License, Version 2.0 (the "License");
+  you may not use this file except in compliance with the License.
+  You may obtain a copy of the License at
+
+      http://www.apache.org/licenses/LICENSE-2.0
+
+  Unless required by applicable law or agreed to in writing, software
+  distributed under the License is distributed on an "AS IS" BASIS,
+  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+  See the License for the specific language governing permissions and
+  limitations under the License.
+-}
+
+import           Control.Applicative ((<|>))
+import           Control.Monad (unless)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Network.SocketIO as SIO
+import           Network.EngineIO.Snap (snapAPI)
+import           Snap.Core
+import           Snap.Http.Server
+import           System.Directory
+
+import CodeWorld.GameServer
+import CodeWorld.CollabServer
+import SnapUtil
+
+main :: IO ()
+main = do
+    hasClientId <- doesFileExist "web/clientId.txt"
+    unless hasClientId $ do
+        putStrLn "WARNING: Missing web/clientId.txt"
+        putStrLn "User logins will not function properly!"
+
+    clientId <- case hasClientId of
+        True -> do
+            txt <- T.readFile "web/clientId.txt"
+            return . ClientId . Just . T.strip $ txt
+        False -> do
+            return $ ClientId Nothing
+
+    gameServerState <- initGameServer
+    collabServerState <- initCollabServer
+    socketIOHandler <- SIO.initialize snapAPI (collabServer collabServerState clientId)
+    config <- commandLineConfig $
+        setPort 9160 $
+        setErrorLog  (ConfigFileLog "log/collab-error.log") $
+        setAccessLog (ConfigFileLog "log/collab-access.log") $
+        mempty
+    httpServe config $
+        ifTop (gameStats gameServerState) <|>
+        route [ ("gameserver", gameServer gameServerState)
+              , ("socket.io" , socketIOHandler)
+              ]