summaryrefslogtreecommitdiff
path: root/src/Propellor/Protocol.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Protocol.hs')
-rw-r--r--src/Propellor/Protocol.hs57
1 files changed, 57 insertions, 0 deletions
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
new file mode 100644
index 00000000..99afb31f
--- /dev/null
+++ b/src/Propellor/Protocol.hs
@@ -0,0 +1,57 @@
+-- | 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 ignored.
+
+module Propellor.Protocol where
+
+import Data.List
+
+import Propellor
+
+data Stage = Ready | NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush
+ 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
+ -- 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 -> getMarked h marker
+ Just v -> return (Just v)
+
+req :: Stage -> Marker -> (String -> IO ()) -> IO ()
+req stage marker a = do
+ sendMarked stdout statusMarker (show stage)
+ maybe noop a =<< getMarked stdin marker