-- | Stream out a NAR file from a regular file

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module System.Nix.Internal.Nar.Streamer
  ( streamNarIO
  , IsExecutable(..)
  )
where

import           Control.Monad                    ( forM_
                                                  , when
                                                  )
import qualified Control.Monad.IO.Class          as IO
import           Data.Bool                        ( bool )
import           Data.ByteString                  ( ByteString )
import qualified Data.ByteString                 as Bytes
import qualified Data.ByteString.Char8           as Bytes.Char8
import qualified Data.ByteString.Lazy            as Bytes.Lazy
import qualified Data.List                       as List
import qualified Data.Serialize                  as Serial
import           GHC.Int                          ( Int64 )
import qualified System.Directory                as Directory
import           System.FilePath                  ( (</>) )

import qualified System.Nix.Internal.Nar.Effects as Nar


-- | This implementation of Nar encoding takes an arbitrary @yield@
--   function from any streaming library, and repeatedly calls
--   it while traversing the filesystem object to Nar encode
streamNarIO
  :: forall m
   . (IO.MonadIO m)
  => (ByteString -> m ())
  -> Nar.NarEffects IO
  -> FilePath
  -> m ()
streamNarIO :: (ByteString -> m ()) -> NarEffects IO -> FilePath -> m ()
streamNarIO ByteString -> m ()
yield NarEffects IO
effs FilePath
basePath = do
  ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
str ByteString
"nix-archive-1"
  m () -> m ()
forall b. m b -> m b
parens (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
go FilePath
basePath

 where

  go :: FilePath -> m ()
  go :: FilePath -> m ()
go FilePath
path = do
    Bool
isDir     <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ NarEffects IO -> FilePath -> IO Bool
forall (m :: * -> *). NarEffects m -> FilePath -> m Bool
Nar.narIsDir NarEffects IO
effs FilePath
path
    Bool
isSymLink <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ NarEffects IO -> FilePath -> IO Bool
forall (m :: * -> *). NarEffects m -> FilePath -> m Bool
Nar.narIsSymLink NarEffects IO
effs FilePath
path
    let isRegular :: Bool
isRegular = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
isDir Bool -> Bool -> Bool
|| Bool
isSymLink

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSymLink (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      FilePath
target <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ NarEffects IO -> FilePath -> IO FilePath
forall (m :: * -> *). NarEffects m -> FilePath -> m FilePath
Nar.narReadLink NarEffects IO
effs FilePath
path
      ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$
        [ByteString] -> ByteString
strs [ByteString
"type", ByteString
"symlink", ByteString
"target", FilePath -> ByteString
Bytes.Char8.pack FilePath
target]

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRegular (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      IsExecutable
isExec <- IO IsExecutable -> m IsExecutable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO IsExecutable -> m IsExecutable)
-> IO IsExecutable -> m IsExecutable
forall a b. (a -> b) -> a -> b
$ NarEffects IO -> FilePath -> IO IsExecutable
forall (m :: * -> *).
Functor m =>
NarEffects m -> FilePath -> m IsExecutable
isExecutable NarEffects IO
effs FilePath
path
      ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
strs [ByteString
"type", ByteString
"regular"]
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsExecutable
isExec IsExecutable -> IsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== IsExecutable
Executable) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
strs [ByteString
"executable", ByteString
""]
      Int64
fSize <- IO Int64 -> m Int64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO Int64 -> m Int64) -> IO Int64 -> m Int64
forall a b. (a -> b) -> a -> b
$ NarEffects IO -> FilePath -> IO Int64
forall (m :: * -> *). NarEffects m -> FilePath -> m Int64
Nar.narFileSize NarEffects IO
effs FilePath
path
      ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
str ByteString
"contents"
      ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString
forall a. Integral a => a -> ByteString
int Int64
fSize
      FilePath -> Int64 -> m ()
