magic wormhole module

This interacts with it using stdio, which is surprisingly hard.

sendFile does not currently work, due to
https://github.com/warner/magic-wormhole/issues/108

Parsing the output to find the magic code is done as robustly as
possible, and should continue to work unless wormhole radically changes
the format of its codes. Presumably it will never output something that
looks like a wormhole code before the actual wormhole code; that would
also break this. It would be better if there was a way to make
wormhole not mix the code with other output, as requested in
https://github.com/warner/magic-wormhole/issues/104

Only exchange of files/directories is supported. To exchange messages,
https://github.com/warner/magic-wormhole/issues/99 would need to be resolved.
I don't need message exchange however.

1 files changed, 112 insertions, 0 deletions

diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs
new file mode 100644
index 000000000..8a3758361
--- /dev/null
+++ b/Utility/MagicWormhole.hs
@@ -0,0 +1,112 @@
+{- Magic Wormhole integration
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.MagicWormHole where
+
+import Utility.Process
+import Utility.SafeCommand
+import Utility.Monad
+import Utility.Misc
+import Utility.FileSystemEncoding
+
+import System.IO
+import System.Exit
+import Control.Concurrent
+import Control.Exception
+import Data.Char
+
+-- | A Magic Wormhole code.
+type Code = String
+
+-- | Codes have the form number-word-word and may contain 2 or more words.
+validCode :: String -> Bool
+validCode s = 
+	let (n, r) = separate (== '-') s
+	    (w1, w2) = separate (== '-') r
+	in and
+		[ not (null n)
+		, all isDigit n
+		, not (null w1)
+		, not (null w2)
+		, not $ any isSpace s
+		]
+
+type CodeObserver = MVar Code
+
+type WormHoleParams = [CommandParam]
+
+mkCodeObserver :: IO CodeObserver
+mkCodeObserver = newEmptyMVar
+
+waitCode :: CodeObserver -> IO Code
+waitCode = takeMVar
+
+sendCode :: CodeObserver -> Code -> IO ()
+sendCode = putMVar
+
+-- | Sends a file. Once the send is underway, the Code will be sent to the
+-- CodeObserver.
+--
+-- Currently this has to parse the output of wormhole to find the code.
+-- To make this as robust as possible, avoids looking for any particular
+-- output strings, and only looks for the form of a wormhole code
+-- (number-word-word).
+--
+-- A request to make the code available in machine-parsable form is here:
+-- https://github.com/warner/magic-wormhole/issues/104
+--
+-- XXX This currently fails due to 
+-- https://github.com/warner/magic-wormhole/issues/108
+sendFile :: FilePath -> CodeObserver -> WormHoleParams -> IO Bool
+sendFile f o ps = runWormHoleProcess p $ \_hin hout -> do
+	fileEncoding hout
+	findcode =<< words <$> hGetContents hout
+  where
+	p = wormHoleProcess (Param "send" : ps ++ [File f])
+	findcode [] = return False
+	findcode (w:ws)
+		| validCode w = do
+			sendCode o w
+			return True
+		| otherwise = findcode ws
+
+-- | Receives a file. Once the receive is under way, the Code will be
+-- read from the CodeObserver, and fed to it on stdin.
+receiveFile :: FilePath -> CodeObserver -> WormHoleParams -> IO Bool
+receiveFile f o ps = runWormHoleProcess p $ \hin hout -> do
+	hPutStrLn hin =<< waitCode o
+	hFlush hin
+	return True
+  where
+	p = wormHoleProcess $
+		[ Param "receive"
+		, Param "--accept-file"
+		, Param "--output-file"
+		, File f
+		] ++ ps
+
+wormHoleProcess :: WormHoleParams -> CreateProcess
+wormHoleProcess = proc "wormhole" . toCommand
+
+runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> IO Bool) ->  IO Bool
+runWormHoleProcess p consumer = bracketOnError setup cleanup go
+  where
+	setup = do
+		(Just hin, Just hout, Nothing, pid)
+			<- createProcess p
+				{ std_in = CreatePipe
+				, std_out = CreatePipe
+				}
+		return (hin, hout, pid)
+	cleanup (hin, hout, pid) = do
+		r <- waitForProcess pid
+		hClose hin
+		hClose hout
+		return $ case r of
+			ExitSuccess -> True
+			ExitFailure _ -> False
+	go h@(hin, hout, _) = consumer hin hout <&&> cleanup h