|
| 1 | +{-# LANGUAGE BangPatterns #-} |
| 2 | +{-# LANGUAGE DeriveGeneric #-} |
| 3 | +{-# LANGUAGE LambdaCase #-} |
| 4 | +{-# LANGUAGE OverloadedLists #-} |
| 5 | +{-# LANGUAGE OverloadedStrings #-} |
| 6 | +{-# LANGUAGE RecordWildCards #-} |
| 7 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 8 | + |
| 9 | +{- |
| 10 | + Copyright 2017 The CodeWorld Authors. All rights reserved. |
| 11 | +
|
| 12 | + Licensed under the Apache License, Version 2.0 (the "License"); |
| 13 | + you may not use this file except in compliance with the License. |
| 14 | + You may obtain a copy of the License at |
| 15 | +
|
| 16 | + http://www.apache.org/licenses/LICENSE-2.0 |
| 17 | +
|
| 18 | + Unless required by applicable law or agreed to in writing, software |
| 19 | + distributed under the License is distributed on an "AS IS" BASIS, |
| 20 | + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
| 21 | + See the License for the specific language governing permissions and |
| 22 | + limitations under the License. |
| 23 | +-} |
| 24 | + |
| 25 | +import qualified Control.Concurrent.STM as STM |
| 26 | +import Control.Monad.State.Strict (StateT) |
| 27 | +import Control.Monad.Trans |
| 28 | +import Control.Monad.Trans.Reader (ReaderT) |
| 29 | +import qualified Control.OperationalTransformation.Selection as Sel |
| 30 | +import qualified Control.OperationalTransformation.Server as OTS |
| 31 | +import Data.Aeson |
| 32 | +import qualified Data.HashMap.Strict as HM |
| 33 | +import Data.Maybe (fromJust) |
| 34 | +import Data.Text (Text) |
| 35 | +import qualified Data.Text as T |
| 36 | +import Data.Time.Clock |
| 37 | +import Network.HTTP.Conduit (simpleHttp) |
| 38 | +import qualified Network.SocketIO as SIO |
| 39 | +import Snap.Core |
| 40 | +import System.Directory |
| 41 | +import System.FilePath |
| 42 | + |
| 43 | +import CodeWorld.CollabModel |
| 44 | + |
| 45 | +module CodeWorld.CollabServer |
| 46 | + ( initCollabServer |
| 47 | + , collabServer |
| 48 | + ) where |
| 49 | + |
| 50 | +-- Initialize Collab Server |
| 51 | + |
| 52 | +initCollabServer :: IO CollabServerState |
| 53 | +initCollabServer = do |
| 54 | + started <- getCurrentTime |
| 55 | + collabProjects <- STM.newTVarIO HM.empty |
| 56 | + return CollabServerState {..} |
| 57 | + |
| 58 | +-- Collaboration requests helpers |
| 59 | + |
| 60 | +-- Retrieves the user for the current request. The request should have an |
| 61 | +-- id_token parameter with an id token retrieved from the Google |
| 62 | +-- authentication API. The user is returned if the id token is valid. |
| 63 | +getUser :: ClientId -> Snap User |
| 64 | +getUser clientId = getParam "id_token" >>= \ case |
| 65 | + Nothing -> pass |
| 66 | + Just id_token -> do |
| 67 | + let url = "https://www.googleapis.com/oauth2/v1/tokeninfo?id_token=" ++ BC.unpack id_token |
| 68 | + decoded <- fmap decode $ liftIO $ simpleHttp url |
| 69 | + case decoded of |
| 70 | + Nothing -> pass |
| 71 | + Just user -> do |
| 72 | + when (clientId /= ClientId (Just (audience user))) pass |
| 73 | + return user |
| 74 | + |
| 75 | +getBuildMode :: Snap BuildMode |
| 76 | +getBuildMode = getParam "mode" >>= \ case |
| 77 | + Just "haskell" -> return (BuildMode "haskell") |
| 78 | + Just "blocklyXML" -> return (BuildMode "blocklyXML") |
| 79 | + _ -> return (BuildMode "codeworld") |
| 80 | + |
| 81 | +getRequestParams :: ClientId -> Snap (Text, FilePath) |
| 82 | +getRequestParams clientId = do |
| 83 | + user <- getUser clientId |
| 84 | + mode <- getBuildMode |
| 85 | + Just path' <- fmap (splitDirectories . BC.unpack) <$> getParam "path" |
| 86 | + Just name <- getParam "name" |
| 87 | + let projectId = nameToProjectId $ T.decodeUtf8 name |
| 88 | + finalDir = joinPath $ map (dirBase . nameToDirId . T.pack) path' |
| 89 | + file = userProjectDir mode (userId user) </> finalDir </> projectFile projectId |
| 90 | + case (length path', path' !! 0) of |
| 91 | + (0, _) -> return (user, file) |
| 92 | + (_, x) | x /= "commentables" -> (user, file) |
| 93 | + |
| 94 | +initCollaborationHandler :: ClientId -> Snap (Text, Text, CollabId) |
| 95 | +initCollaborationHandler clientId = do |
| 96 | + (user, filePath) <- getRequestParams clientId |
| 97 | + collabHashPath <- liftIO $ BC.unpack <$> B.readFile filePath |
| 98 | + let collabHash = take (length collabHashPath - 3) . takeFileName $ collabHashPath |
| 99 | + Just (currentUsers :: [UserDump]) <- liftIO $ decodeStrict <$> |
| 100 | + B.readFile (collabHashPath <.> "users") |
| 101 | + let userIdent' = uuserIdent $ (filter (\x -> uuserId x == userId user) currentUsers) !! 0 |
| 102 | + Just (project :: Project) <- liftIO $ decodeStrict <$> |
| 103 | + B.readFile collabHashPath |
| 104 | + liftIO $ addNewCollaborator state (userId user) userIdent' (projectSource project) $ |
| 105 | + CollabId . T.pack $ collabHash |
| 106 | + return ((userId user), userIdent', CollabId . T.pack $ collabHash) |
| 107 | + |
| 108 | +getCollabProject :: CollabServerState -> CollabId -> STM.STM (STM.TVar CollabProject) |
| 109 | +getCollabProject state collabHash = do |
| 110 | + fromJust . HM.lookup collabHash >>= STM.readTVar (collabProjects state) |
| 111 | + |
| 112 | +addNewCollaborator :: CollabServerState -> Text -> Text -> Text -> CollabId -> IO () |
| 113 | +addNewCollaborator state userId' userIdent' projectSource collabHash = do |
| 114 | + let collabUser = CollabUserState userId' userIdent' mempty |
| 115 | + STM.atomically $ do |
| 116 | + hm <- STM.readTVar $ collabProjects state |
| 117 | + case HM.lookup collabHash hm of |
| 118 | + Just collabProjectTV -> do |
| 119 | + collabProject <- STM.readTVar collabProjectTV |
| 120 | + case userId' `elem` (map suserId $ users collabProject) of |
| 121 | + True -> do |
| 122 | + let collabProject' = collabProject |
| 123 | + { users = map (\x -> if suserId x == userId' |
| 124 | + then collabUser |
| 125 | + else x) $ users collabProject |
| 126 | + } |
| 127 | + collabProjectTV' <- STM.newTVar collabProject' |
| 128 | + STM.modifyTVar (collabProjects state) $ |
| 129 | + \x -> HM.adjust (\_ -> collabProjectTV') collabHash x |
| 130 | + False -> do |
| 131 | + let collabProject' = collabProject |
| 132 | + { totalUsers = totalUsers collabProject + 1 |
| 133 | + , users = collabUser : users collabProject |
| 134 | + } |
| 135 | + collabProjectTV' <- STM.newTVar collabProject' |
| 136 | + STM.modifyTVar (collabProjects state) $ |
| 137 | + \x -> HM.adjust (\_ -> collabProjectTV') collabHash x |
| 138 | + Nothing -> do |
| 139 | + let collabProject = CollabProject |
| 140 | + { totalUsers = 1 |
| 141 | + , collabKey = collabHash |
| 142 | + , collabState = OTS.initialServerState projectSource |
| 143 | + , users = [collabUser] |
| 144 | + } |
| 145 | + collabProjectTV <- STM.newTVar collabProject |
| 146 | + STM.modifyTVar (collabProjects state) $ |
| 147 | + \x -> HM.insert collabHash collabProjectTV x |
| 148 | + |
| 149 | +cleanUp :: CollabServerState -> Text -> STM.TVar CollabProject -> STM.STM () |
| 150 | +cleanUp state userId' collabProjectTV = do |
| 151 | + collabProject <- STM.readTVar collabProjectTV |
| 152 | + case null (filter ((/= userId') . suserId) $ users collabProject) of |
| 153 | + True -> do |
| 154 | + STM.modifyTVar collabProjectTV (\collabProject' -> collabProject' |
| 155 | + { totalUsers = 0 |
| 156 | + , users = [] |
| 157 | + }) |
| 158 | + let collabHash = collabKey collabProject |
| 159 | + STM.modifyTVar (collabProjects state) $ HM.delete collabHash |
| 160 | + False -> do |
| 161 | + STM.modifyTVar collabProjectTV (\collabProject' -> collabProject' |
| 162 | + { totalUsers = totalUsers collabProject' - 1 |
| 163 | + , users = filter ((/= userId') . suserId) $ |
| 164 | + users collabProject' |
| 165 | + }) |
| 166 | + |
| 167 | +-- Collaboration requests handler |
| 168 | + |
| 169 | +collabServer :: CollabServerState -> ClientId -> StateT SIO.RoutingTable (ReaderT SIO.Socket Snap) () |
| 170 | +collabServer state clientId = do |
| 171 | + (userId', userIdent', collabHash) <- liftSnap $ initCollaborationHandler state clientId |
| 172 | + let userHash = hashToId "U" . BC.pack $ (show userId') ++ (show . unCollabId $ collabHash) |
| 173 | + SIO.broadcastJSON "set_name" [toJSON userHash, toJSON userIdent'] |
| 174 | + SIO.broadcast "add_user" userIdent' |
| 175 | + SIO.emitJSON "logged_in" [] |
| 176 | + currentUsers' <- liftIO . STM.atomically $ do |
| 177 | + collabProjectTV <- getCollabProject state collabHash |
| 178 | + (\x -> map suserIdent $ users x) <$> STM.readTVar collabProjectTV |
| 179 | + collabProjectTV' <- liftIO . STM.atomically $ getCollabProject state collabHash |
| 180 | + OTS.ServerState rev' doc _ <- liftIO $ collabState <$> STM.readTVarIO collabProjectTV' |
| 181 | + SIO.emit "doc" $ object |
| 182 | + [ "str" .= doc |
| 183 | + , "revision" .= rev' |
| 184 | + , "clients" .= currentUsers' |
| 185 | + ] |
| 186 | + |
| 187 | + SIO.on "operation" $ \rev op (sel :: Sel.Selection) -> do |
| 188 | + res <- liftIO . STM.atomically $ do |
| 189 | + collabProjectTV <- getCollabProject state collabHash |
| 190 | + serverState <- collabState <$> STM.readTVar collabProjectTV |
| 191 | + case OTS.applyOperation serverState rev op sel of |
| 192 | + Left err -> return $ Left err |
| 193 | + Right (op', sel', serverState') -> do |
| 194 | + STM.modifyTVar collabProjectTV (\collabProject -> |
| 195 | + collabProject { collabState = serverState' }) |
| 196 | + STM.modifyTVar (collabProjects state) $ |
| 197 | + \x -> HM.adjust (\_ -> collabProjectTV) collabHash x |
| 198 | + return $ Right (op', sel') |
| 199 | + case res of |
| 200 | + Left _ -> return () |
| 201 | + Right (op', sel') -> do |
| 202 | + SIO.emitJSON "ack" [] |
| 203 | + SIO.broadcastJSON "operation" [toJSON userHash, toJSON op', toJSON sel'] |
| 204 | + |
| 205 | + SIO.on "selection" $ \sel -> do |
| 206 | + liftIO . STM.atomically $ do |
| 207 | + collabProjectTV <- getCollabProject state collabHash |
| 208 | + currentUsers <- users <$> STM.readTVar collabProjectTV |
| 209 | + let currentUsers'' = map (\x -> if ((/= userId') . suserId) x |
| 210 | + then x |
| 211 | + else x{ userSelection = sel }) currentUsers |
| 212 | + STM.modifyTVar collabProjectTV (\collabProject -> |
| 213 | + collabProject { users = currentUsers'' }) |
| 214 | + STM.modifyTVar (collabProjects state) $ |
| 215 | + \x -> HM.adjust (\_ -> collabProjectTV) collabHash x |
| 216 | + SIO.broadcastJSON "selection" [toJSON userHash, toJSON sel] |
| 217 | + |
| 218 | + SIO.appendDisconnectHandler $ do |
| 219 | + liftIO . STM.atomically $ do |
| 220 | + collabProjectTV <- getCollabProject state collabHash |
| 221 | + cleanUp state userId' collabProjectTV |
| 222 | + SIO.broadcast "client_left" userHash |
| 223 | + SIO.broadcast "remove_user" userIdent' |
0 commit comments