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

{-# language ScopedTypeVariables #-}

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

import qualified Control.Monad.IO.Class          as IO
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.Serialize                  as Serial
import qualified System.Directory                as Directory
import           System.FilePath                  ( (</>) )

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


-- | NarSource
-- The source to provide nar to the handler `(ByteString -> m ())`.
-- It is isomorphic to ByteString by Yoneda lemma
-- if the result is meant to be m ().
-- It is done in CPS style so IO can be chunks.
type NarSource m =  (ByteString -> m ()) -> m ()


-- | dumpString
-- dump a string to nar in CPS style. The function takes in a `ByteString`,
-- and build a `NarSource m`.
dumpString
  :: forall m. IO.MonadIO m
  => ByteString -- ^ the string you want to dump
  -> NarSource m -- ^ The nar result in CPS style
dumpString :: ByteString -> NarSource m
dumpString ByteString
text ByteString -> m ()
yield = (ByteString -> m ()) -> [ByteString] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ByteString -> m ()
yield (ByteString -> m ())
-> (ByteString -> ByteString) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
str)
  [ByteString
"nix-archive-1", ByteString
"(", ByteString
"type" , ByteString
"regular", ByteString
"contents", ByteString
text, ByteString
")"]


-- | dumpPath
-- shorthand
-- build a Source that turn file path to nar using the default narEffectsIO.
dumpPath
  :: forall m . IO.MonadIO m
  => FilePath -- ^ path for the file you want to dump to nar
  -> NarSource m -- ^ the nar result in CPS style
dumpPath :: FilePath -> NarSource m
dumpPath = NarEffects IO -> FilePath -> NarSource m
forall (m :: * -> *).
MonadIO m =>
NarEffects IO -> FilePath -> NarSource m
streamNarIO NarEffects IO
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadBaseControl IO m) =>
NarEffects m
Nar.narEffectsIO


-- | 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 => Nar.NarEffects IO -> FilePath -> NarSource m
streamNarIO :: NarEffects IO -> FilePath -> NarSource m
streamNarIO NarEffects IO
effs FilePath
basePath ByteString -> m ()
yield = 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]
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

  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

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

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

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

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