diff --git a/Utility/StatelessOpenPGP.hs b/Utility/StatelessOpenPGP.hs new file mode 100644 index 0000000000..e6ca08b54c --- /dev/null +++ b/Utility/StatelessOpenPGP.hs @@ -0,0 +1,192 @@ +{- Stateless OpenPGP interface + - + - Copyright 2011-2024 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP, OverloadedStrings #-} + +module Utility.StatelessOpenPGP ( + SopCmd(..), + encryptSymmetric, + decryptSymmetric, + test_encrypt_decrypt_Symmetric, + feedRead, + feedRead', +) where + +import Common +#ifndef mingw32_HOST_OS +import System.Posix.Types +import System.Posix.IO +#else +import Utility.Tmp +#endif +import Utility.Tmp.Dir + +import Control.Concurrent.Async +import Control.Monad.IO.Class +import qualified Data.ByteString as B + +{- The command to run, eq sqop. -} +newtype SopCmd = SopCmd { unSopCmd :: String } + +{- The subcommand to run eg encrypt. -} +type SopSubCmd = String + +{- Note that SOP requires passwords to be UTF-8 encoded, and that they + - may try to trim trailing whitespace. They may also forbid leading + - whitespace, or forbid some non-printing characters. -} +type Password = B.ByteString + +type Profile = String + +newtype Armoring = Armoring Bool + +{- The path to an empty temporary directory. + - + - This is unfortunately needed because of an infelicity in the SOP + - standard, as documented in section 9.9 "Be Careful with Special + - Designators", when using "@FD:" and similar designators the SOP + - command may test for the presense of a file with the same name on the + - filesystem, and fail with AMBIGUOUS_INPUT. + - + - Since we don't want to need to deal with such random failure due to + - whatever filename might be present, when running sop commands using + - special designators, an empty directory has to be provided, and the + - command is run in that directory. Of course, this necessarily means + - that any relative paths passed to the command have to be made absolute. + -} +newtype EmptyDirectory = EmptyDirectory FilePath + +{- Encrypt using symmetric encryption with the specified password. -} +encryptSymmetric + :: (MonadIO m, MonadMask m) + => SopCmd + -> Password + -> EmptyDirectory + -> Maybe Profile + -> Armoring + -> (Handle -> IO ()) + -> (Handle -> m a) + -> m a +encryptSymmetric sopcmd password emptydirectory mprofile armoring feeder reader = + feedRead sopcmd "encrypt" params password emptydirectory feeder reader + where + params = map Param $ catMaybes + [ case armoring of + Armoring False -> Just "--no-armor" + Armoring True -> Nothing + , Just "--as=binary" + , case mprofile of + Just profile -> Just $ "--profile=" ++ profile + Nothing -> Nothing + ] + +{- Deccrypt using symmetric encryption with the specified password. -} +decryptSymmetric + :: (MonadIO m, MonadMask m) + => SopCmd + -> Password + -> EmptyDirectory + -> (Handle -> IO ()) + -> (Handle -> m a) + -> m a +decryptSymmetric sopcmd password emptydirectory feeder reader = + feedRead sopcmd "decrypt" [] password emptydirectory feeder reader + +{- Test a value round-trips through symmetric encryption and decryption. -} +test_encrypt_decrypt_Symmetric :: SopCmd -> SopCmd -> Password -> Armoring -> B.ByteString -> IO Bool +test_encrypt_decrypt_Symmetric a b password armoring v = + withTmpDir "test" $ \d -> do + let ed = EmptyDirectory d + enc <- encryptSymmetric a password ed Nothing armoring + (`B.hPutStr` v) B.hGetContents + dec <- decryptSymmetric b password ed + (`B.hPutStr` enc) B.hGetContents + return (v == dec) + +{- Runs a SOP command with some parameters. First sends it a password + - via '--with-password'. Then runs a feeder action that is + - passed a handle and should write to it all the data to input to the + - command. Finally, runs a reader action that is passed a handle to + - the command's output. + - + - Note that the reader must fully consume its input before returning. -} +feedRead + :: (MonadIO m, MonadMask m) + => SopCmd + -> SopSubCmd + -> [CommandParam] + -> Password + -> EmptyDirectory + -> (Handle -> IO ()) + -> (Handle -> m a) + -> m a +feedRead cmd subcmd params password emptydirectory feeder reader = do +#ifndef mingw32_HOST_OS + let setup = liftIO $ do + -- pipe the passphrase in on a fd + (frompipe, topipe) <- System.Posix.IO.createPipe + toh <- fdToHandle topipe + t <- async $ do + B.hPutStr toh (password <> "\n") + hClose toh + let Fd pfd = frompipe + let passwordfd = [Param $ "--with-password=@FD:"++show pfd] + return (passwordfd, frompipe, toh, t) + let cleanup (_, frompipe, toh, t) = liftIO $ do + closeFd frompipe + hClose toh + cancel t + bracket setup cleanup $ \(passwordfd, _, _, _) -> + go (Just emptydirectory) (passwordfd ++ params) +#else + -- store the password in a temp file + withTmpFile "sop" $ \tmpfile h -> do + liftIO $ B.hPutStr h password + liftIO $ hClose h + let passwordfile = [Param $ "--with-password="++tmpfile] + -- Don't need to pass emptydirectory since @FD is not used, + -- and so tmpfile also does not need to be made absolute. + case emptydirectory of + EmptyDirectory _ -> return () + go Nothing $ passwordfile ++ params +#endif + where + go med params' = feedRead' cmd subcmd params' med feeder reader + +{- Like feedRead, but without password. -} +feedRead' + :: (MonadIO m, MonadMask m) + => SopCmd + -> SopSubCmd + -> [CommandParam] + -> Maybe EmptyDirectory + -> (Handle -> IO ()) + -> (Handle -> m a) + -> m a +feedRead' (SopCmd cmd) subcmd params med feeder reader = do + let p = (proc cmd (subcmd:toCommand params)) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + , cwd = case med of + Just (EmptyDirectory d) -> Just d + Nothing -> Nothing + } + bracket (setup p) cleanup (go p) + where + setup = liftIO . createProcess + cleanup = liftIO . cleanupProcess + + go p (Just to, Just from, _, pid) = + let runfeeder = do + feeder to + hClose to + in bracketIO (async runfeeder) cancel $ const $ do + r <- reader from + liftIO $ forceSuccessProcess p pid + return r + go _ _ = error "internal" diff --git a/git-annex.cabal b/git-annex.cabal index 64302e8244..bcaa23db59 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1060,6 +1060,7 @@ Executable git-annex Utility.Split Utility.SshConfig Utility.SshHost + Utility.StatelessOpenPGP Utility.Su Utility.SystemDirectory Utility.Terminal