{-# LANGUAGE OverloadedStrings #-}
-- | Stream out a NAR file from a regular file

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

import Data.ByteString (ByteString)
import Data.Int (Int64)
import qualified Data.Map.Strict                 as Map

import           Control.Monad                    ( forM_
                                                  , when
                                                  )
import qualified Control.Monad.IO.Class          as IO
import qualified Data.ByteString                 as Bytes
import qualified Data.ByteString.Lazy            as Bytes.Lazy
import qualified Data.Foldable
import qualified Data.List
import qualified Data.Serialize                  as Serial
import qualified Data.Text                       as T (pack, unpack)
import qualified Data.Text.Encoding              as TE (encodeUtf8)
import           System.FilePath                 ((</>))

import qualified System.Nix.Nar.Effects as Nar
import qualified System.Nix.Nar.Options 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 :: forall (m :: * -> *). MonadIO m => 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 ()
Data.Foldable.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 :: forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *).
MonadIO m =>
NarEffects IO -> FilePath -> NarSource m
streamNarIO NarEffects IO
effs FilePath
basePath ByteString -> m ()
yield =
  NarOptions -> NarEffects IO -> FilePath -> NarSource m
forall (m :: * -> *).
MonadIO m =>
NarOptions -> NarEffects IO -> FilePath -> NarSource m
streamNarIOWithOptions NarOptions
Nar.defaultNarOptions NarEffects IO
effs FilePath
basePath ByteString -> m ()
yield

streamNarIOWithOptions
  :: forall m
   . IO.MonadIO m
  => Nar.NarOptions
  -> Nar.NarEffects IO
  -> FilePath
  -> NarSource m
streamNarIOWithOptions :: forall (m :: * -> *).
MonadIO m =>
NarOptions -> NarEffects IO -> FilePath -> NarSource m
streamNarIOWithOptions NarOptions
opts 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 ()
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
isSymLink <- IO Bool -> m Bool
forall a. IO a -> m a
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
    if Bool
isSymLink then do
      FilePath
target <- IO FilePath -> m FilePath
forall a. IO a -> m a
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
filePathToBS FilePath
target]
      else do
        Bool
isDir <- IO Bool -> m Bool
forall a. IO a -> m a
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
        if Bool
isDir then do
          [FilePath]
fs <- IO [FilePath] -> m [FilePath]
forall a. IO a -> m a
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)
          let entries :: Map FilePath FilePath
entries =
                (FilePath -> Map FilePath FilePath -> Map FilePath FilePath)
-> Map FilePath FilePath -> [FilePath] -> Map FilePath FilePath
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\FilePath
f Map FilePath FilePath
acc ->
                  let
                    name :: FilePath
name =
                      if NarOptions -> Bool
Nar.optUseCaseHack NarOptions
opts
                      then FilePath -> FilePath
undoCaseHack FilePath
f
                      else FilePath
f
                  in
                  case (FilePath -> FilePath -> FilePath -> FilePath)
-> FilePath
-> FilePath
-> Map FilePath FilePath
-> (Maybe FilePath, Map FilePath FilePath)
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\FilePath
_ FilePath
n FilePath
_ -> FilePath
n) FilePath
name FilePath
f Map FilePath FilePath
acc of
                    (Maybe FilePath
Nothing, Map FilePath FilePath
newMap) -> Map FilePath FilePath
newMap
                    (Just FilePath
conflict, Map FilePath FilePath
_) -> FilePath -> Map FilePath FilePath
forall a. HasCallStack => FilePath -> a
error (FilePath -> Map FilePath FilePath)
-> FilePath -> Map FilePath FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"File name collision between " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
name) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" and " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
conflict)
                ) Map FilePath FilePath
forall k a. Map k a
Map.empty [FilePath]
fs
          ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
strs [ByteString
"type", ByteString
"directory"]
          [(FilePath, FilePath)] -> ((FilePath, FilePath) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map FilePath FilePath
entries) (((FilePath, FilePath) -> m ()) -> m ())
-> ((FilePath, FilePath) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
unhacked, FilePath
original) -> 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
              ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
strs [ByteString
"name", FilePath -> ByteString
filePathToBS FilePath
unhacked, ByteString
"node"]
              m () -> m ()
parens (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
go (FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
original)
        else do
          IsExecutable
isExec <- IO IsExecutable -> m IsExecutable
forall a. IO a -> m a
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 :: * -> *). NarEffects m -> FilePath -> m IsExecutable
Nar.narIsExec 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
Nar.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 a. IO a -> m a
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

  parens :: m () -> m ()
parens m ()
act = do
    ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
str ByteString
"("
    ()
r <- m ()
act
    ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
str ByteString
")"
    () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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 ())
-> (LazyByteString -> [ByteString]) -> LazyByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> [ByteString]
Bytes.Lazy.toChunks (LazyByteString -> m ()) -> m LazyByteString -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LazyByteString -> m LazyByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (NarEffects IO -> FilePath -> IO LazyByteString
forall (m :: * -> *). NarEffects m -> FilePath -> m LazyByteString
Nar.narReadFile NarEffects IO
effs 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

-- | 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 :: forall a. Integral a => 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

filePathToBS :: FilePath -> ByteString
filePathToBS :: FilePath -> ByteString
filePathToBS = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack

undoCaseHack :: FilePath -> FilePath
undoCaseHack :: FilePath -> FilePath
undoCaseHack FilePath
f =
  case (FilePath -> Bool) -> [FilePath] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
Data.List.findIndex (FilePath
caseHackSuffix FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`Data.List.isPrefixOf`) (FilePath -> [FilePath]
forall a. [a] -> [[a]]
Data.List.tails FilePath
f) of
     Just Int
index -> Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
index FilePath
f
     Maybe Int
Nothing -> FilePath
f
  where
    caseHackSuffix :: FilePath
caseHackSuffix = Text -> FilePath
T.unpack Text
Nar.caseHackSuffix