git-annex-10.20250925: Utility/MagicWormhole.hs

{- 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 Utility.Exception

import System.IO
import System.Exit
import Control.Concurrent
import Control.Concurrent.Async
import Data.Char
import Data.List

-- | 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 herr ph -> do
 		(inout, inerr) <- concurrently
			(findcode ph hout)
			(findcode ph herr)
		return (inout || inerr)
  where
	p = wormHoleProcess (ps ++ [Param "send", File f])
	findcode ph h = hGetLineUntilExitOrEOF ph h >>= \case
		Nothing -> return False
		Just l -> ifM (findcode' (words l))
			( drain ph h >> return True
			, findcode ph h
			)
	findcode' [] = return False
	findcode' (w:ws) = case mkCode w of
		Just code -> do
			_ <- tryPutMVar observer code
			return True
		Nothing -> findcode' ws
	drain ph h = hGetLineUntilExitOrEOF ph h >>= \case
		Just _ -> drain ph h
		Nothing -> return ()

-- | 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 _herr _ph -> do
	Code c <- readMVar producer
	hPutStrLn hin c
	hFlush hin
	return True
  where
	p = wormHoleProcess $ ps ++
		[ Param "receive"
		, Param "--accept-file"
		, Param "--output-file"
		, File f
		]

wormHoleProcess :: WormHoleParams -> CreateProcess
wormHoleProcess = proc "wormhole" . toCommand

runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> ProcessHandle -> IO Bool) ->  IO Bool
runWormHoleProcess p consumer =
	withCreateProcess p' go `catchNonAsync` const (return False)
  where
	p' = p 
		{ std_in = CreatePipe
		, std_out = CreatePipe
		, std_err = CreatePipe
		}
	go (Just hin) (Just hout) (Just herr) pid =
		consumer hin hout herr pid <&&> waitbool pid
	go _ _ _ _ = error "internal"
	waitbool pid = do
		r <- waitForProcess pid
		return $ case r of
			ExitSuccess -> True
			ExitFailure _ -> False

isInstalled :: IO Bool
isInstalled = inSearchPath "wormhole"