{-# 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 (IOException, bracket, bracketOnError, try)
import           Control.Monad (forM_, when)
import           Control.Monad.Except (ExceptT, runExceptT)
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except.Extra (handleIOExceptT, left)
import qualified Data.ByteString as BS
import           GHC.Stack (HasCallStack)
import           System.Directory ()
import           System.FilePath ((</>))
import qualified System.IO as IO
import           System.IO (Handle)
import           System.Posix.Files (fileMode, getFileStatus, groupModes, intersectFileModes,
                   nullFileMode, otherModes, ownerReadMode, ownerWriteMode, setFdOwnerAndGroup,
                   setFileMode, stdFileMode, unionFileModes)
import           System.Posix.IO (OpenFileFlags (..), OpenMode (..), closeFd, defaultFileFlags,
                   fdToHandle, openFd)
import           System.Posix.Types (Fd, FileMode)
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 grab a file descriptor and set ourselves as owner.
  -- Since we're holding the file descriptor at this point, we can be sure that
  -- what we're about to write to is owned by us if an error didn't occur.
  user <- IO UserID
getRealUserID
  ownedFile <-
    try $
      -- We only close the FD on error here, otherwise we let it leak out, since
      -- it will be immediately turned into a Handle (which will be closed when
      -- the Handle is closed)
      bracketOnError
        (openFileDescriptor path WriteOnly)
        closeFd
        (\Fd
fd -> Fd -> UserID -> CGid -> IO ()
setFdOwnerAndGroup Fd
fd UserID
user (-CGid
1) IO () -> IO Fd -> IO Fd
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fd -> IO Fd
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fd
fd)
  case ownedFile of
    Left (IOException
err :: IOException) -> do
      Either (FileError e) () -> IO (Either (FileError e) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (FileError e) () -> IO (Either (FileError e) ()))
-> Either (FileError e) () -> IO (Either (FileError e) ())
forall a b. (a -> b) -> a -> b
$ FileError e -> Either (FileError e) ()
forall a b. a -> Either a b
Left (FileError e -> Either (FileError e) ())
-> FileError e -> Either (FileError e) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException -> FileError e
forall e. FilePath -> IOException -> FileError e
FileIOError FilePath
path IOException
err
    Right Fd
fd -> do
      IO Handle
-> (Handle -> IO ())
-> (Handle -> IO (Either (FileError e) ()))
-> IO (Either (FileError e) ())
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (Fd -> IO Handle
fdToHandle Fd
fd)
        Handle -> IO ()
IO.hClose
        (ExceptT (FileError e) IO () -> IO (Either (FileError e) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (FileError e) IO () -> IO (Either (FileError e) ()))
-> (Handle -> ExceptT (FileError e) IO ())
-> Handle
-> IO (Either (FileError e) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOException -> FileError e)
-> IO () -> ExceptT (FileError e) IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FilePath -> IOException -> FileError e
forall e. FilePath -> IOException -> FileError e
FileIOError FilePath
path) (IO () -> ExceptT (FileError e) IO ())
-> (Handle -> IO ()) -> Handle -> ExceptT (FileError e) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
f)

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

-- | Read and write permissions for the file owner only (@0600@). Files
-- created for writing are data files, so the execute bit is not set.
ownerReadWriteMode :: FileMode
ownerReadWriteMode :: FileMode
ownerReadWriteMode = FileMode
ownerReadMode FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
ownerWriteMode

-- | Opens a file from disk. In 'WriteOnly' mode, the file is truncated if
-- it already exists.
openFileDescriptor :: FilePath -> OpenMode -> IO Fd
# if MIN_VERSION_unix(2,8,0)
openFileDescriptor :: FilePath -> OpenMode -> IO Fd
openFileDescriptor FilePath
fp OpenMode
openMode =
  FilePath -> OpenMode -> OpenFileFlags -> IO Fd
openFd FilePath
fp OpenMode
openMode OpenFileFlags
fileFlags
 where
  fileFlags :: OpenFileFlags
fileFlags =
    case OpenMode
openMode of
      OpenMode
ReadOnly ->
        OpenFileFlags
defaultFileFlags
      OpenMode
ReadWrite ->
        OpenFileFlags
defaultFileFlags{creat = Just stdFileMode}
      OpenMode
WriteOnly ->
        OpenFileFlags
defaultFileFlags{creat = Just ownerReadWriteMode, trunc = True}

# else
openFileDescriptor fp openMode =
  openFd fp openMode fMode fileFlags
 where
  (fMode, fileFlags) =
    case openMode of
      ReadOnly ->
        ( Nothing
        , defaultFileFlags
        )
      ReadWrite ->
        ( Just stdFileMode
        , defaultFileFlags
        )
      WriteOnly ->
        ( Just ownerReadWriteMode
        , defaultFileFlags{trunc = True}
        )

# endif
#endif