diff options
-rw-r--r-- | Types.hs | 6 | ||||
-rw-r--r-- | debug-me.cabal | 1 | ||||
-rw-r--r-- | debug-me.hs | 200 |
3 files changed, 186 insertions, 21 deletions
@@ -27,9 +27,13 @@ data Activity a | StartActivity a Signature deriving (Show) +activityContent :: Activity a -> a +activityContent (Activity a _ _) = a +activityContent (StartActivity a _) = a + data Signature = Signature ByteString deriving (Show) -- | A SHA2 hash pointer to something that hashes to this value. newtype HashPointer = HashPointer (H.Digest H.SHA256) - deriving (Show) + deriving (Show, Eq) diff --git a/debug-me.cabal b/debug-me.cabal index 23edddc..cf9143c 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -28,6 +28,7 @@ Executable debug-me , unix (>= 2.7) , process (>= 1.4) , async (>= 2.1) + , stm (>= 2.4) Other-Modules: Hash Pty diff --git a/debug-me.hs b/debug-me.hs index 69870f1..4122881 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -1,16 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Types import Hash import Pty -import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import System.IO import System.Process import System.Exit import qualified Data.ByteString as B +import Data.List.NonEmpty (NonEmpty(..), toList) +import Data.Monoid main :: IO () main = do @@ -22,25 +25,182 @@ main = do go = withChildPty $ \p -> do (Nothing, Nothing, Nothing, ph) <- createProcess $ onPty p (proc "bash" []) - let Master h = ptyMaster p - hSetBuffering stdin NoBuffering - hSetBuffering h NoBuffering - ithread <- async (forward stdin h ph 200000) - othread <- async (forward h stdout ph 0) + ichan <- newTChanIO + ochan <- newTChanIO + dthread <- async (developer ichan ochan) + uthread <- async (user p ichan ochan ph) exitstatus <- waitForProcess ph - cancel ithread - cancel othread + cancel dthread + cancel uthread return exitstatus -forward :: Handle -> Handle -> ProcessHandle -> Int -> IO () -forward from to ph delay = do - b <- B.hGetSome from 1024 - if b == B.empty - then do - terminateProcess ph - return () - else do - threadDelay delay - B.hPut to b - hFlush to - forward from to ph delay +developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO () +developer ichan ochan = do + startact <- atomically $ readTChan ochan + case startact of + StartActivity (Seen b) sig -> do + B.hPut stdout b + hFlush stdout + _ -> return () + devstate <- newTVarIO (DeveloperState (hash startact) mempty) + _ <- sendTtyInput ichan devstate + `concurrently` sendTtyOutput ochan devstate + return () + +data DeveloperState = DeveloperState + { lastSeen :: HashPointer + , sentSince :: B.ByteString + } + deriving (Show) + +-- | Read things typed by the user, and forward them to the TChan. +sendTtyInput :: TChan (Activity Entered) -> TVar DeveloperState -> IO () +sendTtyInput ichan devstate = go + where + go = do + b <- B.hGetSome stdin 1024 + if b == B.empty + then return () + else send b + send b = do + atomically $ do + ds <- readTVar devstate + let entered = Entered + { enteredData = b + , echoData = sentSince ds + } + let act = Activity entered (lastSeen ds) dummySignature + writeTChan ichan act + let ds' = ds { sentSince = sentSince ds <> b } + writeTVar devstate ds' + go + +-- | Read activity from the TChan and display it. +sendTtyOutput :: TChan (Activity Seen) -> TVar DeveloperState -> IO () +sendTtyOutput ochan devstate = go + where + go = do + b <- atomically get + B.hPut stdout b + hFlush stdout + go + get = do + act <- readTChan ochan + ds <- readTVar devstate + case act of + Activity (Seen b) hp sig + | hp == lastSeen ds -> do + let ds' = DeveloperState + { lastSeen = hash act + -- XXX is this right? + -- What if we get + -- a Seen that is + -- part of what + -- sentSince + -- contained? + , sentSince = mempty + } + writeTVar devstate ds' + return b + -- Got an activity out of order or + -- missed one somehow. Ignore it? + _ -> return ("bad input") + +user :: Pty -> TChan (Activity Entered) -> TChan (Activity Seen) -> ProcessHandle -> IO () +user p ichan ochan ph = do + let startact = StartActivity (Seen ">>> debug-me started\r\n") dummySignature + atomically $ writeTChan ochan startact + backlog <- newTVarIO $ Backlog ((hash startact, startact) :| []) + _ <- sendPtyOutput p ochan backlog ph + `concurrently` sendPtyInput ichan p backlog + return () + +-- | Log of recent output, with the most recent output first. +data Backlog = Backlog (NonEmpty (HashPointer, Activity Seen)) + deriving (Show) + +-- | Forward things written to the Pty out the TChan. +sendPtyOutput :: Pty -> TChan (Activity Seen) -> TVar Backlog -> ProcessHandle -> IO () +sendPtyOutput p ochan backlog ph = go + where + Master h = ptyMaster p + go = do + b <- B.hGetSome h 1024 + if b == B.empty + then do + terminateProcess ph + return () + else send b + send b = do + atomically $ do + Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog + let seen = Seen b + let act = Activity seen prevhash dummySignature + writeTChan ochan act + writeTVar backlog (Backlog ((hash act, act) :| toList bl)) + go + +-- | Read things to be entered from the TChan, verify if they're legal, +-- and send them to the Pty. +sendPtyInput :: TChan (Activity Entered) -> Pty -> TVar Backlog -> IO () +sendPtyInput ichan p backlog = go + where + Master h = ptyMaster p + go = do + mb <- atomically $ do + newact <- readTChan ichan + bl <- readTVar backlog + -- Don't need to retain backlog before the Activity + -- that newact references. + let bl' = truncateBacklog bl newact + if isLegal newact bl' + then do + writeTVar backlog bl' + return (Right (enteredData (activityContent newact))) + else do + return (Left ("illegal entry", newact, bl')) + case mb of + Right b -> do + B.hPut h b + hFlush h + go + Left e -> do + print e + go + +-- | Truncate the Backlog to remove entries older than the one +-- that the Activity refers to. +-- +-- If the activity refers to an item not in the backlog, no truncation is +-- done. +truncateBacklog :: Backlog -> Activity Entered -> Backlog +truncateBacklog (Backlog (b :| l)) (Activity _ hp _) + | fst b == hp = Backlog (b :| []) + | otherwise = Backlog (b :| go [] l) + where + go c [] = reverse c + go c (x:xs) + | fst x == hp = reverse (x:c) + | otherwise = go (x:c) xs +truncateBacklog (Backlog bl) _ = Backlog bl + +-- | Entered activity is only legal if it points to the last Seen activvity, +-- 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 HashPointer in the activity points +-- to an older Seen activity, then the echoData must match the +-- concatenation of all activities after that one, up to the most recent +-- Seen activity. +isLegal :: Activity Entered -> Backlog -> Bool +isLegal (Activity entered hp sig) (Backlog ((lastseenhash, _lastseen) :| bl)) + | lastseenhash == hp = True + | any (== hp) (map fst bl) = + let sincehp = reverse (takeWhile (\(h, _) -> h /= hp) bl) + in echoData entered == mconcat (map (seenData . activityContent . snd) sincehp) + | otherwise = False +isLegal _ _ = False + +dummySignature :: Signature +dummySignature = Signature mempty |