{- Copyright 2017 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE DeriveGeneric #-}

-- | debug-me session control unix socket

module ControlSocket where

import Types
import DotDir
import JSON

import System.IO
import System.Posix
import System.FilePath
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Concurrent.STM.TMChan
import Control.Exception
import qualified Network.Socket as S
import qualified Data.ByteString.Lazy as L
import Data.Char

data ControlInput
	= ControlInputAction ControlAction
	| ControlWindowMessage String
	deriving (Show, Generic)

data ControlOutput
	= ControlOutputAction ControlAction
	| ControlWindowOpened
	| ControlWindowRequestedImmediateQuit
	deriving (Show, Generic)

instance ToJSON ControlInput
instance FromJSON ControlInput
instance ToJSON ControlOutput
instance FromJSON ControlOutput

defaultSocketFile :: IO FilePath
defaultSocketFile = (</> "control") <$> dotDir

bindSocket :: FilePath -> IO S.Socket
bindSocket socketfile = do
	-- Delete any existing socket file.
	_ <- try (removeLink socketfile) :: IO (Either IOException ())
	soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
	S.bind soc (S.SockAddrUnix socketfile)
	setFileMode socketfile (unionFileModes ownerWriteMode ownerReadMode)
	S.listen soc 2
	return soc

-- | Serve connections to the control socket, feeding data between it and
-- the TMChans.
--
-- Returns once either of the TMChans is closed.
serveControlSocket :: S.Socket -> TMChan ControlInput -> TMChan ControlOutput -> IO ()
serveControlSocket soc ichan ochan = do
	_ <- serve `race` waitclose
	return ()
  where
	serve = do
		(sconn, _) <- S.accept soc
		conn <- S.socketToHandle sconn ReadWriteMode
		hSetBinaryMode conn True
		_ <- async $ sendToConn conn ichan
			`race` receiveFromConn conn ochan
		serve
	waitclose = atomically $ do
		ic <- isClosedTMChan ichan
		oc <- isClosedTMChan ochan
		if ic || oc
			then return ()
			else retry

-- | Connects to the control socket and feeds data between it and the
-- TMChans.
--
-- Returns when the socket server exits or the TMChan ControlInput is
-- closed.
connectControlSocket :: FilePath -> TMChan ControlInput -> TMChan ControlOutput -> IO ()
connectControlSocket socketfile ichan ochan = bracket setup cleanup connected
  where
	setup = do
		soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
		S.connect soc (S.SockAddrUnix socketfile)
		conn <- S.socketToHandle soc ReadWriteMode
		hSetBinaryMode conn True
		return conn
	cleanup conn = do
		hClose conn
		atomically $ do
			closeTMChan ichan
			closeTMChan ochan
	connected conn = do
		_ <- sendToConn conn ochan
			`race` receiveFromConn conn ichan
		return ()

sendToConn :: ToJSON a => Handle -> TMChan a -> IO ()
sendToConn conn chan = go =<< atomically (readTMChan chan)
  where
	go Nothing = return ()
	go (Just v) = do
		L.hPut conn (encode v)
		hPutStr conn "\n"
		hFlush conn
		sendToConn conn chan

receiveFromConn :: FromJSON a => Handle -> TMChan a -> IO ()
receiveFromConn conn chan = withLines conn go
  where
	go [] = return ()
	go (l:ls)
		| L.null l = go ls
		| otherwise = case decode l of
			Nothing -> error "internal control message parse error"
			Just v -> do
				atomically $ writeTMChan chan v
				go ls

withLines :: Handle -> ([L.ByteString] -> IO a) -> IO a
withLines conn a = do
	ls <- L.split nl <$> L.hGetContents conn
	a ls
  where
	nl = fromIntegral (ord '\n')