multicast: New command, uses uftp to multicast annexed files, for eg a classroom setting.

This commit was supported by the NSF-funded DataLad project.

1 files changed, 253 insertions, 0 deletions

diff --git a/Command/Multicast.hs b/Command/Multicast.hs
new file mode 100644
index 000000000..cd74c3ebc
--- /dev/null
+++ b/Command/Multicast.hs
@@ -0,0 +1,253 @@
+{- git-annex command
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Command.Multicast where
+
+import Command
+import Logs.Multicast
+import Annex.Multicast
+import Annex.WorkTree
+import Annex.Content
+import Annex.UUID
+#ifndef mingw32_HOST_OS
+import Creds
+import Annex.Perms
+import Utility.FileMode
+#endif
+import qualified Limit
+import Types.FileMatcher
+import qualified Git.LsFiles as LsFiles
+import Utility.Hash
+import Utility.Tmp
+import Config
+
+import Data.Char
+import qualified Data.ByteString.Lazy.UTF8 as B8
+import qualified Data.Map as M
+import Control.Concurrent.Async
+
+cmd :: Command
+cmd = command "multicast" SectionCommon "multicast file distribution"
+	paramNothing (seek <$$> optParser)
+
+data MultiCastAction
+	= GenAddress
+	| Send
+	| Receive
+	deriving (Show)
+
+data MultiCastOptions = MultiCastOptions MultiCastAction [CommandParam] [FilePath]
+	deriving (Show)
+
+optParser :: CmdParamsDesc -> Parser MultiCastOptions
+optParser _ = MultiCastOptions 
+	<$> (genaddressp <|> sendp <|> receivep)
+	<*> many uftpopt
+	<*> cmdParams paramPaths
+  where
+	genaddressp = flag' GenAddress
+		( long "gen-address"
+		<> help "generate multicast encryption key and store address in git-annex branch"
+		)
+	sendp = flag' Send
+		( long "send"
+		<> help "multicast files"
+		)
+	receivep = flag' Receive
+		( long "receive"
+		<> help "listen for multicast files and store in repository"
+		)
+	uftpopt = Param <$> strOption
+		( long "uftp-opt"
+		<> short 'U'
+		<> help "passed on to uftp/uftpd"
+		<> metavar "OPTION"
+		)
+
+seek :: MultiCastOptions -> CommandSeek
+seek (MultiCastOptions GenAddress _ _) = commandAction genAddress 
+seek (MultiCastOptions Send ups fs) = commandAction $ send ups fs
+seek (MultiCastOptions Receive ups []) = commandAction $ receive ups
+seek (MultiCastOptions Receive _ _) = giveup "Cannot specify list of files with --receive; this receives whatever files the sender chooses to send."
+
+genAddress :: CommandStart
+genAddress = do
+	showStart "gen-address" ""
+	k <- uftpKey
+	(s, ok) <- case k of
+		KeyContainer s -> liftIO $ genkey (Param s)
+		KeyFile f -> do
+			createAnnexDirectory (takeDirectory f)
+			liftIO $ nukeFile f
+			liftIO $ protectedOutput $ genkey (File f)
+	case (ok, parseFingerprint s) of
+		(False, _) -> giveup $ "uftp_keymgt failed: " ++ s
+		(_, Nothing) -> giveup $ "Failed to find fingerprint in uftp_keymgt output: " ++ s
+		(True, Just fp) -> next $ next $ do
+			recordFingerprint fp =<< getUUID
+			return True
+  where
+ 	-- Annoyingly, the fingerprint is output to stderr.
+	genkey p = processTranscript "uftp_keymgt" ps Nothing
+	  where
+		ps = toCommand $
+			[ Param "-g"
+			, keyparam
+			, p
+			]
+	-- uftp only supports rsa up to 2048 which is on the lower
+	-- limit of secure RSA key sizes. Instead, use an EC curve.
+	-- Except for on Windows XP, secp521r1 is supported on all
+	-- platforms by uftp. DJB thinks it's pretty good compared
+	-- with other NIST curves: "there's one standard NIST curve
+	-- using a nice prime, namely 2521−1  but the sheer size of this
+	-- prime makes it much slower than NIST P-256"
+	-- (http://blog.cr.yp.to/20140323-ecdsa.html)
+	-- Since this key is only used to set up the block encryption,
+	-- its slow speed is ok.
+	keyparam = Param "ec:secp521r1"
+
+parseFingerprint :: String -> Maybe Fingerprint
+parseFingerprint = Fingerprint <$$> lastMaybe . filter isfingerprint . words 
+  where
+	isfingerprint s = 
+		let os = filter (all isHexDigit) (splitc ':' s)
+		in length os == 20
+	
+send :: [CommandParam] -> [FilePath] -> CommandStart
+send ups fs = withTmpFile "send" $ \t h -> do
+	-- Need to be able to send files with the names of git-annex
+	-- keys, and uftp does not allow renaming the files that are sent.
+	-- In a direct mode repository, the annex objects do not have
+	-- the names of keys, and would have to be copied, which is too
+	-- expensive.
+	whenM isDirect $
+		giveup "Sorry, multicast send cannot be done from a direct mode repository."
+	
+	showStart "generating file list" ""
+	fs' <- seekHelper LsFiles.inRepo fs
+	matcher <- Limit.getMatcher
+	let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $
+		liftIO $ hPutStrLn h o
+	forM_ fs' $ \f -> do
+		mk <- lookupFile f
+		case mk of
+			Nothing -> noop
+			Just k -> withObjectLoc k (addlist f) (const noop)
+	liftIO $ hClose h
+	showEndOk
+
+	showStart "sending files" ""
+	showOutput
+	serverkey <- uftpKey
+	u <- getUUID
+	withAuthList $ \authlist -> do
+		let ps =
+			-- Force client authentication.
+			[ Param "-c"
+			, Param "-Y", Param "aes256-cbc"
+			, Param "-h", Param "sha512"
+			-- Picked ecdh_ecdsa for perfect forward secrecy,
+			-- and because a EC key exchange algorithm is
+			-- needed since all keys are EC.
+			, Param "-e", Param "ecdh_ecdsa"
+			, Param "-k", uftpKeyParam serverkey
+			, Param "-U", Param (uftpUID u)
+			-- only allow clients on the authlist
+			, Param "-H", Param ("@"++authlist)
+			-- pass in list of files to send
+			, Param "-i", File t
+			] ++ ups
+		liftIO (boolSystem "uftp" ps) >>= showEndResult
+	stop
+
+receive :: [CommandParam] -> CommandStart
+receive ups = do
+	showStart "receiving multicast files" ""
+	showNote "Will continue to run until stopped by ctrl-c"
+	
+	showOutput
+	clientkey <- uftpKey
+	u <- getUUID
+	(callback, environ, statush) <- liftIO multicastCallbackEnv
+	tmpobjdir <- fromRepo gitAnnexTmpObjectDir
+	createAnnexDirectory tmpobjdir
+	withTmpDirIn tmpobjdir "multicast" $ \tmpdir -> withAuthList $ \authlist -> 
+		abstmpdir <- liftIO $ absPath tmpdir
+		abscallback <- liftIO $ searchPath callback
+		let ps =
+			-- Avoid it running as a daemon.
+			[ Param "-d"
+			-- Require encryption.
+			, Param "-E"
+			, Param "-k", uftpKeyParam clientkey
+			, Param "-U", Param (uftpUID u)
+			-- Only allow servers on the authlist
+			, Param "-S", Param authlist
+			-- Receive files into tmpdir
+			-- (it needs an absolute path)
+			, Param "-D", File abstmpdir
+			-- Run callback after each file received
+			-- (it needs an absolute path)
+			, Param "-s", Param (fromMaybe callback abscallback)
+			] ++ ups
+		runner <- liftIO $ async $
+			hClose statush
+				`after` boolSystemEnv "uftpd" ps (Just environ)
+		mapM_ storeReceived . lines =<< liftIO (hGetContents statush)
+		showEndResult =<< liftIO (wait runner)
+	stop
+
+storeReceived :: FilePath -> Annex ()
+storeReceived f = do
+	case file2key (takeFileName f) of
+		Nothing -> do
+			warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file."
+			liftIO $ nukeFile f
+		Just k -> void $
+			getViaTmp' AlwaysVerify k $ \dest -> unVerified $
+				liftIO $ catchBoolIO $ do
+					rename f dest
+					return True
+
+-- Under Windows, uftp uses key containers, which are not files on the
+-- filesystem.
+data UftpKey = KeyFile FilePath | KeyContainer String
+
+uftpKeyParam :: UftpKey -> CommandParam
+uftpKeyParam (KeyFile f) = File f
+uftpKeyParam (KeyContainer s) = Param s
+
+uftpKey :: Annex UftpKey
+#ifdef mingw32_HOST_OS
+uftpKey = do
+	u <- getUUID
+	return $ KeyContainer $ "annex-" ++ fromUUID u
+#else
+uftpKey = KeyFile <$> cacheCredsFile "multicast"
+#endif
+
+-- uftp needs a unique UID for each client and server, which 
+-- is a 8 digit hex number in the form "0xnnnnnnnn"
+-- Derive it from the UUID.
+uftpUID :: UUID -> String
+uftpUID u = "0x" ++ (take 8 $ show $ sha2_256 $ B8.fromString (fromUUID u))
+
+withAuthList :: (FilePath -> Annex a) -> Annex a
+withAuthList a = do
+	m <- knownFingerPrints
+	withTmpFile "authlist" $ \t h -> do
+		liftIO $ hPutStr h (genAuthList m)
+		liftIO $ hClose h
+		a t
+
+genAuthList :: M.Map UUID Fingerprint -> String
+genAuthList = unlines . map fmt . M.toList
+  where
+	fmt (u, Fingerprint f) = uftpUID u ++ "|" ++ f