Effects.hs

{-# LANGUAGE RankNTypes #-}

module System.Nix.Nar.Effects
  ( NarEffects(..)
  , narEffectsIO
  , IsExecutable(..)
  , isExecutable
  , setExecutable
  ) where

import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.ByteString (ByteString)
import Data.Bool (bool)
import Data.Int (Int64)
import Data.Kind (Type)
import System.IO (Handle, IOMode(WriteMode))

import Control.Monad qualified
import Data.ByteString qualified
import Data.ByteString.Lazy qualified        as Bytes.Lazy
import System.Directory qualified            as Directory
import           System.Posix.Files          ( createSymbolicLink
                                             , fileMode
                                             , fileSize
                                             , FileStatus
                                             , getFileStatus
                                             , getSymbolicLinkStatus
                                             , groupExecuteMode
                                             , intersectFileModes
                                             , isDirectory
                                             , isRegularFile
                                             , nullFileMode
                                             , otherExecuteMode
                                             , ownerExecuteMode
                                             , readSymbolicLink
                                             , setFileMode
                                             , unionFileModes
                                             )
import System.IO qualified                   as IO
import Control.Exception.Lifted qualified    as Exception.Lifted

data IsExecutable = NonExecutable | Executable
  deriving (Eq, Show)

data NarEffects (m :: Type -> Type) = NarEffects {
    narReadFile   :: FilePath -> m Bytes.Lazy.ByteString
  , narWriteFile  :: FilePath -> IsExecutable -> Bytes.Lazy.ByteString -> m ()
  , narStreamFile :: FilePath -> IsExecutable -> m (Maybe ByteString) -> m ()
  , narListDir    :: FilePath -> m [FilePath]
  , narCreateDir  :: FilePath -> m ()
  , narCreateLink :: FilePath -> FilePath -> m ()
  , narIsExec     :: FilePath -> m IsExecutable
  , narIsDir      :: FilePath -> m Bool
  , narIsSymLink  :: FilePath -> m Bool
  , narFileSize   :: FilePath -> m Int64
  , narReadLink   :: FilePath -> m FilePath
  , narDeleteDir  :: FilePath -> m ()
  , narDeleteFile :: FilePath -> m ()
}

-- | A particular @NarEffects@ that uses regular POSIX for file manipulation
--   You would replace this with your own @NarEffects@ if you wanted a
--   different backend
narEffectsIO
  :: ( MonadIO m
     , MonadFail m
     , MonadBaseControl IO m
     )
  => NarEffects m
narEffectsIO = NarEffects {
    narReadFile   = liftIO . Bytes.Lazy.readFile
  , narWriteFile  = \f e c -> liftIO $ do
      Bytes.Lazy.writeFile f c
      Control.Monad.when (e == Executable) $
        setExecutable f
  , narStreamFile = streamStringOutIO
  , narListDir    = liftIO . Directory.listDirectory
  , narCreateDir  = liftIO . Directory.createDirectory
  , narCreateLink = \f -> liftIO . createSymbolicLink f
  , narIsExec     = liftIO . fmap (bool NonExecutable Executable . isExecutable) . getSymbolicLinkStatus
  , narIsDir      = fmap isDirectory . liftIO . getFileStatus
  , narIsSymLink  = liftIO . Directory.pathIsSymbolicLink
  , narFileSize   = fmap (fromIntegral . fileSize) . liftIO . getFileStatus
  , narReadLink   = liftIO . readSymbolicLink
  , narDeleteDir  = liftIO . Directory.removeDirectoryRecursive
  , narDeleteFile = liftIO . Directory.removeFile
  }

-- | This default implementation for @narStreamFile@ requires @MonadIO@
streamStringOutIO
  :: forall m
   . ( MonadIO m
     , MonadFail m
     , MonadBaseControl IO m
     )
  => FilePath
  -> IsExecutable
  -> m (Maybe ByteString)
  -> m ()
streamStringOutIO f executable getChunk =
  Exception.Lifted.bracket
    (liftIO $ IO.openFile f WriteMode)
    (\h -> liftIO (updateExecutablePermissions >> IO.hClose h))
    go
  `Exception.Lifted.catch`
    cleanupException
 where
  go :: Handle -> m ()
  go handle = do
    chunk <- getChunk
    case chunk of
      Nothing -> pure ()
      Just c  -> do
        liftIO $ Data.ByteString.hPut handle c
        go handle
  updateExecutablePermissions =
    Control.Monad.when (executable == Executable) $
      setExecutable f
  cleanupException (e :: Exception.Lifted.SomeException) = do
    liftIO $ Directory.removeFile f
    Control.Monad.fail $
      "Failed to stream string to " <> f <> ": " <> show e

-- | Check whether the file is executable by the owner.
--
--   Matches the logic used by Nix.
--
--   access() should not be used for this purpose on macOS.
--   It returns false for executables when placed in certain directories.
--   For example, when in an app bundle: App.app/Contents/Resources/en.lproj/myexecutable.strings
isExecutable :: FileStatus -> Bool
isExecutable st =
  isRegularFile st
    && fileMode st `intersectFileModes` ownerExecuteMode /= nullFileMode

-- | Set the file to be executable by the owner, group, and others.
--
--   Matches the logic used by Nix.
setExecutable :: FilePath -> IO ()
setExecutable f = do
  st <- getSymbolicLinkStatus f
  let p =
        fileMode st
          `unionFileModes` ownerExecuteMode
          `unionFileModes` groupExecuteMode
          `unionFileModes` otherExecuteMode
  setFileMode f p