From 5572dbc8289de934e9ee5bc3f74a0f98365ce3e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 21 Apr 2017 17:42:10 -0400 Subject: initial http server Incomplete, but the client is able to connect and send messages which get logged. Split up debug-me.hs into Role/* Switched from cereal to binary, since websockets operate on lazy ByteStrings, and using cereal would involve a copy on every receive. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon. --- CmdLine.hs | 32 +++- Log.hs | 4 + Role/Developer.hs | 239 ++++++++++++++++++++++++++ Role/User.hs | 252 +++++++++++++++++++++++++++ Serialization.hs | 4 +- Server.hs | 95 ++++++++++- SessionID.hs | 28 +++ TODO | 1 - Types.hs | 28 +-- Val.hs | 2 +- WebSockets.hs | 113 +++++++++++++ debug-me.cabal | 10 +- debug-me.hs | 496 +----------------------------------------------------- 13 files changed, 783 insertions(+), 521 deletions(-) create mode 100644 Role/Developer.hs create mode 100644 Role/User.hs create mode 100644 SessionID.hs create mode 100644 WebSockets.hs diff --git a/CmdLine.hs b/CmdLine.hs index 2c71327..db3c749 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -9,10 +9,19 @@ data CmdLine = CmdLine } data Mode - = Test - | Graphviz GraphvizOpts - | Replay ReplayOpts - | Server ServerOpts + = UserMode UserOpts + | DeveloperMode DeveloperOpts + | GraphvizMode GraphvizOpts + | ReplayMode ReplayOpts + | ServerMode ServerOpts + +data UserOpts = UserOpts + { + } + +data DeveloperOpts = DeveloperOpts + { debugUrl :: String + } data GraphvizOpts = GraphvizOpts { graphvizLogFile :: FilePath @@ -32,10 +41,11 @@ parseCmdLine :: Parser CmdLine parseCmdLine = CmdLine <$> parseMode parseMode :: Parser Mode -parseMode = (Graphviz <$> parsegraphviz) - <|> (Replay <$> parsereplay) - <|> (Server <$> parseserver) - <|> pure Test -- default, so last +parseMode = (GraphvizMode <$> parsegraphviz) + <|> (ReplayMode <$> parsereplay) + <|> (ServerMode <$> parseserver) + <|> (DeveloperMode <$> parsedeveloper) + <|> pure (UserMode (UserOpts {})) -- default, so last where parsegraphviz = GraphvizOpts <$> option str @@ -66,6 +76,12 @@ parseMode = (Graphviz <$> parsegraphviz) <> showDefault <> help "port for server to listen on" ) + parsedeveloper = DeveloperOpts + <$> option str + ( long "debug" + <> metavar "url" + <> help "debug a user on the given url" + ) getCmdLine :: IO CmdLine getCmdLine = execParser opts diff --git a/Log.hs b/Log.hs index 05cbdc3..ec7078e 100644 --- a/Log.hs +++ b/Log.hs @@ -71,6 +71,10 @@ withLogger logfile a = withFile logfile WriteMode (a . mkLogger) mkLogger :: Handle -> Logger mkLogger h a = do l <- mkLog a <$> getPOSIXTime + writeLogHandle l h + +writeLogHandle :: Log -> Handle -> IO () +writeLogHandle l h = do L.hPut h (encode l) hPutStr h "\n" hFlush h diff --git a/Role/Developer.hs b/Role/Developer.hs new file mode 100644 index 0000000..deceb6d --- /dev/null +++ b/Role/Developer.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Role.Developer where + +import Types +import Hash +import Log +import Crypto +import CmdLine +import WebSockets + +import Control.Concurrent.Async +import Control.Concurrent.STM +import System.IO +import qualified Data.ByteString as B +import qualified Data.Text as T +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 + -- Start by reading the initial two messages from the user side, + -- their session key and the startup message. + sessionmsg <- atomically $ readTChan ochan + logger $ User sessionmsg + sigverifier <- case sessionmsg of + ControlMessage c@(Control (SessionKey pk) _) -> + let sv = mkSigVerifier pk + in if verifySigned sv c + then return sv + else error "Badly signed session initialization message" + _ -> error $ "Unexpected session initialization message: " ++ show sessionmsg + startmsg <- atomically $ readTChan ochan + logger $ User startmsg + starthash <- case startmsg of + ActivityMessage act@(Activity (Seen (Val b)) Nothing _) + | verifySigned sigverifier act -> do + B.hPut stdout b + hFlush stdout + return (hash act) + _ -> error $ "Unexpected startup message: " ++ show startmsg + + sk <- genMySessionKey + devstate <- newTVarIO $ DeveloperState + { lastSeen = starthash + , sentSince = mempty + , enteredSince = mempty + , lastActivity = starthash + , developerSessionKey = sk + , developerSigVerifier = sigverifier + } + ok <- authUser ichan ochan devstate logger + if ok + then do + _ <- sendTtyInput ichan devstate logger + `concurrently` sendTtyOutput ochan devstate logger + return () + else do + hPutStrLn stderr "\nUser did not grant access to their terminal." + +data DeveloperState = DeveloperState + { lastSeen :: Hash + , sentSince :: [B.ByteString] + , enteredSince :: [Hash] + , lastActivity :: Hash + , developerSessionKey :: MySessionKey + , developerSigVerifier :: SigVerifier + } + +-- | Read things typed by the developer, and forward them to the TChan. +sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () +sendTtyInput ichan devstate logger = go + where + go = do + b <- B.hGetSome stdin 1024 + if b == B.empty + then return () + else send b + send b = do + act <- atomically $ do + ds <- readTVar devstate + let ed = if lastActivity ds == lastSeen ds + then B.concat $ sentSince ds + else case reverse (sentSince ds) of + [] -> mempty + (lb:_) -> lb + let entered = Entered + { enteredData = Val b + , echoData = Val ed + } + let act = mkSigned (developerSessionKey ds) $ + Activity entered (Just $ lastActivity ds) + writeTChan ichan (ActivityMessage act) + let acth = hash act + let ds' = ds + { sentSince = sentSince ds ++ [b] + , enteredSince = enteredSince ds ++ [acth] + , lastActivity = acth + } + writeTVar devstate ds' + return act + logger $ Developer $ ActivityMessage act + go + +-- | Read activity from the TChan and display it to the developer. +sendTtyOutput :: TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO () +sendTtyOutput ochan devstate logger = go + where + go = do + (o, msg) <- atomically $ getUserMessage ochan devstate + logger $ User msg + emitOutput o + go + +-- | Present our session key to the user. +-- Wait for them to accept or reject it, while displaying any Seen data +-- in the meantime. +authUser :: TChan (Message Entered) -> TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO Bool +authUser ichan ochan devstate logger = do + ds <- atomically $ readTVar devstate + pk <- myPublicKey (developerSessionKey ds) + let msg = ControlMessage $ mkSigned (developerSessionKey ds) + (Control (SessionKey pk)) + atomically $ writeTChan ichan msg + logger $ Developer msg + waitresp pk + where + waitresp pk = do + (o, msg) <- atomically $ getUserMessage ochan devstate + logger $ User msg + emitOutput o + case o of + GotControl (SessionKeyAccepted pk') + | pk' == pk -> return True + GotControl (SessionKeyRejected pk') + | pk' == pk -> return False + _ -> waitresp pk + +data Output + = TtyOutput B.ByteString + | Beep + | ProtocolError String + | GotControl ControlAction + +emitOutput :: Output -> IO () +emitOutput (ProtocolError e) = + error e +emitOutput (TtyOutput b) = do + B.hPut stdout b + hFlush stdout +emitOutput Beep = do + B.hPut stdout "\a" + hFlush stdout +emitOutput (GotControl _) = + return () + +-- | Get messages from user, check their signature, and make sure that they +-- are properly chained from past messages, before returning. +getUserMessage :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen) +getUserMessage ochan devstate = do + msg <- readTChan ochan + ds <- readTVar devstate + -- Check signature before doing anything else. + if verifySigned (developerSigVerifier ds) msg + then do + o <- process ds msg + return (o, msg) + else getUserMessage ochan devstate + where + process ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do + let (legal, ds') = isLegalSeen act ds + if legal + then do + writeTVar devstate ds' + return (TtyOutput b) + else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act)) + process ds (ControlMessage (Control (Rejected _) _)) = do + -- When they rejected a message we sent, + -- anything we sent subsequently will + -- also be rejected, so forget about it. + let ds' = ds + { sentSince = mempty + , enteredSince = mempty + } + writeTVar devstate ds' + return Beep + process _ (ControlMessage (Control c@(SessionKey _) _)) = + return (GotControl c) + process _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) = + return (GotControl c) + process _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = + return (GotControl c) + +-- | Check if the Seen activity is legal, forming a chain with previous +-- ones, and returns an updated DeveloperState. +-- +-- Does not check the signature. +isLegalSeen :: Activity Seen -> DeveloperState -> (Bool, DeveloperState) +isLegalSeen (Activity _ Nothing _) ds = (False, ds) +isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds + -- Does it chain to the last Seen activity? + | hp == lastSeen ds = + -- Trim sentSince and enteredSince to + -- values after the Seen value. + let ss = sentSince ds + es = enteredSince ds + n = B.length b + (ss', es') = if b `B.isPrefixOf` mconcat ss + then (drop n ss, drop n es) + else (mempty, mempty) + in yes ds + { lastSeen = acth + , sentSince = ss' + , enteredSince = es' + , lastActivity = acth + } + -- Does it chain to something we've entered since the last Seen + -- value? Eg, user sent A, we replied B C, and the user has + -- now replied to B. + -- If so, we can drop B (and anything before it) from + -- enteredSince and sentSince. + | otherwise = case elemIndex hp (enteredSince ds) of + Nothing -> (False, ds) + Just i -> + let ss = sentSince ds + es = enteredSince ds + ss' = drop (i+1) ss + es' = drop (i+1) es + in yes ds + { lastSeen = acth + , sentSince = ss' + , enteredSince = es' + , lastActivity = acth + } + where + acth = hash act + yes ds' = (True, ds') diff --git a/Role/User.hs b/Role/User.hs new file mode 100644 index 0000000..9412843 --- /dev/null +++ b/Role/User.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Role.User where + +import Types +import Pty +import Memory +import Log +import Session +import Crypto +import CmdLine +import WebSockets + +import Control.Concurrent.Async +import Control.Concurrent.STM +import System.Process +import System.Exit +import qualified Data.ByteString as B +import Data.List.NonEmpty (NonEmpty(..), toList) +import Data.Monoid +import Data.Time.Clock.POSIX + +run :: UserOpts -> IO ExitCode +run os = do + (cmd, cmdparams) <- shellCommand os + exitstatus <- go cmd cmdparams startSession + 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 + +shellCommand :: UserOpts -> IO (String, [String]) +shellCommand os = return ("dash", []) + +-- | Log of recent Activity, with the most recent first. +type Backlog = NonEmpty Log + +data UserState = UserState + { backLog :: Backlog + , userSessionKey :: MySessionKey + , userSigVerifier :: SigVerifier + } + +user :: B.ByteString -> Pty -> TChan (Message Seen) -> TChan (Message Entered) -> IO () +user starttxt p ochan ichan = withLogger "debug-me.log" $ \logger -> do + -- Start by establishing our session key, and displaying the starttxt. + let initialmessage msg = do + atomically $ writeTChan ochan msg + logger $ User msg + sk <- genMySessionKey + pk <- myPublicKey sk + let c = mkSigned sk $ Control (SessionKey pk) + initialmessage $ ControlMessage c + let act = mkSigned sk $ Activity (Seen (Val (starttxt <> "\r\n"))) Nothing + let startmsg = ActivityMessage act + initialmessage startmsg + l <- mkLog (User startmsg) <$> getPOSIXTime + us <- newTVarIO $ UserState + { backLog = l :| [] + , userSessionKey = sk + , userSigVerifier = mempty + } + _ <- sendPtyOutput p ochan us logger + `concurrently` sendPtyInput ichan ochan p us logger + return () + +-- | Forward things written to the Pty out the TChan. +sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO () +sendPtyOutput p ochan us logger = go + where + go = do + b <- readPty p + now <- getPOSIXTime + l <- atomically $ do + let seen = Seen (Val b) + sendDeveloper ochan us seen now + logger $ User l + go + +class SendableToDeveloper t where + sendDeveloper :: TChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen) + +instance SendableToDeveloper Seen where + sendDeveloper ochan us seen now = do + st <- readTVar us + let bl@(prev :| _) = backLog st + let msg = ActivityMessage $ + mkSigned (userSessionKey st) $ + Activity seen (loggedHash prev) + let l = mkLog (User msg) now + writeTChan ochan msg + writeTVar us $ st { backLog = l :| toList bl } + return msg + +instance SendableToDeveloper ControlAction where + sendDeveloper ochan us c _now = do + st <- readTVar us + let msg = ControlMessage $ + mkSigned (userSessionKey st) (Control c) + -- Control messages are not kept in the backlog. + writeTChan ochan msg + return msg + +-- | Read things to be entered from the TChan, verify if they're legal, +-- and send them to the Pty. +sendPtyInput :: TChan (Message Entered) -> TChan (Message Seen) -> Pty -> TVar UserState -> Logger -> IO () +sendPtyInput ichan ochan p us logger = go + where + go = do + now <- getPOSIXTime + v <- atomically $ getDeveloperMessage ichan ochan us now + case v of + InputMessage msg@(ActivityMessage entered) -> do + logger $ Developer msg + writePty p $ val $ enteredData $ activity entered + go + InputMessage msg@(ControlMessage (Control c _)) -> do + logger $ Developer msg + case c of + SessionKey pk -> do + checkDeveloperPublicKey ochan us logger pk + go + Rejected r -> error $ "User side received a Rejected: " ++ show r + SessionKeyAccepted _ -> error "User side received a SessionKeyAccepted" + SessionKeyRejected _ -> error "User side received a SessionKeyRejected" + RejectedMessage rej -> do + logger $ User rej + go + BadlySignedMessage _ -> go + +data Input + = InputMessage (Message Entered) + | RejectedMessage (Message Seen) + | BadlySignedMessage (Message Entered) + +-- Get message from developer, verify its signature is from a developer we +-- have allowed (unless it's a SessionKey control message, then the +-- signature of the message is only verified against the key in it), and +-- make sure it's legal before returning it. If it's not legal, sends a +-- Reject message. +getDeveloperMessage :: TChan (Message Entered) -> TChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input +getDeveloperMessage ichan ochan us now = do + msg <- readTChan ichan + st <- readTVar us + case msg of + ControlMessage (Control (SessionKey pk) _) -> do + let sigverifier = mkSigVerifier pk + if verifySigned sigverifier msg + then return (InputMessage msg) + else return (BadlySignedMessage msg) + _ -> if verifySigned (userSigVerifier st) msg + then case msg of + ActivityMessage entered -> do + -- Don't need to retain backlog + -- before the Activity that entered + -- references. + let bl' = reduceBacklog $ + truncateBacklog (backLog st) entered + if isLegalEntered entered (st { backLog = bl' }) + then do + let l = mkLog (Developer msg) now + writeTVar us (st { backLog = l :| toList bl' }) + return (InputMessage msg) + else do + let reject = Rejected entered + RejectedMessage <$> sendDeveloper ochan us reject now + ControlMessage (Control _ _) -> + return (InputMessage msg) + else return (BadlySignedMessage msg) + +-- | Check if the public key a developer presented is one we want to use, +-- and if so, add it to the userSigVerifier. +checkDeveloperPublicKey :: TChan (Message Seen) -> TVar UserState -> Logger -> PublicKey -> IO () +checkDeveloperPublicKey ochan us logger pk = do + now <- getPOSIXTime + -- TODO check gpg sig.. + msg <- atomically $ do + st <- readTVar us + let sv = userSigVerifier st + let sv' = sv `mappend` mkSigVerifier pk + let st' = st { userSigVerifier = sv' } + writeTVar us st' + sendDeveloper ochan us (SessionKeyAccepted pk) now + logger $ User msg + +-- | Truncate the Backlog to remove entries older than the one +-- that the Activity Entered refers to, but only if the referred +-- to Activity is an Activity Seen. +-- +-- Once the developer has referred to a given Activity Seen in +-- their Activity Entered, they cannot refer backwards to anything +-- that came before it. +-- +-- If the Activity refers to an item not in the backlog, no truncation is +-- done. +truncateBacklog :: Backlog -> Activity Entered -> Backlog +truncateBacklog (b :| l) (Activity _ (Just hp) _) + | truncationpoint b = b :| [] + | otherwise = b :| go [] l + where + go c [] = reverse c + go c (x:xs) + | truncationpoint x = reverse (x:c) + | otherwise = go (x:c) xs + truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp + truncationpoint _ = False +truncateBacklog bl (Activity _ Nothing _) = bl + +-- | To avoid DOS attacks that try to fill up the backlog and so use all +-- memory, don't let the backlog contain more than 1000 items, or +-- more than 16 megabytes of total data. (Excluding the most recent +-- item). +reduceBacklog :: Backlog -> Backlog +reduceBacklog (b :| l) = b :| go 0 (take 1000 l) + where + go _ [] = [] + go n (x:xs) + | n > 16777216 = [] + | otherwise = x : go (n + dataSize x) xs + +-- | Entered activity is legal when it points to the last logged activity, +-- because this guarantees that the person who entered it saw +-- the current state of the system before manipulating it. +-- +-- To support typeahead on slow links, some echoData may be provided +-- in the Entered activity. If the Entered activity points +-- to an older activity, then the echoData must match the +-- concatenation of all Seen activities after that one, up to the +-- last logged activity. +-- +-- Activities that do not enter data point to the first message +-- sent in the debug-me session. +-- +-- Does not check the signature. +isLegalEntered :: Activity Entered -> UserState -> Bool +isLegalEntered (Activity _ Nothing _) _ = False +isLegalEntered (Activity a (Just hp) _) us + | loggedHash lastact == Just hp = True + | B.null (val (echoData a)) = False -- optimisation + | any (== Just hp) (map loggedHash bl) = + let sincehp = reverse (lastact : takeWhile (\l -> loggedHash l /= Just hp) bl) + in echoData a == mconcat (map (getseen . loggedMessage) sincehp) + | otherwise = False + where + (lastact :| bl) = backLog us + getseen (User (ActivityMessage as)) = seenData $ activity as + getseen _ = mempty diff --git a/Serialization.hs b/Serialization.hs index 6940550..bba2a52 100644 --- a/Serialization.hs +++ b/Serialization.hs @@ -1,12 +1,12 @@ module Serialization ( module Data.Aeson, - Serialize, + Binary, Generic, sumOptions ) where import GHC.Generics (Generic) -import Data.Serialize +import Data.Binary import Data.Aeson import qualified Data.Aeson.Types as Aeson diff --git a/Server.hs b/Server.hs index 5d919b8..37316c3 100644 --- a/Server.hs +++ b/Server.hs @@ -3,24 +3,105 @@ module Server where import CmdLine +import WebSockets +import SessionID +import Log import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.WebSockets import qualified Network.WebSockets as WS import Network.HTTP.Types -import Data.Text (Text) +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import Control.Concurrent.Async +import qualified Data.Map as M +import System.IO +import Control.Exception +import Data.Time.Clock.POSIX server :: ServerOpts -> IO () -server o = run (serverPort o) app +server o = run (serverPort o) . app o =<< newServerState -app :: Application -app = websocketsOr WS.defaultConnectionOptions websocketApp webapp +type ServerState = M.Map SessionID (TMChan Log) + +newServerState :: IO (TVar ServerState) +newServerState = newTVarIO M.empty + +app :: ServerOpts -> TVar ServerState -> Application +app o ssv = websocketsOr WS.defaultConnectionOptions (websocketApp o ssv) webapp where webapp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request" -websocketApp :: WS.ServerApp -websocketApp pending_conn = do +websocketApp :: ServerOpts -> TVar ServerState -> WS.ServerApp +websocketApp o ssv pending_conn = do + print ("new connection" :: String) conn <- WS.acceptRequest pending_conn - WS.sendTextData conn ("Hello, client!" :: Text) + sendWireVersions conn + print ("new connection open" :: String) + -- wv <- negotiateWireVersion conn + -- print ("version negotiated" :: String, wv) + theirmode <- getMode conn + print ("Connected" :: String, theirmode) + case theirmode of + InitMode _ -> user o ssv conn + ConnectMode t -> case mkSessionID t of + Nothing -> error "Invalid session id!" + Just sid -> developer o ssv sid conn + +user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO () +user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> + bracket (setup sid) (cleanup sid) (go logh) + where + setup sid = do + bchan <- newBroadcastTMChanIO + atomically $ modifyTVar' ssv $ M.insert sid bchan + return bchan + + cleanup sid bchan = atomically $ do + closeTMChan bchan + modifyTVar' ssv $ M.delete sid + + go logh bchan = do + logchan <- atomically $ dupTMChan bchan + userchan <- atomically $ dupTMChan bchan + _ <- storelog logh logchan + `concurrently` relaytouser userchan + `concurrently` relayfromuser bchan + return () + + -- Read from logchan and store each value to the log file. + storelog logh logchan = do + v <- atomically $ readTMChan logchan + case v of + Nothing -> return () + Just l -> do + writeLogHandle l logh + storelog logh logchan + + relaytouser userchan = relayToSocket conn $ do + v <- atomically $ readTMChan userchan + return $ case v of + Just l -> case loggedMessage l of + 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 + where + 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 + return $ case v of + Just l -> case loggedMessage l of + User m -> Just m + Developer _ -> Nothing + Nothing -> Nothing diff --git a/SessionID.hs b/SessionID.hs new file mode 100644 index 0000000..a47de8f --- /dev/null +++ b/SessionID.hs @@ -0,0 +1,28 @@ +module SessionID (SessionID, mkSessionID, sessionLogFile, withSessionID) where + +import System.FilePath +import Data.Text +import System.IO + +-- | 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) + +-- | Smart constructor that enforces security requirements. +mkSessionID :: Text -> Maybe SessionID +mkSessionID t = + let f = unpack t + in if takeFileName f == f + then Just (SessionID f) + else Nothing + +sessionLogFile :: FilePath -> SessionID -> FilePath +sessionLogFile dir (SessionID f) = dir "debug-me." ++ f ++ ".log" + +-- | Allocate a new SessionID and return an open Handle to its log file. +withSessionID :: FilePath -> ((Handle, SessionID) -> IO a) -> IO a +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) diff --git a/TODO b/TODO index c9e93ec..6a63d26 100644 --- a/TODO +++ b/TODO @@ -17,4 +17,3 @@ * Multiple developers should be able to connect to a single debug-me user. Most of the code was written with that in mind, but not tested yet.. -* Add a protocol version (probably to the SessionKey message) diff --git a/Types.hs b/Types.hs index 699fa59..b28713d 100644 --- a/Types.hs +++ b/Types.hs @@ -2,7 +2,7 @@ {- | Main types for debug-me - - - Note that changing types in ways that change the cereal serialization + - Note that changing types in ways that change the Binary serialization - changes debug-me's wire format. Changing types in ways that change the - aeson serialization changes debug-me's log format. -} @@ -136,56 +136,56 @@ newtype GpgSig = GpgSig Val instance DataSize GpgSig where dataSize (GpgSig s) = dataSize s -instance Serialize Seen +instance Binary Seen instance ToJSON Seen instance FromJSON Seen -instance Serialize Entered +instance Binary Entered instance ToJSON Entered instance FromJSON Entered -instance Serialize (Activity Seen) +instance Binary (Activity Seen) instance ToJSON (Activity Seen) instance FromJSON (Activity Seen) -instance Serialize (Activity Entered) +instance Binary (Activity Entered) instance ToJSON (Activity Entered) instance FromJSON (Activity Entered) -instance Serialize Control +instance Binary Control instance ToJSON Control instance FromJSON Control -instance Serialize Hash +instance Binary Hash instance ToJSON Hash instance FromJSON Hash -instance Serialize HashMethod +instance Binary HashMethod instance ToJSON HashMethod instance FromJSON HashMethod -instance Serialize PublicKey +instance Binary PublicKey instance ToJSON PublicKey instance FromJSON PublicKey -instance Serialize GpgSig +instance Binary GpgSig instance ToJSON GpgSig instance FromJSON GpgSig -instance Serialize (Message Seen) +instance Binary (Message Seen) instance ToJSON (Message Seen) where toJSON = genericToJSON sumOptions toEncoding = genericToEncoding sumOptions instance FromJSON (Message Seen) where parseJSON = genericParseJSON sumOptions -instance Serialize (Message Entered) +instance Binary (Message Entered) instance ToJSON (Message Entered) where toJSON = genericToJSON sumOptions toEncoding = genericToEncoding sumOptions instance FromJSON (Message Entered) where parseJSON = genericParseJSON sumOptions -instance Serialize Signature +instance Binary Signature instance ToJSON Signature where toJSON = genericToJSON sumOptions toEncoding = genericToEncoding sumOptions instance FromJSON Signature where parseJSON = genericParseJSON sumOptions -instance Serialize ControlAction +instance Binary ControlAction instance ToJSON ControlAction where toJSON = genericToJSON sumOptions toEncoding = genericToEncoding sumOptions diff --git a/Val.hs b/Val.hs index 80ab8ed..3493bcd 100644 --- a/Val.hs +++ b/Val.hs @@ -19,7 +19,7 @@ newtype Val = Val { val :: B.ByteString } instance DataSize Val where dataSize (Val b) = fromIntegral (B.length b) -instance Serialize Val +instance Binary Val -- | JSON instances for Val, using base64 encoding when the value -- is not utf-8 encoded, and otherwise using a more efficient encoding. diff --git a/WebSockets.hs b/WebSockets.hs new file mode 100644 index 0000000..1f18b14 --- /dev/null +++ b/WebSockets.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric, GeneralizedNewtypeDeriving, FlexibleContexts #-} + +module WebSockets where + +import Types +import Serialization + +import Control.Concurrent.STM +import Control.Concurrent.Async +import Control.Exception +import qualified Data.Aeson +import qualified Data.Binary +import qualified Network.WebSockets as WS +import qualified Data.Text as T +import Data.List +import Data.Maybe + +runClientApp :: WS.ClientApp a -> IO a +runClientApp = WS.runClient "localhost" 8080 "/" + +-- | Make a client that sends and receives Messages over a websocket. +clientApp + :: (Binary (Message sent), Binary (Message received)) + => Mode + -> (TChan (Message sent) -> TChan (Message received) -> IO a) + -> WS.ClientApp a +clientApp mode a conn = bracket setup cleanup go + where + setup = do + schan <- newTChanIO + rchan <- newTChanIO + sthread <- async $ relayFromSocket conn $ + atomically . writeTChan rchan + rthread <- async $ relayToSocket conn $ + Just <$> atomically (readTChan schan) + return (schan, rchan, sthread, rthread) + cleanup (_, _, sthread, rthread) = do + cancel sthread + cancel rthread + go (schan, rchan, _, _) = do + print "sendWireVersions start" + print "negotiateWireVersion start" + _ <- negotiateWireVersion conn + --sendWireVersions conn + print "negotiateWireVersion done" + sendMode conn mode + print "sendmode now done" + a schan rchan + +relayFromSocket :: Binary (Message received) => WS.Connection -> (Message received -> IO ()) -> IO () +relayFromSocket conn send = go + where + go = do + dm <- WS.receiveDataMessage conn + case dm of + WS.Binary b -> case Data.Binary.decodeOrFail b of + Right (_, _, msg) -> do + send msg + go + Left (_, _, err) -> error $ "Deserialization error: " ++ err + WS.Text _ -> error "Unexpected Text received on websocket" + +relayToSocket :: Binary (Message sent) => WS.Connection -> (IO (Maybe (Message sent))) -> IO () +relayToSocket conn get = go + where + go = do + mmsg <- get + case mmsg of + Nothing -> return () + Just msg -> do + WS.sendDataMessage conn $ WS.Binary $ + Data.Binary.encode msg + go + +newtype WireVersion = WireVersion T.Text + deriving (Show, Eq, Generic, Ord) + +instance FromJSON WireVersion +instance ToJSON WireVersion + +supportedWireVersions :: [WireVersion] +supportedWireVersions = [WireVersion "1"] + +sendWireVersions :: WS.Connection -> IO () +sendWireVersions conn = WS.sendTextData conn (Data.Aeson.encode supportedWireVersions) + +-- | Send supportedWireVersions and at the same time receive it from +-- the remote side. The highest version present in both lists will be used. +negotiateWireVersion :: WS.Connection -> IO WireVersion +negotiateWireVersion conn = do + remoteversions <- WS.receiveData conn + print ("got versions" :: String) + case Data.Aeson.decode remoteversions of + Nothing -> error "Protocol error: WireVersion list was not sent" + Just l -> case reverse (intersect (sort supportedWireVersions) (sort l)) of + (v:_) -> return v + [] -> error $ "Unable to negotiate a WireVersion. I support: " ++ show supportedWireVersions ++ " They support: " ++ show l + +-- | Modes of operation that can be requested for a websocket connection. +data Mode + = InitMode T.Text + | ConnectMode T.Text + deriving (Show, Eq, Generic) + +instance FromJSON Mode +instance ToJSON Mode where + +sendMode :: WS.Connection -> Mode -> IO () +sendMode conn mode = WS.sendTextData conn (Data.Aeson.encode mode) + +getMode :: WS.Connection -> IO Mode +getMode conn = fromMaybe (error "Unknown mode") . Data.Aeson.decode + <$> WS.receiveData conn diff --git a/debug-me.cabal b/debug-me.cabal index f32f195..c7639fd 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -23,21 +23,25 @@ Executable debug-me GHC-Options: -threaded -Wall -fno-warn-tabs -O2 Build-Depends: base (>= 4.9 && < 5.0) + , network (>= 2.6) , bytestring == 0.10.* , cryptonite (>= 0.20) , unix (>= 2.7) , process (>= 1.4) , async (>= 2.1) , stm (>= 2.4) + , stm-chans (>= 3.0) , posix-pty (>= 0.2.1) , terminal-size (>= 0.3) , aeson (>= 0.11 && < 1.1) , sandi (>= 0.4) , text (>= 1.2.2) - , cereal (>= 0.5) + , binary (>= 0.8) , optparse-applicative (>= 0.12) , graphviz (== 2999.18.*) , time (>= 1.6) + , filepath (>= 1.4) + , containers (>= 0.5) , unbounded-delays (>= 0.1) , memory (>= 0.13) , warp (>= 3.2) @@ -54,11 +58,15 @@ Executable debug-me Memory Pty Replay + Role.Developer + Role.User Session Types Serialization Server + SessionID Val + WebSockets source-repository head type: git diff --git a/debug-me.hs b/debug-me.hs index a17a740..25f18b8 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -1,499 +1,21 @@ -{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts #-} - module Main where -import Types -import Hash -import Pty -import Memory import CmdLine -import Log +import qualified Role.User +import qualified Role.Developer import Graphviz import Replay -import Session -import Crypto import Server -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM -import System.IO -import System.Process +import Network.Socket import System.Exit -import qualified Data.ByteString as B -import Data.List -import Data.List.NonEmpty (NonEmpty(..), toList) -import Data.Monoid -import Data.Time.Clock.POSIX main :: IO () -main = do +main = withSocketsDo $ do c <- getCmdLine case mode c of - Test -> test - Graphviz o -> graphviz o - Replay o -> replay o - Server o -> server o - -test :: IO () -test = do - exitstatus <- go startSession - sessionDone - exitWith exitstatus - where - go startmsg = runWithPty "dash" [] $ \(p, ph) -> do - ichan <- newTChanIO - ochan <- newTChanIO - dthread <- async (developer ichan ochan) - uthread <- async (user startmsg p ichan ochan) - exitstatus <- waitForProcess ph - cancel dthread - cancel uthread - return exitstatus - -networkDelay :: IO () --- networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit -networkDelay = threadDelay 150000 -- 150 ms ; transatlantic latency - -developer :: TChan (Message Entered) -> TChan (Message Seen) -> IO () -developer ichan ochan = 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 - logger $ User sessionmsg - sigverifier <- case sessionmsg of - ControlMessage c@(Control (SessionKey pk) _) -> - let sv = mkSigVerifier pk - in if verifySigned sv c - then return sv - else protocolError "Badly signed session initialization message" - _ -> protocolError $ "Unexpected session initialization message: " ++ show sessionmsg - startmsg <- atomically $ readTChan ochan - logger $ User startmsg - starthash <- case startmsg of - ActivityMessage act@(Activity (Seen (Val b)) Nothing _) - | verifySigned sigverifier act -> do - B.hPut stdout b - hFlush stdout - return (hash act) - _ -> protocolError $ "Unexpected startup message: " ++ show startmsg - - sk <- genMySessionKey - devstate <- newTVarIO $ DeveloperState - { lastSeen = starthash - , sentSince = mempty - , enteredSince = mempty - , lastActivity = starthash - , developerSessionKey = sk - , developerSigVerifier = sigverifier - } - ok <- authUser ichan ochan devstate logger - if ok - then do - _ <- sendTtyInput ichan devstate logger - `concurrently` sendTtyOutput ochan devstate logger - return () - else do - hPutStrLn stderr "\nUser did not grant access to their terminal." - -data DeveloperState = DeveloperState - { lastSeen :: Hash - , sentSince :: [B.ByteString] - , enteredSince :: [Hash] - , lastActivity :: Hash - , developerSessionKey :: MySessionKey - , developerSigVerifier :: SigVerifier - } - --- | Read things typed by the developer, and forward them to the TChan. -sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () -sendTtyInput ichan devstate logger = go - where - go = do - b <- B.hGetSome stdin 1024 - if b == B.empty - then return () - else send b - send b = do - act <- atomically $ do - ds <- readTVar devstate - let ed = if lastActivity ds == lastSeen ds - then B.concat $ sentSince ds - else case reverse (sentSince ds) of - [] -> mempty - (lb:_) -> lb - let entered = Entered - { enteredData = Val b - , echoData = Val ed - } - let act = mkSigned (developerSessionKey ds) $ - Activity entered (Just $ lastActivity ds) - writeTChan ichan (ActivityMessage act) - let acth = hash act - let ds' = ds - { sentSince = sentSince ds ++ [b] - , enteredSince = enteredSince ds ++ [acth] - , lastActivity = acth - } - writeTVar devstate ds' - return act - logger $ Developer $ ActivityMessage act - go - --- | Read activity from the TChan and display it to the developer. -sendTtyOutput :: TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO () -sendTtyOutput ochan devstate logger = go - where - go = do - (o, msg) <- atomically $ getUserMessage ochan devstate - logger $ User msg - emitOutput o - go - --- | Present our session key to the user. --- Wait for them to accept or reject it, while displaying any Seen data --- in the meantime. -authUser :: TChan (Message Entered) -> TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO Bool -authUser ichan ochan devstate logger = do - ds <- atomically $ readTVar devstate - pk <- myPublicKey (developerSessionKey ds) - let msg = ControlMessage $ mkSigned (developerSessionKey ds) - (Control (SessionKey pk)) - atomically $ writeTChan ichan msg - logger $ Developer msg - waitresp pk - where - waitresp pk = do - (o, msg) <- atomically $ getUserMessage ochan devstate - logger $ User msg - emitOutput o - case o of - GotControl (SessionKeyAccepted pk') - | pk' == pk -> return True - GotControl (SessionKeyRejected pk') - | pk' == pk -> return False - _ -> waitresp pk - -data Output - = TtyOutput B.ByteString - | Beep - | ProtocolError String - | GotControl ControlAction - -emitOutput :: Output -> IO () -emitOutput (ProtocolError e) = - protocolError e -emitOutput (TtyOutput b) = do - B.hPut stdout b - hFlush stdout -emitOutput Beep = do - B.hPut stdout "\a" - hFlush stdout -emitOutput (GotControl _) = - return () - --- | Get messages from user, check their signature, and make sure that they --- are properly chained from past messages, before returning. -getUserMessage :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen) -getUserMessage ochan devstate = do - msg <- readTChan ochan - ds <- readTVar devstate - -- Check signature before doing anything else. - if verifySigned (developerSigVerifier ds) msg - then do - o <- process ds msg - return (o, msg) - else getUserMessage ochan devstate - where - process ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do - let (legal, ds') = isLegalSeen act ds - if legal - then do - writeTVar devstate ds' - return (TtyOutput b) - else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act)) - process ds (ControlMessage (Control (Rejected _) _)) = do - -- When they rejected a message we sent, - -- anything we sent subsequently will - -- also be rejected, so forget about it. - let ds' = ds - { sentSince = mempty - , enteredSince = mempty - } - writeTVar devstate ds' - return Beep - process _ (ControlMessage (Control c@(SessionKey _) _)) = - return (GotControl c) - process _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) = - return (GotControl c) - process _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = - return (GotControl c) - --- | Check if the Seen activity is legal, forming a chain with previous --- ones, and returns an updated DeveloperState. --- --- Does not check the signature. -isLegalSeen :: Activity Seen -> DeveloperState -> (Bool, DeveloperState) -isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds - -- Does it chain to the last Seen activity? - | hp == lastSeen ds = - -- Trim sentSince and enteredSince to - -- values after the Seen value. - let ss = sentSince ds - es = enteredSince ds - n = B.length b - (ss', es') = if b `B.isPrefixOf` mconcat ss - then (drop n ss, drop n es) - else (mempty, mempty) - in yes ds - { lastSeen = acth - , sentSince = ss' - , enteredSince = es' - , lastActivity = acth - } - -- Does it chain to something we've entered since the last Seen - -- value? Eg, user sent A, we replied B C, and the user has - -- now replied to B. - -- If so, we can drop B (and anything before it) from - -- enteredSince and sentSince. - | otherwise = case elemIndex hp (enteredSince ds) of - Nothing -> (False, ds) - Just i -> - let ss = sentSince ds - es = enteredSince ds - ss' = drop (i+1) ss - es' = drop (i+1) es - in yes ds - { lastSeen = acth - , sentSince = ss' - , enteredSince = es' - , lastActivity = acth - } - where - acth = hash act - yes ds' = (True, ds') -isLegalSeen (Activity _ Nothing _) ds = (False, ds) - -user :: B.ByteString -> Pty -> TChan (Message Entered) -> TChan (Message Seen) -> IO () -user starttxt p ichan ochan = withLogger "debug-me.log" $ \logger -> do - -- Start by establishing our session key, and displaying the starttxt. - let initialmessage msg = do - atomically $ writeTChan ochan msg - logger $ User msg - sk <- genMySessionKey - pk <- myPublicKey sk - let c = mkSigned sk $ Control (SessionKey pk) - initialmessage $ ControlMessage c - let act = mkSigned sk $ Activity (Seen (Val (starttxt <> "\r\n"))) Nothing - let startmsg = ActivityMessage act - initialmessage startmsg - l <- mkLog (User startmsg) <$> getPOSIXTime - us <- newTVarIO $ UserState - { backLog = l :| [] - , userSessionKey = sk - , userSigVerifier = mempty - } - _ <- sendPtyOutput p ochan us logger - `concurrently` sendPtyInput ichan ochan p us logger - return () - where - --- | Log of recent Activity, with the most recent first. -type Backlog = NonEmpty Log - -data UserState = UserState - { backLog :: Backlog - , userSessionKey :: MySessionKey - , userSigVerifier :: SigVerifier - } - --- | Forward things written to the Pty out the TChan. -sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO () -sendPtyOutput p ochan us logger = go - where - go = do - b <- readPty p - now <- getPOSIXTime - l <- atomically $ do - let seen = Seen (Val b) - sendDeveloper ochan us seen now - logger $ User l - go - -class SendableToDeveloper t where - sendDeveloper :: TChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen) - -instance SendableToDeveloper Seen where - sendDeveloper ochan us seen now = do - st <- readTVar us - let bl@(prev :| _) = backLog st - let msg = ActivityMessage $ - mkSigned (userSessionKey st) $ - Activity seen (loggedHash prev) - let l = mkLog (User msg) now - writeTChan ochan msg - writeTVar us $ st { backLog = l :| toList bl } - return msg - -instance SendableToDeveloper ControlAction where - sendDeveloper ochan us c _now = do - st <- readTVar us - let msg = ControlMessage $ - mkSigned (userSessionKey st) (Control c) - -- Control messages are not kept in the backlog. - writeTChan ochan msg - return msg - --- | Read things to be entered from the TChan, verify if they're legal, --- and send them to the Pty. -sendPtyInput :: TChan (Message Entered) -> TChan (Message Seen) -> Pty -> TVar UserState -> Logger -> IO () -sendPtyInput ichan ochan p us logger = go - where - go = do - networkDelay - now <- getPOSIXTime - v <- atomically $ getDeveloperMessage ichan ochan us now - case v of - InputMessage msg@(ActivityMessage entered) -> do - logger $ Developer msg - writePty p $ val $ enteredData $ activity entered - go - InputMessage msg@(ControlMessage (Control c _)) -> do - logger $ Developer msg - case c of - SessionKey pk -> do - checkDeveloperPublicKey ochan us logger pk - go - Rejected r -> protocolError $ "User side received a Rejected: " ++ show r - SessionKeyAccepted _ -> protocolError "User side received a SessionKeyAccepted" - SessionKeyRejected _ -> protocolError "User side received a SessionKeyRejected" - RejectedMessage rej -> do - logger $ User rej - go - BadlySignedMessage _ -> go - -data Input - = InputMessage (Message Entered) - | RejectedMessage (Message Seen) - | BadlySignedMessage (Message Entered) - --- Get message from developer, verify its signature is from a developer we --- have allowed (unless it's a SessionKey control message, then the --- signature of the message is only verified against the key in it), and --- make sure it's legal before returning it. If it's not legal, sends a --- Reject message. -getDeveloperMessage :: TChan (Message Entered) -> TChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input -getDeveloperMessage ichan ochan us now = do - msg <- readTChan ichan - st <- readTVar us - case msg of - ControlMessage (Control (SessionKey pk) _) -> do - let sigverifier = mkSigVerifier pk - if verifySigned sigverifier msg - then return (InputMessage msg) - else return (BadlySignedMessage msg) - _ -> if verifySigned (userSigVerifier st) msg - then case msg of - ActivityMessage entered -> do - -- Don't need to retain backlog - -- before the Activity that entered - -- references. - let bl' = reduceBacklog $ - truncateBacklog (backLog st) entered - if isLegalEntered entered (st { backLog = bl' }) - then do - let l = mkLog (Developer msg) now - writeTVar us (st { backLog = l :| toList bl' }) - return (InputMessage msg) - else do - let reject = Rejected entered - RejectedMessage <$> sendDeveloper ochan us reject now - ControlMessage (Control _ _) -> - return (InputMessage msg) - else return (BadlySignedMessage msg) - --- | Check if the public key a developer presented is one we want to use, --- and if so, add it to the userSigVerifier. -checkDeveloperPublicKey :: TChan (Message Seen) -> TVar UserState -> Logger -> PublicKey -> IO () -checkDeveloperPublicKey ochan us logger pk = do - now <- getPOSIXTime - -- TODO check gpg sig.. - msg <- atomically $ do - st <- readTVar us - let sv = userSigVerifier st - let sv' = sv `mappend` mkSigVerifier pk - let st' = st { userSigVerifier = sv' } - writeTVar us st' - sendDeveloper ochan us (SessionKeyAccepted pk) now - logger $ User msg - --- | Truncate the Backlog to remove entries older than the one --- that the Activity Entered refers to, but only if the referred --- to Activity is an Activity Seen. --- --- Once the developer has referred to a given Activity Seen in --- their Activity Entered, they cannot refer backwards to anything --- that came before it. --- --- If the Activity refers to an item not in the backlog, no truncation is --- done. -truncateBacklog :: Backlog -> Activity Entered -> Backlog -truncateBacklog (b :| l) (Activity _ (Just hp) _) - | truncationpoint b = b :| [] - | otherwise = b :| go [] l - where - go c [] = reverse c - go c (x:xs) - | truncationpoint x = reverse (x:c) - | otherwise = go (x:c) xs - truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp - truncationpoint _ = False -truncateBacklog bl (Activity _ Nothing _) = bl - --- | To avoid DOS attacks that try to fill up the backlog and so use all --- memory, don't let the backlog contain more than 1000 items, or --- more than 16 megabytes of total data. (Excluding the most recent --- item). -reduceBacklog :: Backlog -> Backlog -reduceBacklog (b :| l) = b :| go 0 (take 1000 l) - where - go _ [] = [] - go n (x:xs) - | n > 16777216 = [] - | otherwise = x : go (n + dataSize x) xs - --- | Entered activity is legal when it points to the last logged activity, --- because this guarantees that the person who entered it saw --- the current state of the system before manipulating it. --- --- To support typeahead on slow links, some echoData may be provided --- in the Entered activity. If the Entered activity points --- to an older activity, then the echoData must match the --- concatenation of all Seen activities after that one, up to the --- last logged activity. --- --- Activities that do not enter data point to the first message --- sent in the debug-me session. --- --- Does not check the signature. -isLegalEntered :: Activity Entered -> UserState -> Bool -isLegalEntered (Activity _ Nothing _) _ = False -isLegalEntered (Activity a (Just hp) _) us - | loggedHash lastact == Just hp = True - | B.null (val (echoData a)) = False -- optimisation - | any (== Just hp) (map loggedHash bl) = - let sincehp = reverse (lastact : takeWhile (\l -> loggedHash l /= Just hp) bl) - in echoData a == mconcat (map (getseen . loggedMessage) sincehp) - | otherwise = False - where - (lastact :| bl) = backLog us - getseen (User (ActivityMessage as)) = seenData $ activity as - getseen _ = mempty - --- | Temporary hack while user and developer share a process. -protocolError :: String -> IO a -protocolError e = do - hPutStrLn stderr e - hFlush stderr - _ <- exitWith (ExitFailure 101) - error e + UserMode o -> Role.User.run o >>= exitWith + DeveloperMode o -> Role.Developer.run o + GraphvizMode o -> graphviz o + ReplayMode o -> replay o + ServerMode o -> server o -- cgit v1.2.3