1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
{- 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 Utility.Env
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).
--
-- Note that, if the filename looks like "foo 1-wormhole-code bar", when
-- that is output by wormhole, it will look like it's output a wormhole code.
--
-- A request to make the code available in machine-parsable form is here:
-- https://github.com/warner/magic-wormhole/issues/104
sendFile :: FilePath -> CodeObserver -> WormHoleParams -> IO Bool
sendFile f o ps = do
-- Work around stupid stdout buffering behavior of python.
-- See https://github.com/warner/magic-wormhole/issues/108
environ <- addEntry "PYTHONUNBUFFERED" "1" <$> getEnvironment
runWormHoleProcess p { env = Just environ} $ \_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
|
