propellor/src/Propellor/Protocol.hs

65 lines
1.8 KiB
Haskell
Raw Normal View History

2014-11-18 17:29:50 +00:00
-- | 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.
2014-11-19 02:10:50 +00:00
--
-- 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.
2014-11-18 17:29:50 +00:00
module Propellor.Protocol where
import Data.List
import Propellor
data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush | NeedPrecompiled
2014-11-18 17:29:50 +00:00
deriving (Read, Show, Eq)
type Marker = String
type Marked = String
statusMarker :: Marker
statusMarker = "STATUS"
privDataMarker :: String
privDataMarker = "PRIVDATA "
2014-11-18 17:59:50 +00:00
repoUrlMarker :: String
repoUrlMarker = "REPOURL "
2014-11-18 19:05:15 +00:00
gitPushMarker :: String
gitPushMarker = "GITPUSH"
2014-11-18 17:29:50 +00:00
toMarked :: Marker -> String -> String
2014-11-18 19:15:56 +00:00
toMarked = (++)
2014-11-18 17:29:50 +00:00
2014-11-18 17:32:33 +00:00
fromMarked :: Marker -> Marked -> Maybe String
fromMarked marker s
| marker `isPrefixOf` s = Just $ drop (length marker) s
| otherwise = Nothing
2014-11-18 17:29:50 +00:00
sendMarked :: Handle -> Marker -> String -> IO ()
sendMarked h marker s = do
-- Prefix string with newline because sometimes a
2014-11-18 17:32:33 +00:00
-- incomplete line has been output, and the marker needs to
-- come at the start of a line.
2014-11-18 17:29:50 +00:00
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
2014-11-18 19:17:12 +00:00
go (Just l) = case fromMarked marker l of
Nothing -> do
2014-11-18 22:13:42 +00:00
unless (null l) $
hPutStrLn stderr l
getMarked h marker
2014-11-18 19:17:12 +00:00
Just v -> return (Just v)
2014-11-18 18:09:18 +00:00
req :: Stage -> Marker -> (String -> IO ()) -> IO ()
req stage marker a = do
sendMarked stdout statusMarker (show stage)
maybe noop a =<< getMarked stdin marker