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

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

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

#ifdef UNIX

import           Cardano.Api.Error (FileError (..))
import           Cardano.Api.IO.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           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, ownerModes, ownerReadMode, setFdOwnerAndGroup,
                   setFileMode, stdFileMode)
#if MIN_VERSION_unix(2,8,0)
import           System.Posix.IO (OpenFileFlags (..), OpenMode (..), closeFd, defaultFileFlags,
                   fdToHandle, openFd)
#else
import           System.Posix.IO (OpenMode (..), closeFd, defaultFileFlags, fdToHandle, openFd)
#endif
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.
  UserID
user <- IO UserID
getRealUserID
  Either IOException Fd
ownedFile <-
    IO Fd -> IO (Either IOException Fd)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Fd -> IO (Either IOException Fd))
-> IO Fd -> IO (Either IOException Fd)
forall a b. (a -> b) -> a -> b
$
      -- 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)
      IO Fd -> (Fd -> IO ()) -> (Fd -> IO Fd) -> IO Fd
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (FilePath -> OpenMode -> IO Fd
openFileDescriptor FilePath
path OpenMode
WriteOnly)
        Fd -> IO ()
closeFd
        (\Fd
fd -> Fd -> UserID -> GroupID -> IO ()
setFdOwnerAndGroup Fd
fd UserID
user (-GroupID
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 Either IOException Fd
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 :: FilePath -> [Char] -> [Char] -> (a -> BS.ByteString) -> [a] -> IO ()
writeSecretsImpl :: forall a.
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
      FilePath -> ByteString -> IO ()
BS.writeFile FilePath
filename (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
secretOp a
secret
      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
  FileStatus
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 :: FileMode
fm = FileStatus -> FileMode
fileMode FileStatus
fs
  -- Check the the VRF private key file does not give read/write/exec permissions to others.
  Bool
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (FileMode -> Bool
hasOtherPermissions FileMode
fm)
    (VRFPrivateKeyFilePermissionError
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (VRFPrivateKeyFilePermissionError
 -> ExceptT VRFPrivateKeyFilePermissionError IO ())
-> VRFPrivateKeyFilePermissionError
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> VRFPrivateKeyFilePermissionError
OtherPermissionsExist FilePath
vrfPrivKey)
  -- Check the the VRF private key file does not give read/write/exec permissions to any group.
  Bool
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (FileMode -> Bool
hasGroupPermissions FileMode
fm)
    (VRFPrivateKeyFilePermissionError
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (VRFPrivateKeyFilePermissionError
 -> ExceptT VRFPrivateKeyFilePermissionError IO ())
-> VRFPrivateKeyFilePermissionError
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> VRFPrivateKeyFilePermissionError
GroupPermissionsExist FilePath
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

-- | Opens a file from disk.
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 ownerModes}

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

# endif
#endif