b657242f5d
Leveraged the existing verification code by making it also check the retrievalSecurityPolicy. Also, prevented getViaTmp from running the download action at all when the retrievalSecurityPolicy is going to prevent verifying and so storing it. Added annex.security.allow-unverified-downloads. A per-remote version would be nice to have too, but would need more plumbing, so KISS. (Bill the Cat reference not too over the top I hope. The point is to make this something the user reads the documentation for before using.) A few calls to verifyKeyContent and getViaTmp, that don't involve downloads from remotes, have RetrievalAllKeysSecure hard-coded. It was also hard-coded for P2P.Annex and Command.RecvKey, to match the values of the corresponding remotes. A few things use retrieveKeyFile/retrieveKeyFileCheap without going through getViaTmp. * Command.Fsck when downloading content from a remote to verify it. That content does not get into the annex, so this is ok. * Command.AddUrl when using a remote to download an url; this is new content being added, so this is ok. This commit was sponsored by Fernando Jimenez 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 RetrievalVerifiableKeysSecure 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
|