73 lines
2.0 KiB
Haskell
73 lines
2.0 KiB
Haskell
-- | 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
|
|
|
|
data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush | NeedPrecompiled
|
|
deriving (Read, Show, Eq)
|
|
|
|
type Marker = String
|
|
type Marked = String
|
|
|
|
statusMarker :: Marker
|
|
statusMarker = "STATUS"
|
|
|
|
privDataMarker :: String
|
|
privDataMarker = "PRIVDATA "
|
|
|
|
repoUrlMarker :: String
|
|
repoUrlMarker = "REPOURL "
|
|
|
|
gitPushMarker :: String
|
|
gitPushMarker = "GITPUSH"
|
|
|
|
toMarked :: Marker -> String -> String
|
|
toMarked = (++)
|
|
|
|
fromMarked :: Marker -> Marked -> Maybe String
|
|
fromMarked marker s
|
|
| marker `isPrefixOf` s = Just $ drop (length marker) s
|
|
| otherwise = Nothing
|
|
|
|
sendMarked :: Handle -> Marker -> String -> IO ()
|
|
sendMarked h marker s = do
|
|
debug ["sent marked", marker]
|
|
sendMarked' h marker s
|
|
|
|
sendMarked' :: Handle -> Marker -> String -> IO ()
|
|
sendMarked' h marker 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.
|
|
hPutStrLn h ("\n" ++ toMarked marker s)
|
|
hFlush h
|
|
|
|
getMarked :: Handle -> Marker -> IO (Maybe String)
|
|
getMarked h marker = go =<< catchMaybeIO (hGetLine h)
|
|
where
|
|
go Nothing = return Nothing
|
|
go (Just l) = case fromMarked marker l of
|
|
Nothing -> do
|
|
unless (null l) $
|
|
hPutStrLn stderr l
|
|
getMarked h marker
|
|
Just v -> do
|
|
debug ["received marked", marker]
|
|
return (Just v)
|
|
|
|
req :: Stage -> Marker -> (String -> IO ()) -> IO ()
|
|
req stage marker a = do
|
|
debug ["requested marked", marker]
|
|
sendMarked' stdout statusMarker (show stage)
|
|
maybe noop a =<< getMarked stdin marker
|