{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

#if !defined(mingw32_HOST_OS) && !defined(wasm32_HOST_ARCH)
#define UNIX
#endif

module Cardano.Api.IO.Internal.Compat.Posix
  (
#ifdef UNIX
    VRFPrivateKeyFilePermissionError
  , checkVrfFilePermissionsImpl
  , handleFileForWritingWithOwnerPermissionImpl
  , writeSecretsImpl
#endif
  )
where

#ifdef UNIX

import           Cardano.Api.Error (FileError (..), throwErrorM)
import           Cardano.Api.IO.Internal.Base

import           Control.Exception (bracket, bracketOnError, try)
import           Control.Monad (forM_, when)
import           Control.Monad.Except (ExceptT)
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except.Extra (left)
import           Data.Bifunctor (first)
import qualified Data.ByteString as BS
import           GHC.Stack (HasCallStack)
import qualified System.Directory as IO
import           System.FilePath (splitFileName, (<.>), (</>))
import qualified System.IO as IO
import           System.IO (Handle)
import           System.Posix.Files (fileMode, getFileStatus, groupModes, intersectFileModes,
                   nullFileMode, otherModes, ownerReadMode, setFdOwnerAndGroup, setFileMode)
import           System.Posix.IO (OpenMode (..), closeFd, defaultFileFlags, handleToFd, openFd)
import           System.Posix.Types (FileMode)
import           System.Posix.Unistd (fileSynchronise)
import           System.Posix.User (getRealUserID)
import           Text.Printf (printf)

handleFileForWritingWithOwnerPermissionImpl
  :: FilePath
  -> (Handle -> IO ())
  -> IO (Either (FileError e) ())
handleFileForWritingWithOwnerPermissionImpl :: forall e.
FilePath -> (Handle -> IO ()) -> IO (Either (FileError e) ())
handleFileForWritingWithOwnerPermissionImpl FilePath
path Handle -> IO ()
f = do
  -- On a unix based system, we write to a fresh temporary file (which
  -- 'IO.openTempFile' creates with owner-only permissions) and rename it over
  -- the target path once the contents are safely on disk. The target path thus
  -- always holds either its previous contents or the complete new contents.
  user <- IO UserID
getRealUserID
  fmap (first $ FileIOError path) $
    try $
      bracketOnError
        (IO.openTempFile targetDir $ targetFile <.> "tmp")
        ( \(FilePath
tmpPath, Handle
h) -> do
            Handle -> IO ()
IO.hClose Handle
h
            FilePath -> IO ()
IO.removeFile FilePath
tmpPath
        )
        ( \(FilePath
tmpPath, Handle
h) -> do
            Handle -> IO ()
f Handle
h
            -- 'handleToFd' flushes the handle's buffers and closes it, handing
            -- us the raw file descriptor. Before the rename, we set the file's
            -- ownership to the real user (which can differ from the effective
            -- user in setuid programs) and sync the descriptor, so a power
            -- failure cannot leave an empty file at the target path.
            IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
              (Handle -> IO Fd
handleToFd Handle
h)
              Fd -> IO ()
closeFd
              (\Fd
fd -> Fd -> UserID -> CGid -> IO ()
setFdOwnerAndGroup Fd
fd UserID
user (-CGid
1) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO ()
fileSynchronise Fd
fd)
            FilePath -> FilePath -> IO ()
IO.renameFile FilePath
tmpPath FilePath
path
            -- Sync the directory as well, so the rename itself (and not just
            -- the file contents) survives a power failure.
            IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
              (FilePath -> OpenMode -> OpenFileFlags -> IO Fd
openFd FilePath
targetDir OpenMode
ReadOnly OpenFileFlags
defaultFileFlags)
              Fd -> IO ()
closeFd
              Fd -> IO ()
fileSynchronise
        )
 where
  (FilePath
targetDir, FilePath
targetFile) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
path

writeSecretsImpl
  :: HasCallStack => FilePath -> [Char] -> [Char] -> (a -> BS.ByteString) -> [a] -> IO ()
writeSecretsImpl :: forall a.
HasCallStack =>
FilePath
-> FilePath -> FilePath -> (a -> ByteString) -> [a] -> IO ()
writeSecretsImpl FilePath
outDir FilePath
prefix FilePath
suffix a -> ByteString
secretOp [a]
xs =
  [(a, Int)] -> ((a, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [Int
0 :: Int ..]) (((a, Int) -> IO ()) -> IO ()) -> ((a, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \(a
secret, Int
nr) -> do
      let filename :: FilePath
filename = FilePath
outDir FilePath -> FilePath -> FilePath
</> FilePath
prefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Int -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%03d" Int
nr FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
suffix
      result <- FilePath -> (Handle -> IO ()) -> IO (Either (FileError ()) ())
forall e.
FilePath -> (Handle -> IO ()) -> IO (Either (FileError e) ())
handleFileForWritingWithOwnerPermissionImpl FilePath
filename ((Handle -> IO ()) -> IO (Either (FileError ()) ()))
-> (Handle -> IO ()) -> IO (Either (FileError ()) ())
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
        Handle -> ByteString -> IO ()
BS.hPut Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
secretOp a
secret
      case result of
        Left FileError ()
err -> FileError () -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Typeable e, Error e) =>
e -> m a
throwErrorM (FileError ()
err :: FileError ())
        Right () -> FilePath -> FileMode -> IO ()
setFileMode FilePath
filename FileMode
ownerReadMode

-- | Make sure the VRF private key file is readable only
-- by the current process owner the node is running under.
checkVrfFilePermissionsImpl
  :: File content direction -> ExceptT VRFPrivateKeyFilePermissionError IO ()
checkVrfFilePermissionsImpl :: forall content (direction :: FileDirection).
File content direction
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
checkVrfFilePermissionsImpl (File FilePath
vrfPrivKey) = do
  fs <- IO FileStatus
-> ExceptT VRFPrivateKeyFilePermissionError IO FileStatus
forall a. IO a -> ExceptT VRFPrivateKeyFilePermissionError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus
 -> ExceptT VRFPrivateKeyFilePermissionError IO FileStatus)
-> IO FileStatus
-> ExceptT VRFPrivateKeyFilePermissionError IO FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus FilePath
vrfPrivKey
  let fm = FileStatus -> FileMode
fileMode FileStatus
fs
  -- Check the the VRF private key file does not give read/write/exec permissions to others.
  when
    (hasOtherPermissions fm)
    (left $ OtherPermissionsExist vrfPrivKey)
  -- Check the the VRF private key file does not give read/write/exec permissions to any group.
  when
    (hasGroupPermissions fm)
    (left $ GroupPermissionsExist vrfPrivKey)
 where
  hasPermission :: FileMode -> FileMode -> Bool
  hasPermission :: FileMode -> FileMode -> Bool
hasPermission FileMode
fModeA FileMode
fModeB = FileMode
fModeA FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
fModeB FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
nullFileMode

  hasOtherPermissions :: FileMode -> Bool
  hasOtherPermissions :: FileMode -> Bool
hasOtherPermissions FileMode
fm' = FileMode
fm' FileMode -> FileMode -> Bool
`hasPermission` FileMode
otherModes

  hasGroupPermissions :: FileMode -> Bool
  hasGroupPermissions :: FileMode -> Bool
hasGroupPermissions FileMode
fm' = FileMode
fm' FileMode -> FileMode -> Bool
`hasPermission` FileMode
groupModes
#endif