{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Embedding and installation of 'etcd' binary. In a dedicated module as HLS
-- tends to choke on the executable's Template Haskell splice.
module Hydra.Network.EtcdBinary where

import Hydra.Prelude

#ifndef mingw32_HOST_OS
import Data.Bits ((.|.))
import Data.ByteString qualified as BS
import System.IO (hClose)
import System.Posix (OpenFileFlags (..), OpenMode (WriteOnly), closeFd, defaultFileFlags, fdToHandle, openFd, ownerExecuteMode, ownerReadMode, ownerWriteMode, setFileMode)
#endif
import Hydra.Network (WhichEtcd (..))
import Hydra.Node.EmbedTH (embedExecutable)
import System.Directory (createDirectoryIfMissing, renameFile)
import System.FilePath (takeDirectory, (</>))

-- | Return the path of the etcd binary. Will either install it first, or just
-- assume there is one available on the system path.
getEtcdBinary :: FilePath -> WhichEtcd -> IO FilePath
getEtcdBinary :: FilePath -> WhichEtcd -> IO FilePath
getEtcdBinary FilePath
_ WhichEtcd
SystemEtcd = FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
etcdExecutable
getEtcdBinary FilePath
persistenceDir WhichEtcd
EmbeddedEtcd =
  let path :: FilePath
path = FilePath
persistenceDir FilePath -> FilePath -> FilePath
</> FilePath
"bin" FilePath -> FilePath -> FilePath
</> FilePath
etcdExecutable
   in FilePath -> IO ()
installEtcd FilePath
path IO () -> IO FilePath -> IO FilePath
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
path

etcdExecutable :: FilePath
#ifdef mingw32_HOST_OS
etcdExecutable = "etcd.exe"
#else
etcdExecutable :: FilePath
etcdExecutable = FilePath
"etcd"
#endif

-- | Install the embedded 'etcd' binary to given file path.
installEtcd :: FilePath -> IO ()
installEtcd :: FilePath -> IO ()
installEtcd FilePath
fp = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
fp)
  -- Replace the executable without truncating a previous installation. This
  -- also avoids rewriting an inode still mapped by a process during shutdown.
  FilePath -> ByteString -> IO ()
writeBinaryFile FilePath
tmp $(embedExecutable "HYDRA_ETCD_PATH" "etcd")
  FilePath -> IO ()
makeExecutable FilePath
tmp
  FilePath -> FilePath -> IO ()
renameFile FilePath
tmp FilePath
fp
 where
  tmp :: FilePath
tmp = FilePath
fp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".tmp"

-- | Write without letting another process retain the writable file descriptor.
writeBinaryFile :: FilePath -> ByteString -> IO ()
#ifdef mingw32_HOST_OS
writeBinaryFile = writeFileBS
#else
writeBinaryFile :: FilePath -> ByteString -> IO ()
writeBinaryFile FilePath
fp ByteString
bytes =
  -- Open with close-on-exec atomically. Otherwise an unrelated child can
  -- inherit the write handle and prevent executing etcd (ETXTBSY) after close.
  IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    ( do
        Fd
fd <- FilePath -> OpenMode -> OpenFileFlags -> IO Fd
openFd FilePath
fp OpenMode
WriteOnly OpenFileFlags
defaultFileFlags{creat = Just 0o600, trunc = True, cloexec = True}
        Fd -> IO Handle
fdToHandle Fd
fd IO Handle -> IO () -> IO Handle
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` Fd -> IO ()
closeFd Fd
fd
    )
    Handle -> IO ()
hClose
    (Handle -> ByteString -> IO ()
`BS.hPut` ByteString
bytes)
#endif

makeExecutable :: FilePath -> IO ()
#ifdef mingw32_HOST_OS
makeExecutable _ = pure ()
#else
makeExecutable :: FilePath -> IO ()
makeExecutable FilePath
fp = FilePath -> FileMode -> IO ()
setFileMode FilePath
fp (FileMode
ownerReadMode FileMode -> FileMode -> FileMode
forall a. Bits a => a -> a -> a
.|. FileMode
ownerWriteMode FileMode -> FileMode -> FileMode
forall a. Bits a => a -> a -> a
.|. FileMode
ownerExecuteMode)
#endif