summaryrefslogtreecommitdiff
path: root/Utility/MagicWormhole.hs
blob: f9e694e28b519cffb7d4fc53290fde16f9aa6cc2 (plain)
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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
{- Magic Wormhole integration
 -
 - Copyright 2016 Joey Hess <id@joeyh.name>
 -
 - License: BSD-2-clause
 -}

module Utility.MagicWormhole (
	Code,
	mkCode,
	toCode,
	fromCode,
	validCode,
	CodeObserver,
	CodeProducer,
	mkCodeObserver,
	mkCodeProducer,
	waitCode,
	sendCode,
	WormHoleParams,
	appId,
	sendFile,
	receiveFile,
	isInstalled,
) where

import Utility.Process
import Utility.SafeCommand
import Utility.Monad
import Utility.Misc
import Utility.Env
import Utility.Path

import System.IO
import System.Exit
import Control.Concurrent
import Control.Exception
import Data.Char
import Data.List
import Control.Applicative
import Prelude

-- | A Magic Wormhole code.
newtype Code = Code String
	deriving (Eq, Show)

-- | Smart constructor for Code
mkCode :: String -> Maybe Code
mkCode s
	| validCode s = Just (Code s)
	| otherwise = Nothing

-- | Tries to fix up some common mistakes in a homan-entered code.
toCode :: String -> Maybe Code
toCode s = mkCode $ intercalate "-" $ words s

fromCode :: Code -> String
fromCode (Code s) = s

-- | 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
		]

newtype CodeObserver = CodeObserver (MVar Code)

newtype CodeProducer = CodeProducer (MVar Code)

mkCodeObserver :: IO CodeObserver
mkCodeObserver = CodeObserver <$> newEmptyMVar

mkCodeProducer :: IO CodeProducer
mkCodeProducer = CodeProducer <$> newEmptyMVar

waitCode :: CodeObserver -> IO Code
waitCode (CodeObserver o) = readMVar o

sendCode :: CodeProducer -> Code -> IO ()
sendCode (CodeProducer p) = putMVar p

type WormHoleParams = [CommandParam]

-- | An appid should be provided when using wormhole in an app, to avoid
-- using the same channel space as ad-hoc wormhole users.
appId :: String -> WormHoleParams
appId s = [Param "--appid", Param s]

-- | Sends a file. Once the send is underway, and the Code has been
-- generated, it will be sent to the CodeObserver. (This may not happen,
-- eg if there's a network problem).
--
-- 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 (CodeObserver observer) 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 ->
		findcode =<< words <$> hGetContents hout
  where
	p = wormHoleProcess (Param "send" : ps ++ [File f])
	findcode [] = return False
	findcode (w:ws) = case mkCode w of
		Just code -> do
			putMVar observer code
			return True
		Nothing -> findcode ws

-- | Receives a file. Once the receive is under way, the Code will be
-- read from the CodeProducer, and fed to wormhole on stdin.
receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool
receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout -> do
	Code c <- readMVar producer
	hPutStrLn hin c
	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 (\v -> cleanup v <&&> return False) 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

isInstalled :: IO Bool
isInstalled = inPath "wormhole"