e89bb4361b
p2p and multicast creds are not cached the same way that s3 and webdav creds are. The difference is that p2p and multicast obtain the creds themselves, as part of a process like pairing. So they're storing the only extant copy of the creds. In s3 and webdav etc the creds are provided by the cloud storage provider. This is a fine difference, but I do think it's a reasonable difference. If the user wants to prevent s3 and webdav etc creds from being stored unencrypted on disk, they won't feel the same about p2p auth tokens used for tor, or a multicast encryption key, or for that matter their local ssh private key. 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 <$> credsFile "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
|