{-# 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 Data.Text (Text)

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, breakOn)
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)
          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]
Data.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
              let serializedPath :: ByteString
serializedPath =
                    if NarOptions -> Bool
Nar.optUseCaseHack NarOptions
opts then
                      FilePath -> ByteString
filePathToBSWithCaseHack FilePath
f
                    else
                      FilePath -> ByteString
filePathToBS FilePath
f
              ByteString -> m ()
yield (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
strs [ByteString
"name", ByteString
serializedPath, ByteString
"node"]
              m () -> m ()
parens (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
go FilePath
fullName
        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

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

undoCaseHack :: Text -> Text
undoCaseHack :: Text -> Text
undoCaseHack = (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
Nar.caseHackSuffix