9a5ddda511
Drop support for building with ghc older than 8.4.4, and with older versions of serveral haskell libraries than will be included in Debian 10. The only remaining version ifdefs in the entire code base are now a couple for aws! This commit should only be merged after the Debian 10 release. And perhaps it will need to wait longer than that; it would make backporting new versions of git-annex to Debian 9 (stretch) which has been actively happening as recently as this year. This commit was sponsored by Ilya Shlyakhter.
44 lines
1.3 KiB
Haskell
44 lines
1.3 KiB
Haskell
{- git-annex multicast receive callback
|
|
-
|
|
- Copyright 2017 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Annex.Multicast where
|
|
|
|
import Config.Files
|
|
import Utility.Env
|
|
import Utility.PartialPrelude
|
|
|
|
import System.Process
|
|
import System.IO
|
|
import GHC.IO.Handle.FD
|
|
import Control.Applicative
|
|
import Prelude
|
|
|
|
multicastReceiveEnv :: String
|
|
multicastReceiveEnv = "GIT_ANNEX_MULTICAST_RECEIVE"
|
|
|
|
multicastCallbackEnv :: IO (FilePath, [(String, String)], Handle)
|
|
multicastCallbackEnv = do
|
|
gitannex <- readProgramFile
|
|
-- This will even work on Windows
|
|
(rfd, wfd) <- createPipeFd
|
|
rh <- fdToHandle rfd
|
|
environ <- addEntry multicastReceiveEnv (show wfd) <$> getEnvironment
|
|
return (gitannex, environ, rh)
|
|
|
|
-- This is run when uftpd has received a file. Rather than move
|
|
-- the file into the annex here, which would require starting up the
|
|
-- Annex monad, parsing git config, and verifying the content, simply
|
|
-- output to the specified FD the filename. This keeps the time
|
|
-- that uftpd is not receiving the next file as short as possible.
|
|
runMulticastReceive :: [String] -> String -> IO ()
|
|
runMulticastReceive ("-I":_sessionid:fs) hs = case readish hs of
|
|
Just fd -> do
|
|
h <- fdToHandle fd
|
|
mapM_ (hPutStrLn h) fs
|
|
hClose h
|
|
Nothing -> return ()
|
|
runMulticastReceive _ _ = return ()
|