-- | This is a simple line-based protocol used for communication between
-- a local and remote propellor. It's sent over a ssh channel, and lines of
-- the protocol can be interspersed with other, non-protocol lines
-- that should be passed through to be displayed.
--
-- Avoid making backwards-incompatible changes to this protocol,
-- since propellor needs to use this protocol to update itself to new
-- versions speaking newer versions of the protocol.

module Propellor.Protocol where

import Data.List

import Propellor.Base

data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush | NeedPrecompiled
	deriving (ReadPrec [Stage]
ReadPrec Stage
Int -> ReadS Stage
ReadS [Stage]
(Int -> ReadS Stage)
-> ReadS [Stage]
-> ReadPrec Stage
-> ReadPrec [Stage]
-> Read Stage
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Stage]
$creadListPrec :: ReadPrec [Stage]
readPrec :: ReadPrec Stage
$creadPrec :: ReadPrec Stage
readList :: ReadS [Stage]
$creadList :: ReadS [Stage]
readsPrec :: Int -> ReadS Stage
$creadsPrec :: Int -> ReadS Stage
Read, Int -> Stage -> ShowS
[Stage] -> ShowS
Stage -> String
(Int -> Stage -> ShowS)
-> (Stage -> String) -> ([Stage] -> ShowS) -> Show Stage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stage] -> ShowS
$cshowList :: [Stage] -> ShowS
show :: Stage -> String
$cshow :: Stage -> String
showsPrec :: Int -> Stage -> ShowS
$cshowsPrec :: Int -> Stage -> ShowS
Show, Stage -> Stage -> Bool
(Stage -> Stage -> Bool) -> (Stage -> Stage -> Bool) -> Eq Stage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stage -> Stage -> Bool
$c/= :: Stage -> Stage -> Bool
== :: Stage -> Stage -> Bool
$c== :: Stage -> Stage -> Bool
Eq)

type Marker = String
type Marked = String

statusMarker :: Marker
statusMarker :: String
statusMarker = "STATUS"

privDataMarker :: String
privDataMarker :: String
privDataMarker = "PRIVDATA "

repoUrlMarker :: String
repoUrlMarker :: String
repoUrlMarker = "REPOURL "

gitPushMarker :: String
gitPushMarker :: String
gitPushMarker = "GITPUSH"

toMarked :: Marker -> String -> String
toMarked :: String -> ShowS
toMarked = String -> ShowS
forall a. [a] -> [a] -> [a]
(++)

fromMarked :: Marker -> Marked -> Maybe String
fromMarked :: String -> String -> Maybe String
fromMarked marker :: String
marker s :: String
s
	| String
marker String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
marker) String
s
	| Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

sendMarked :: Handle -> Marker -> String -> IO ()
sendMarked :: Handle -> String -> String -> IO ()
sendMarked h :: Handle
h marker :: String
marker s :: String
s = do
	[String] -> IO ()
debug ["sent marked", String
marker]
	Handle -> String -> String -> IO ()
sendMarked' Handle
h String
marker String
s

sendMarked' :: Handle -> Marker -> String -> IO ()
sendMarked' :: Handle -> String -> String -> IO ()
sendMarked' h :: Handle
h marker :: String
marker s :: String
s = do
	-- Prefix string with newline because sometimes a
	-- incomplete line has been output, and the marker needs to
	-- come at the start of a line.
	Handle -> String -> IO ()
hPutStrLn Handle
h ("\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS
toMarked String
marker String
s)
	Handle -> IO ()
hFlush Handle
h

getMarked :: Handle -> Marker -> IO (Maybe String)
getMarked :: Handle -> String -> IO (Maybe String)
getMarked h :: Handle
h marker :: String
marker = Maybe String -> IO (Maybe String)
go (Maybe String -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String -> IO (Maybe String)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (Handle -> IO String
hGetLine Handle
h)
  where
	go :: Maybe String -> IO (Maybe String)
go Nothing = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
	go (Just l :: String
l) = case String -> String -> Maybe String
fromMarked String
marker String
l of
		Nothing -> do
			Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
				Handle -> String -> IO ()
hPutStrLn Handle
stderr String
l
			Handle -> String -> IO (Maybe String)
getMarked Handle
h String
marker
		Just v :: String
v -> do
			[String] -> IO ()
debug ["received marked", String
marker]
			Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
v)

req :: Stage -> Marker -> (String -> IO ()) -> IO ()
req :: Stage -> String -> (String -> IO ()) -> IO ()
req stage :: Stage
stage marker :: String
marker a :: String -> IO ()
a = do
	[String] -> IO ()
debug ["requested marked", String
marker]
	Handle -> String -> String -> IO ()
sendMarked' Handle
stdout String
statusMarker (Stage -> String
forall a. Show a => a -> String
show Stage
stage)
	IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
forall (m :: * -> *). Monad m => m ()
noop String -> IO ()
a (Maybe String -> IO ()) -> IO (Maybe String) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> String -> IO (Maybe String)
getMarked Handle
stdin String
marker