31e1adc005
P2P protocol version 1 adds VALID|INVALID after DATA; INVALID means the file was detected to change content while it was being sent and so we may not have received the valid content of the file. Added new MustVerify constructor for Verification, which forces verification even when annex.verify=false etc. This is used when INVALID and in protocol version 0. As well as changing git-annex-shell p2psdio, this makes git-annex tor remotes always force verification, since they don't yet use protocol version 1. Previously, annex.verify=false could skip verification when using tor remotes, and let bad data into the repository. This commit was sponsored by Jack Hill on Patreon.
255 lines
7.6 KiB
Haskell
255 lines
7.6 KiB
Haskell
{- 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
|
||
import Annex.Perms
|
||
import Utility.FileMode
|
||
#ifndef mingw32_HOST_OS
|
||
import Creds
|
||
#endif
|
||
import qualified Limit
|
||
import Types.FileMatcher
|
||
import qualified Git.LsFiles as LsFiles
|
||
import Utility.Hash
|
||
import Utility.Tmp
|
||
import Utility.Tmp.Dir
|
||
import Utility.Process.Transcript
|
||
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" Nothing
|
||
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" Nothing
|
||
fs' <- seekHelper LsFiles.inRepo =<< workTreeItems 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" Nothing
|
||
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" Nothing
|
||
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 -> do
|
||
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 $
|
||
getViaTmpFromDisk 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
|