yieldFile FilePath
path Int64
fSize

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isDir (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      [FilePath]
fs <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (NarEffects IO -> FilePath -> IO [FilePath]
forall (m :: * -> *). NarEffects m -> FilePath -> m [FilePath]
Nar.narListDir NarEffects IO
effs FilePath
path)
      ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
strs [ByteString
"type", ByteString
"directory"]
      [FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
List.sort [FilePath]
fs) ((FilePath -> m ()) -> m ()) -> (FilePath -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
        ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
str ByteString
"entry"
        m () -> m ()
forall b. m b -> m b
parens (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          let fullName :: FilePath
fullName = FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
f
          ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
strs [ByteString
"name", FilePath -> ByteString
Bytes.Char8.pack FilePath
f, ByteString
"node"]
          m () -> m ()
forall b. m b -> m b
parens (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
go FilePath
fullName

  str :: ByteString -> ByteString
  str :: ByteString -> ByteString
str ByteString
t =
    let
      len :: Int
len = ByteString -> Int
Bytes.length ByteString
t
    in
      Int -> ByteString
forall a. Integral a => a -> ByteString
int Int
len ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
padBS Int
len ByteString
t

  padBS :: Int -> ByteString -> ByteString
  padBS :: Int -> ByteString -> ByteString
padBS Int
strSize ByteString
bs = ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
Bytes.replicate (Int -> Int
padLen Int
strSize) Word8
0

  parens :: m b -> m b
parens m b
act = do
    ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
str ByteString
"("
    b
r <- m b
act
    ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
str ByteString
")"
    b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

  -- Read, yield, and pad the file
  yieldFile :: FilePath -> Int64 -> m ()
  yieldFile :: FilePath -> Int64 -> m ()
yieldFile FilePath
path Int64
fsize = do
    (ByteString -> m ()) -> [ByteString] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> m ()
yield ([ByteString] -> m ())
-> (ByteString -> [ByteString]) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
Bytes.Lazy.toChunks (ByteString -> m ()) -> m ByteString -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (FilePath -> IO ByteString
Bytes.Lazy.readFile FilePath
path)
    ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
Bytes.replicate (Int -> Int
padLen (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
fsize) Word8
0

  strs :: [ByteString] -> ByteString
  strs :: [ByteString] -> ByteString
strs [ByteString]
xs = [ByteString] -> ByteString
Bytes.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
str (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
xs

  int :: Integral a => a -> ByteString
  int :: a -> ByteString
int a
n = Put -> ByteString
Serial.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Putter Int64
Serial.putInt64le Putter Int64 -> Putter Int64
forall a b. (a -> b) -> a -> b
$ a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n


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
/= :: IsExecutable -> IsExecutable -> Bool
$c/= :: IsExecutable -> IsExecutable -> Bool
== :: IsExecutable -> IsExecutable -> Bool
$c== :: IsExecutable -> IsExecutable -> Bool
Eq, Int -> IsExecutable -> FilePath -> FilePath
[IsExecutable] -> FilePath -> FilePath
IsExecutable -> FilePath
(Int -> IsExecutable -> FilePath -> FilePath)
-> (IsExecutable -> FilePath)
-> ([IsExecutable] -> FilePath -> FilePath)
-> Show IsExecutable
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [IsExecutable] -> FilePath -> FilePath
$cshowList :: [IsExecutable] -> FilePath -> FilePath
show :: IsExecutable -> FilePath
$cshow :: IsExecutable -> FilePath
showsPrec :: Int -> IsExecutable -> FilePath -> FilePath
$cshowsPrec :: Int -> IsExecutable -> FilePath -> FilePath
Show)

isExecutable :: Functor m => Nar.NarEffects m -> FilePath -> m IsExecutable
isExecutable :: NarEffects m -> FilePath -> m IsExecutable
isExecutable NarEffects m
effs FilePath
fp =
  IsExecutable -> IsExecutable -> Bool -> IsExecutable
forall a. a -> a -> Bool -> a
bool
    IsExecutable
NonExecutable
    IsExecutable
Executable
    (Bool -> IsExecutable)
-> (Permissions -> Bool) -> Permissions -> IsExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permissions -> Bool
Directory.executable (Permissions -> IsExecutable) -> m Permissions -> m IsExecutable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NarEffects m -> FilePath -> m Permissions
forall (m :: * -> *). NarEffects m -> FilePath -> m Permissions
Nar.narGetPerms NarEffects m
effs FilePath
fp

-- | Distance to the next multiple of 8
padLen :: Int -> Int
padLen :: Int -> Int
padLen Int
n = (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8