diff options
| -rw-r--r-- | Pty.hs | 52 | ||||
| -rw-r--r-- | Role/Developer.hs | 6 | ||||
| -rw-r--r-- | Role/User.hs | 21 | ||||
| -rw-r--r-- | Server.hs | 40 | ||||
| -rw-r--r-- | SessionID.hs | 46 | ||||
| -rw-r--r-- | TODO | 3 | ||||
| -rw-r--r-- | Types.hs | 18 | ||||
| -rw-r--r-- | WebSockets.hs | 31 |
8 files changed, 152 insertions, 65 deletions
@@ -1,4 +1,4 @@ -module Pty (Pty, runWithPty, readPty, writePty) where +module Pty (Pty, runWithPty, readPty, writePty, inRawMode) where import System.Posix import System.Posix.Pty @@ -25,24 +25,7 @@ runWithPty cmd params a = bracket setup cleanup go -- Set the pty's terminal attributes to the same ones that -- the outer terminal had. System.Posix.Pty.setTerminalAttributes p as Immediately - -- This is similar to cfmakeraw(3). - let masteras = as - `withoutMode` IgnoreBreak - `withoutMode` InterruptOnBreak - `withoutMode` CheckParity - `withoutMode` StripHighBit - `withoutMode` MapLFtoCR - `withoutMode` IgnoreCR - `withoutMode` MapCRtoLF - `withoutMode` StartStopOutput - `withoutMode` ProcessOutput - `withoutMode` EnableEcho - `withoutMode` EchoLF - `withoutMode` ProcessInput - `withoutMode` KeyboardInterrupts - `withoutMode` ExtendedFunctions - `withoutMode` EnableParity - System.Posix.setTerminalAttributes stdInput masteras Immediately + setRawMode as return (p, ph, as) cleanup (p, ph, as) = do -- Needed in case the provided action throws an exception @@ -57,3 +40,34 @@ runWithPty cmd params a = bracket setup cleanup go case msz of Nothing -> return () Just sz -> resizePty p (Console.width sz, Console.height sz) + +inRawMode :: IO a -> IO a +inRawMode a = bracket setup cleanup go + where + setup = do + as <- System.Posix.getTerminalAttributes stdInput + setRawMode as + return as + cleanup as = System.Posix.setTerminalAttributes stdInput as Immediately + go _ = a + +-- This is similar to cfmakeraw(3). +setRawMode :: TerminalAttributes -> IO () +setRawMode as = do + let as' = as + `withoutMode` IgnoreBreak + `withoutMode` InterruptOnBreak + `withoutMode` CheckParity + `withoutMode` StripHighBit + `withoutMode` MapLFtoCR + `withoutMode` IgnoreCR + `withoutMode` MapCRtoLF + `withoutMode` StartStopOutput + `withoutMode` ProcessOutput + `withoutMode` EnableEcho + `withoutMode` EchoLF + `withoutMode` ProcessInput + `withoutMode` KeyboardInterrupts + `withoutMode` ExtendedFunctions + `withoutMode` EnableParity + System.Posix.setTerminalAttributes stdInput as' Immediately diff --git a/Role/Developer.hs b/Role/Developer.hs index deceb6d..a53e841 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -8,6 +8,8 @@ import Log import Crypto import CmdLine import WebSockets +import SessionID +import Pty import Control.Concurrent.Async import Control.Concurrent.STM @@ -19,8 +21,8 @@ import Data.List run :: DeveloperOpts -> IO () run os = runClientApp $ clientApp (ConnectMode (T.pack (debugUrl os))) developer -developer :: TChan (Message Entered) -> TChan (Message Seen) -> IO () -developer ichan ochan = withLogger "debug-me-developer.log" $ \logger -> do +developer :: TChan (Message Entered) -> TChan (Message Seen) -> SessionID -> IO () +developer ichan ochan _ = inRawMode $ withLogger "debug-me-developer.log" $ \logger -> do -- Start by reading the initial two messages from the user side, -- their session key and the startup message. sessionmsg <- atomically $ readTChan ochan diff --git a/Role/User.hs b/Role/User.hs index 9412843..efbbb24 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -10,6 +10,7 @@ import Session import Crypto import CmdLine import WebSockets +import SessionID import Control.Concurrent.Async import Control.Concurrent.STM @@ -19,6 +20,7 @@ import qualified Data.ByteString as B import Data.List.NonEmpty (NonEmpty(..), toList) import Data.Monoid import Data.Time.Clock.POSIX +import System.IO run :: UserOpts -> IO ExitCode run os = do @@ -27,12 +29,19 @@ run os = do sessionDone return exitstatus where - go cmd cmdparams startmsg = runWithPty cmd cmdparams $ \(p, ph) -> do - runClientApp $ clientApp (InitMode mempty) $ \ichan ochan -> do - uthread <- async (user startmsg p ichan ochan) - exitstatus <- waitForProcess ph - cancel uthread - return exitstatus + go cmd cmdparams startmsg = do + putStr "Connecting to debug-me server..." + hFlush stdout + runClientApp $ clientApp (InitMode mempty) $ \ichan ochan sid -> do + let url = sessionIDUrl sid "localhost" 8081 + putStrLn "" + putStrLn $ "Others can connect to this session by running: debug-me --debug " ++ url + hFlush stdout + runWithPty cmd cmdparams $ \(p, ph) -> do + uthread <- async (user startmsg p ichan ochan) + exitstatus <- waitForProcess ph + cancel uthread + return exitstatus shellCommand :: UserOpts -> IO (String, [String]) shellCommand os = return ("dash", []) @@ -10,6 +10,7 @@ import Log import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.WebSockets +import Network.WebSockets hiding (Message) import qualified Network.WebSockets as WS import Network.HTTP.Types import Control.Concurrent.STM @@ -23,6 +24,8 @@ import Data.Time.Clock.POSIX server :: ServerOpts -> IO () server o = run (serverPort o) . app o =<< newServerState +-- | A server is a map of sessions, each of which consists of a broadcast +-- TMChan, which both users and developers write messages to. type ServerState = M.Map SessionID (TMChan Log) newServerState :: IO (TVar ServerState) @@ -46,7 +49,8 @@ websocketApp o ssv pending_conn = do Just sid -> developer o ssv sid conn user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO () -user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> +user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> do + sendTextData conn sid bracket (setup sid) (cleanup sid) (go logh) where setup sid = do @@ -66,7 +70,14 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> `concurrently` relayfromuser bchan return () - -- Read from logchan and store each value to the log file. + -- Relay all messages from the user's websocket to the + -- broadcast channel. + relayfromuser bchan = relayFromSocket conn $ \msg -> do + print ("got from user", msg) + l <- mkLog (User msg) <$> getPOSIXTime + atomically $ writeTMChan bchan l + + -- Read from logchan and store each message to the log file. storelog logh logchan = do v <- atomically $ readTMChan logchan case v of @@ -75,6 +86,7 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> writeLogHandle l logh storelog logh logchan + -- Relay developer messages from the channel to the user's websocket. relaytouser userchan = relayToSocket conn $ do v <- atomically $ readTMChan userchan return $ case v of @@ -82,10 +94,6 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> Developer m -> Just m User _ -> Nothing Nothing -> Nothing - - relayfromuser bchan = relayFromSocket conn $ \msg -> do - l <- mkLog (User msg) <$> getPOSIXTime - atomically $ writeTMChan bchan l developer :: ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO () developer o ssv sid conn = bracket setup cleanup go @@ -93,8 +101,24 @@ developer o ssv sid conn = bracket setup cleanup go setup = atomically $ M.lookup sid <$> readTVar ssv cleanup _ = return () go Nothing = error "Invalid session id!" - go (Just logchan) = relayToSocket conn $ do - v <- atomically $ readTMChan logchan + go (Just bchan) = do + sendTextData conn sid + -- TODO replay backlog + devchan <- atomically $ dupTMChan bchan + _ <- relayfromdeveloper bchan + `concurrently` relaytodeveloper devchan + return () + + -- Relay all messages from the developer's websocket to the + -- broadcast channel. + relayfromdeveloper bchan = relayFromSocket conn $ \msg -> do + print ("got from developer", msg) + l <- mkLog (Developer msg) <$> getPOSIXTime + atomically $ writeTMChan bchan l + + -- Relay user messages from the channel to the developer's websocket. + relaytodeveloper devchan = relayToSocket conn $ do + v <- atomically $ readTMChan devchan return $ case v of Just l -> case loggedMessage l of User m -> Just m diff --git a/SessionID.hs b/SessionID.hs index a47de8f..71f2150 100644 --- a/SessionID.hs +++ b/SessionID.hs @@ -1,21 +1,48 @@ -module SessionID (SessionID, mkSessionID, sessionLogFile, withSessionID) where +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} + +module SessionID ( + SessionID, + mkSessionID, + sessionLogFile, + withSessionID, + sessionIDUrl, +) where + +import Serialization import System.FilePath import Data.Text import System.IO +import Network.Wai.Handler.Warp (Port) +import Network.WebSockets hiding (Message) +import qualified Data.Aeson +import Data.Maybe -- | A SessionID is the base name of the log file to use, -- and may not contain any path information. newtype SessionID = SessionID FilePath - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance ToJSON SessionID +instance FromJSON SessionID --- | Smart constructor that enforces security requirements. +instance WebSocketsData SessionID where + -- fromDataMessage = fromLazyByteString . fromDataMessage + fromLazyByteString = fromMaybe (error "bad SessionID") . Data.Aeson.decode + toLazyByteString = Data.Aeson.encode + +-- | Smart constructor that enforces legal SessionID contents. +-- +-- The passed Text can either be the bare SessionID, or it can be an URL +-- which ends with the SessionID. mkSessionID :: Text -> Maybe SessionID mkSessionID t = - let f = unpack t - in if takeFileName f == f - then Just (SessionID f) - else Nothing + let s = unpack t + in if "http" `isPrefixOf` t + then Just $ SessionID $ takeFileName s + else if takeFileName s == s + then Just $ SessionID s + else Nothing sessionLogFile :: FilePath -> SessionID -> FilePath sessionLogFile dir (SessionID f) = dir </> "debug-me." ++ f ++ ".log" @@ -26,3 +53,8 @@ withSessionID dir a = do -- TODO find an unused log file and open it let sid = SessionID "1" withFile "debug-me-server.log" WriteMode $ \h -> a (h, sid) + +type UrlString = String + +sessionIDUrl :: SessionID -> String -> Port -> UrlString +sessionIDUrl (SessionID f) host port = "http://" ++ host ++ ":" ++ show port ++ "/" ++ f @@ -1,3 +1,6 @@ +* Loop user input and output to their outer pty.. +* Improve error message when developer fails to connect due to the session + id being invalid or expored. * Use protobuf for serialization, to make non-haskell implementations easier? * Leave the prevMessage out of Activity serialization to save BW. @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts #-} {- | Main types for debug-me - @@ -15,6 +15,9 @@ module Types ( import Val import Memory import Serialization +import Network.WebSockets (WebSocketsData(..)) +import qualified Data.Binary +import qualified Data.ByteString.Lazy as L -- | Things that the developer sees. data Seen = Seen @@ -191,3 +194,16 @@ instance ToJSON ControlAction where toEncoding = genericToEncoding sumOptions instance FromJSON ControlAction where parseJSON = genericParseJSON sumOptions + +instance WebSocketsData (Message Seen) where + fromLazyByteString = decodeBinaryMessage + toLazyByteString = Data.Binary.encode + +instance WebSocketsData (Message Entered) where + fromLazyByteString = decodeBinaryMessage + toLazyByteString = Data.Binary.encode + +decodeBinaryMessage :: Binary (Message a) => L.ByteString -> Message a +decodeBinaryMessage b = case Data.Binary.decodeOrFail b of + Right (_, _, msg) -> msg + Left (_, _, err) -> error $ "Binary decode error: " ++ err diff --git a/WebSockets.hs b/WebSockets.hs index 8816b6b..c7893fb 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -4,15 +4,14 @@ module WebSockets where import Types import Serialization +import SessionID import Network.WebSockets hiding (Message) import Control.Concurrent.STM import Control.Concurrent.Async import Control.Exception import qualified Data.Aeson -import qualified Data.Binary import qualified Data.Text as T -import qualified Data.ByteString.Lazy as L import Data.List import Data.Maybe @@ -21,14 +20,15 @@ runClientApp = runClient "localhost" 8081 "/" -- | Make a client that sends and receives Messages over a websocket. clientApp - :: (WebSocketsData (Message sent), WebSocketsData (Message received)) + :: (Show sent, WebSocketsData (Message sent), WebSocketsData (Message received)) => Mode - -> (TChan (Message sent) -> TChan (Message received) -> IO a) + -> (TChan (Message sent) -> TChan (Message received) -> SessionID -> IO a) -> ClientApp a clientApp mode a conn = do vs <- negotiateWireVersion conn sendMode conn mode - bracket setup cleanup go + sid <- receiveData conn + bracket setup cleanup (go sid) where setup = do schan <- newTChanIO @@ -41,7 +41,7 @@ clientApp mode a conn = do cleanup (_, _, sthread, rthread) = do cancel sthread cancel rthread - go (schan, rchan, _, _) = a schan rchan + go sid (schan, rchan, _, _) = a schan rchan sid relayFromSocket :: WebSocketsData (Message received) => Connection -> (Message received -> IO ()) -> IO () relayFromSocket conn sender = go @@ -51,13 +51,14 @@ relayFromSocket conn sender = go sender msg go -relayToSocket :: WebSocketsData (Message sent) => Connection -> (IO (Maybe (Message sent))) -> IO () +relayToSocket :: Show sent => WebSocketsData (Message sent) => Connection -> (IO (Maybe (Message sent))) -> IO () relayToSocket conn getter = go where go = do mmsg <- getter + print ("got message", mmsg) case mmsg of - Nothing -> return () + Nothing -> go Just msg -> do sendBinaryData conn msg go @@ -83,7 +84,6 @@ negotiateWireVersion conn = do (_, remoteversions) <- concurrently (sendTextData conn supportedWireVersions) (receiveData conn) - print ("got versions" :: String, remoteversions) case reverse (intersect (sort supportedWireVersions) (sort remoteversions)) of (v:_) -> return v [] -> error $ "Unable to negotiate a WireVersion. I support: " ++ show supportedWireVersions ++ " They support: " ++ show remoteversions @@ -107,16 +107,3 @@ sendMode = sendTextData getMode :: Connection -> IO Mode getMode = receiveData - -instance WebSocketsData (Message Seen) where - fromLazyByteString = decodeBinaryMessage - toLazyByteString = Data.Binary.encode - -instance WebSocketsData (Message Entered) where - fromLazyByteString = decodeBinaryMessage - toLazyByteString = Data.Binary.encode - -decodeBinaryMessage :: Binary (Message a) => L.ByteString -> Message a -decodeBinaryMessage b = case Data.Binary.decodeOrFail b of - Right (_, _, msg) -> msg - Left (_, _, err) -> error $ "Binary decode error: " ++ err |