{-# 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 qualified Control.Monad
import qualified Data.ByteString
import qualified Data.ByteString.Lazy        as Bytes.Lazy
import qualified System.Directory            as Directory
import           System.Posix.Files          ( createSymbolicLink
                                             , fileMode
                                             , fileSize
                                             , FileStatus
                                             , getFileStatus
                                             , getSymbolicLinkStatus
                                             , groupExecuteMode
                                             , intersectFileModes
                                             , isDirectory
                                             , isRegularFile
                                             , nullFileMode
                                             , otherExecuteMode
                                             , ownerExecuteMode
                                             , readSymbolicLink
                                             , setFileMode
                                             , unionFileModes
                                             )
import qualified System.IO                   as IO
import qualified Control.Exception.Lifted    as Exception.Lifted

data IsExecutable = NonExecutable | Executable
  deriving (IsExecutable -> IsExecutable -> Bool
(IsExecutable -> IsExecutable -> Bool)
-> (IsExecutable -> IsExecutable -> Bool) -> Eq IsExecutable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsExecutable -> IsExecutable -> Bool
== :: IsExecutable -> IsExecutable -> Bool
$c/= :: IsExecutable -> IsExecutable -> Bool
/= :: IsExecutable -> IsExecutable -> Bool
Eq, Int -> IsExecutable -> ShowS
[IsExecutable] -> ShowS
IsExecutable -> String
(Int -> IsExecutable -> ShowS)
-> (IsExecutable -> String)
-> ([IsExecutable] -> ShowS)
-> Show IsExecutable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsExecutable -> ShowS
showsPrec :: Int -> IsExecutable -> ShowS
$cshow :: IsExecutable -> String
show :: IsExecutable -> String
$cshowList :: [IsExecutable] -> ShowS
showList :: [IsExecutable] -> ShowS
Show)

data NarEffects (m :: Type -> Type) = NarEffects {
    forall (m :: * -> *). NarEffects m -> String -> m ByteString
narReadFile   :: FilePath -> m Bytes.Lazy.ByteString
  , forall (m :: * -> *).
NarEffects m -> String -> IsExecutable -> ByteString -> m ()
narWriteFile  :: FilePath -> IsExecutable -> Bytes.Lazy.ByteString -> m ()
  , forall (m :: * -> *).
NarEffects m
-> String -> IsExecutable -> m (Maybe ByteString) -> m ()
narStreamFile :: FilePath -> IsExecutable -> m (Maybe ByteString) -> m ()
  , forall (m :: * -> *). NarEffects m -> String -> m [String]
narListDir    :: FilePath -> m [FilePath]
  , forall (m :: * -> *). NarEffects m -> String -> m ()
narCreateDir  :: FilePath -> m ()
  , forall (m :: * -> *). NarEffects m -> String -> String -> m ()
narCreateLink :: FilePath -> FilePath -> m ()
  , forall (m :: * -> *). NarEffects m -> String -> m IsExecutable
narIsExec     :: FilePath -> m IsExecutable
  , forall (m :: * -> *). NarEffects m -> String -> m Bool
narIsDir      :: FilePath -> m Bool
  , forall (m :: * -> *). NarEffects m -> String -> m Bool
narIsSymLink  :: FilePath -> m Bool
  , forall (m :: * -> *). NarEffects m -> String -> m Int64
narFileSize   :: FilePath -> m Int64
  , forall (m :: * -> *). NarEffects m -> String -> m String
narReadLink   :: FilePath -> m FilePath
  , forall (m :: * -> *). NarEffects m -> String -> m ()
narDeleteDir  :: FilePath -> m ()
  , forall (m :: * -> *). NarEffects m -> String -> 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 :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m) =>
NarEffects m
narEffectsIO = NarEffects {
    narReadFile :: String -> m ByteString
narReadFile   = IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (String -> IO ByteString) -> String -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
Bytes.Lazy.readFile
  , narWriteFile :: String -> IsExecutable -> ByteString -> m ()
narWriteFile  = \String
f IsExecutable
e ByteString
c -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      String -> ByteString -> IO ()
Bytes.Lazy.writeFile String
f ByteString
c
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.when (IsExecutable
e IsExecutable -> IsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== IsExecutable
Executable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
setExecutable String
f
  , narStreamFile :: String -> IsExecutable -> m (Maybe ByteString) -> m ()
narStreamFile = String -> IsExecutable -> m (Maybe ByteString) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m) =>
String -> IsExecutable -> m (Maybe ByteString) -> m ()
streamStringOutIO
  , narListDir :: String -> m [String]
narListDir    = IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> m [String])
-> (String -> IO [String]) -> String -> m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO [String]
Directory.listDirectory
  , narCreateDir :: String -> m ()
narCreateDir  = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
Directory.createDirectory
  , narCreateLink :: String -> String -> m ()
narCreateLink = \String
f -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
createSymbolicLink String
f
  , narIsExec :: String -> m IsExecutable
narIsExec     = IO IsExecutable -> m IsExecutable
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IsExecutable -> m IsExecutable)
-> (String -> IO IsExecutable) -> String -> m IsExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileStatus -> IsExecutable) -> IO FileStatus -> IO IsExecutable
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IsExecutable -> IsExecutable -> Bool -> IsExecutable
forall a. a -> a -> Bool -> a
bool IsExecutable
NonExecutable IsExecutable
Executable (Bool -> IsExecutable)
-> (FileStatus -> Bool) -> FileStatus -> IsExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> Bool
isExecutable) (IO FileStatus -> IO IsExecutable)
-> (String -> IO FileStatus) -> String -> IO IsExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO FileStatus
getSymbolicLinkStatus
  , narIsDir :: String -> m Bool
