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

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module System.Nix.Internal.Nar.Streamer where

import           Control.Monad                   (forM, forM_, when)
import qualified Control.Monad.IO.Class          as IO
import           Data.Bool                       (bool)
import qualified Data.ByteString                 as BS
import qualified Data.ByteString.Char8           as BSC
import qualified Data.ByteString.Lazy            as BSL
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)
  => (BS.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 -> ByteString
str ByteString
"nix-archive-1")
  m () -> m ()
parens (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
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
BSC.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) (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 ()
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] -> ByteString
strs [ByteString
"name", FilePath -> ByteString
BSC.pack FilePath
f, ByteString
"node"])
            m () -> m ()
parens (FilePath -> m ()
go FilePath
fullName)

    str :: BS.ByteString -> BS.ByteString
    str :: ByteString -> ByteString
str ByteString
t = let len :: Int
len =  ByteString -> Int
BS.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 -> BS.ByteString -> BS.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
BS.replicate (Int -> Int
padLen Int
strSize) Word8
0

    parens :: m () -> m ()
parens m ()
act = do
      ByteString -> m ()
yield (ByteString -> ByteString
str ByteString
"(")
      ()
r <- m ()
act
      ByteString -> m ()
yield (ByteString -> ByteString
str ByteString
")")
      () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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]
BSL.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
BSL.readFile FilePath
path)
      ByteString -> m ()
yield (Int -> Word8 -> ByteString
BS.replicate (Int -> Int
padLen (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
fsize)) Word8
0)

    strs :: [BS.ByteString] -> BS.ByteString
    strs :: [ByteString] -> ByteString
strs [ByteString]
xs = [ByteString] -> ByteString
BS.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 -> BS.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 (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