{-# 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 qualified Data.ByteString.Lazy as L
import Data.List.NonEmpty (NonEmpty(..), toList)
import Data.Monoid
import Data.Aeson

main :: IO ()
main = do
	exitstatus <- go ">>> debug-me started"
	putStrLn ""
	putStrLn ">>> debug-me is exiting..."
	exitWith exitstatus
  where
	go startmsg = runWithPty "bash" [] $ \(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

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

developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
developer ichan ochan = do
	startact <- atomically $ readTChan ochan
	case startact of
		Activity (Seen (Val b)) Nothing 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 = Val b
				, echoData = Val (sentSince ds)
				}
			let act = Activity entered (Just $ 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 (Val b)) (Just 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 :: B.ByteString -> Pty -> TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
user startmsg p ichan ochan = do
	let startact = Activity (Seen (Val (startmsg <> "\r\n"))) Nothing dummySignature
	atomically $ writeTChan ochan startact
	backlog <- newTVarIO $ Backlog ((hash startact, startact) :| [])
	_ <- sendPtyOutput p ochan backlog
		`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 -> IO ()
sendPtyOutput p ochan backlog = go
  where
	go = do
		b <- readPty p
		atomically $ do
			Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog
			let seen = Seen (Val b)
			let act = Activity seen (Just 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
	go = do
		networkDelay
		v <- 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 newact)
				else do
					return (Left ("illegal entry" :: String, encode newact, bl'))
		case v of
			Right entered -> do
				L.putStrLn (encode entered)
				writePty p (val (enteredData (activity entered)))
				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 _)
	| Just (fst b) == hp = Backlog (b :| [])
	| otherwise = Backlog (b :| go [] l)
  where
	go c [] = reverse c
	go c (x:xs)
		| Just (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 (lastseen@(lastseenhash, _lastseen) :| bl))
	| Just lastseenhash == hp = True
	| B.null (val (echoData entered)) = False -- optimisation
	| any (== hp) (map (Just . fst) bl) =
		let sincehp = reverse (lastseen : takeWhile (\(h, _) -> Just h /= hp) bl)
		in echoData entered == mconcat (map (seenData . activity . snd) sincehp)
	| otherwise = False
isLegal _ _ = False

dummySignature :: Signature
dummySignature = Signature mempty