narIsDir      = (FileStatus -> Bool) -> m FileStatus -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileStatus -> Bool
isDirectory (m FileStatus -> m Bool)
-> (String -> m FileStatus) -> String -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO FileStatus -> m FileStatus
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> m FileStatus)
-> (String -> IO FileStatus) -> String -> m FileStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO FileStatus
getFileStatus
  , narIsSymLink :: String -> m Bool
narIsSymLink  = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> (String -> IO Bool) -> String -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
Directory.pathIsSymbolicLink
  , narFileSize :: String -> m Int64
narFileSize   = (FileStatus -> Int64) -> m FileStatus -> m Int64
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FileOffset -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Int64)
-> (FileStatus -> FileOffset) -> FileStatus -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileOffset
fileSize) (m FileStatus -> m Int64)
-> (String -> m FileStatus) -> String -> m Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO FileStatus -> m FileStatus
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> m FileStatus)
-> (String -> IO FileStatus) -> String -> m FileStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO FileStatus
getFileStatus
  , narReadLink :: String -> m String
narReadLink   = IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String)
-> (String -> IO String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readSymbolicLink
  , narDeleteDir :: String -> m ()
narDeleteDir  = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
Directory.removeDirectoryRecursive
  , narDeleteFile :: String -> m ()
narDeleteFile = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
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 :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m) =>
String -> IsExecutable -> m (Maybe ByteString) -> m ()
streamStringOutIO String
f IsExecutable
executable m (Maybe ByteString)
getChunk =
  m Handle -> (Handle -> m ()) -> (Handle -> m ()) -> m ()
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
Exception.Lifted.bracket
    (IO Handle -> m Handle
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> IO Handle
IO.openFile String
f IOMode
WriteMode)
    (\Handle
h -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
updateExecutablePermissions IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
IO.hClose Handle
h))
    Handle -> m ()
go
  m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`Exception.Lifted.catch`
    SomeException -> m ()
cleanupException
 where
  go :: Handle -> m ()
  go :: Handle -> m ()
go Handle
handle = do
    Maybe ByteString
chunk <- m (Maybe ByteString)
getChunk
    case Maybe ByteString
chunk of
      Maybe ByteString
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ByteString
c  -> do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
Data.ByteString.hPut Handle
handle ByteString
c
        Handle -> m ()
go Handle
handle
  updateExecutablePermissions :: IO ()
updateExecutablePermissions =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.when (IsExecutable
executable IsExecutable -> IsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== IsExecutable
Executable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
setExecutable String
f
  cleanupException :: SomeException -> m ()
cleanupException (SomeException
e :: Exception.Lifted.SomeException) = do
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.removeFile String
f
    String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Control.Monad.fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
      String
"Failed to stream string to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
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 :: FileStatus -> Bool
isExecutable FileStatus
st =
  FileStatus -> Bool
isRegularFile FileStatus
st
    Bool -> Bool -> Bool
&& FileStatus -> FileMode
fileMode FileStatus
st FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
ownerExecuteMode FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
nullFileMode

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