path: root/debug-me.hs

{-# 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
import Debug.Trace

main :: IO ()
main = do
	exitstatus <- go
	putStrLn ""
	putStrLn ">>> debug-me is exiting..."
	exitWith exitstatus
  where
	go = withChildPty $ \p -> do
		(Nothing, Nothing, Nothing, ph) <- createProcess $
			onPty p (proc "bash" [])
		ichan <- newTChanIO
		ochan <- newTChanIO
		dthread <- async (developer ichan ochan)
		uthread <- async (user p ichan ochan ph)
		exitstatus <- waitForProcess ph
		cancel dthread
		cancel uthread
		return exitstatus

-- | 800 ms is about the latency to geosync orbit
networkDelay :: IO ()
networkDelay = threadDelay 800000 -- 150000 -- 800000

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 developer, 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 to the developer.
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 ss = sentSince ds
					let ss' = if b `B.isPrefixOf` ss
						then B.drop (B.length b) ss
						else mempty
					let ds' = DeveloperState
						{ lastSeen = hash act
						, sentSince = ss'
						}
					writeTVar devstate ds'
					return b
			-- Got an activity out of order or
			-- missed one somehow. Ignore it?
			_ -> return mempty

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 do
				-- networkDelay
				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
		networkDelay
		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 (last@(lastseenhash, _lastseen) :| bl))
	| lastseenhash == hp = True
	| B.null (echoData entered) = False -- optimisation
	| any (== hp) (map fst bl) =
		let sincehp = reverse (last : takeWhile (\(h, _) -> h /= hp) bl)
		in echoData entered == mconcat (map (seenData . activityContent . snd) sincehp)
	| otherwise = False
isLegal _ _ = False

dummySignature :: Signature
dummySignature = Signature mempty