hnix-store/hnix-store-core/tests/NarFormat.hs

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}

module NarFormat where

import           Control.Applicative              (many, optional, (<|>))
import qualified Control.Concurrent               as Concurrent
import           Control.Exception                (SomeException, try)
import           Control.Monad                    (replicateM, void,
                                                   when)
import           Data.Binary.Get                  (Get, getByteString,
                                                   getInt64le,
                                                   getLazyByteString, runGet)
import           Data.Binary.Put                  (Put, putInt64le,
                                                   putLazyByteString, runPut)
import qualified Data.ByteString                  as BS
import qualified Data.ByteString.Base64.Lazy      as B64
import qualified Data.ByteString.Char8            as BSC
import qualified Data.ByteString.Lazy             as BSL
import qualified Data.ByteString.Lazy.Char8       as BSLC
import           Data.Int
import qualified Data.Map                         as Map
import           Data.Maybe                       (fromMaybe)
import qualified Data.Text                        as T
import qualified Data.Text.Encoding               as E
import           System.Directory                 (doesDirectoryExist, doesPathExist,
                                                   removeDirectoryRecursive,
                                                   removeFile)
import qualified System.Directory                 as Directory
import           System.Environment               (getEnv)
import           System.FilePath                  ((<.>), (</>))
import qualified System.IO                        as IO
import qualified System.IO.Temp                   as Temp
import qualified System.Posix.Process             as Unix
import qualified System.Process                   as P
import           Test.Tasty                       as T
import           Test.Tasty.Hspec
import qualified Test.Tasty.HUnit                 as HU
import           Test.Tasty.QuickCheck
import qualified Text.Printf                      as Printf
import           Text.Read                        (readMaybe)

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



withBytesAsHandle :: BSLC.ByteString -> (IO.Handle -> IO a) -> IO a
withBytesAsHandle bytes act = do
  Temp.withSystemTempFile "nar-test-file-XXXXX" $ \tmpFile h -> do
    IO.hClose h
    BSL.writeFile tmpFile bytes
    IO.withFile tmpFile IO.ReadMode act

spec_narEncoding :: Spec
spec_narEncoding = do

  -- For a Haskell embedded Nar, check that (decode . encode === id)
  let
    withTempDir act = Temp.withSystemTempDirectory "nar-test" act


    roundTrip :: String -> Nar -> IO ()
    roundTrip narFileName n = withTempDir $ \tmpDir -> do
        let packageFilePath = tmpDir </> narFileName

        e <- doesPathExist packageFilePath
        e `shouldBe` False

        res <- withBytesAsHandle (runPut (putNar n)) $ \h -> do
          unpackNarIO narEffectsIO h packageFilePath
        res `shouldBe` Right ()

        e' <- doesPathExist packageFilePath
        e' `shouldBe` True

        res' <- Temp.withSystemTempFile "nar-test-file-hnix" $ \tmpFile h -> do
          buildNarIO narEffectsIO packageFilePath h
          IO.hClose h
          BSL.readFile tmpFile

        res' `shouldBe` (runPut $ putNar n)

  -- For a Haskell embedded Nar, check that encoding it gives
  -- the same bytestring as `nix-store --dump`
  let
    encEqualsNixStore :: Nar -> BSL.ByteString -> IO ()
    encEqualsNixStore n b = runPut (putNar n) `shouldBe` b


  describe "parser-roundtrip" $ do
    it "roundtrips regular" $ do
      roundTrip "sampleRegular" (Nar sampleRegular)

    it "roundtrips regular 2" $ do
      roundTrip "sampleRegular'" (Nar sampleRegular')

    it "roundtrips executable" $ do
      roundTrip "sampleExecutable" (Nar sampleExecutable)

    it "roundtrips directory" $ do
      roundTrip "sampleDirectory" (Nar sampleDirectory)

  describe "matches-nix-store fixture" $ do
    it "matches regular" $ do
      encEqualsNixStore (Nar sampleRegular) sampleRegularBaseline

    it "matches regular'" $
      encEqualsNixStore (Nar sampleRegular') sampleRegular'Baseline

    it "matches executable" $
      encEqualsNixStore (Nar sampleExecutable) sampleExecutableBaseline

    it "matches symlink" $
      encEqualsNixStore (Nar sampleSymLink) sampleSymLinkBaseline

    it "matches directory" $ do
      encEqualsNixStore (Nar sampleDirectory) sampleDirectoryBaseline


unit_nixStoreRegular :: HU.Assertion
unit_nixStoreRegular = filesystemNixStore "regular" (Nar sampleRegular)

unit_nixStoreDirectory :: HU.Assertion
unit_nixStoreDirectory = filesystemNixStore "directory" (Nar sampleDirectory)

unit_nixStoreDirectory' :: HU.Assertion
unit_nixStoreDirectory' = filesystemNixStore "directory'" (Nar sampleDirectory')

test_nixStoreBigFile :: TestTree
test_nixStoreBigFile = packThenExtract "bigfile" $ \baseDir -> do
  mkBigFile (baseDir </> "bigfile")


test_nixStoreBigDir :: TestTree
test_nixStoreBigDir = packThenExtract "bigdir" $ \baseDir -> do
  let testDir = baseDir </> "bigdir"
  Directory.createDirectory testDir
  mkBigFile (testDir </> "bf1")
  mkBigFile (testDir </> "bf2")
  -- flip mapM_ [1..100] $ \i ->
  --   mkBigFile (testDir </> ('f': show i))
  -- -- Directory.createDirectory (testDir </> "")


prop_narEncodingArbitrary :: Nar -> Property
prop_narEncodingArbitrary n = runGet getNar (runPut $ putNar n) === n

unit_packSelfSrcDir :: HU.Assertion
unit_packSelfSrcDir = Temp.withSystemTempDirectory "nar-test" $ \tmpDir -> do
  ver <- try (P.readProcess "nix-store" ["--version"] "")
  let narFilePath = tmpDir </> "src.nar"
  case ver of
    Left  (_ :: SomeException) -> print ("No nix-store on system" :: String)
    Right _ -> do
      let go dir = do
            srcHere <- doesDirectoryExist dir
            case srcHere of
              False -> pure ()
              True -> do
                IO.withFile narFilePath IO.WriteMode $ \h ->
                  buildNarIO narEffectsIO "src" h
                hnixNar <- BSL.readFile narFilePath
                nixStoreNar <- getNixStoreDump "src"
                HU.assertEqual
                  "src dir serializes the same between hnix-store and nix-store"
                  hnixNar
                  nixStoreNar
      go "src"
      go "hnix-store-core/src"
-- ||||||| merged common ancestors
--       hnixNar <- runPut . put <$> localPackNar narEffectsIO "src"
--       nixStoreNar <- getNixStoreDump "src"
--       HU.assertEqual
--         "src dir serializes the same between hnix-store and nix-store"
--         hnixNar
--         nixStoreNar
-- =======
--       let narFile = tmpDir </> "src.nar"
--       IO.withFile narFile IO.WriteMode $ \h ->
--         buildNarIO narEffectsIO "src" h
--       hnixNar <- BSL.readFile narFile
--       nixStoreNar <- getNixStoreDump "src"
--       HU.assertEqual
--         "src dir serializes the same between hnix-store and nix-store"
--         hnixNar
--         nixStoreNar
-- >>>>>>> Use streaming to consume and produce NARs

-- passes
test_streamLargeFileToNar :: TestTree
test_streamLargeFileToNar = HU.testCaseSteps "streamLargeFileToNar" $ \step -> do

  step "create test file"
  mkBigFile bigFileName
  -- BSL.writeFile narFileName =<< buildNarIO narEffectsIO bigFileName
  --
  step "create nar file"
  IO.withFile narFileName IO.WriteMode $ \h ->
    buildNarIO narEffectsIO bigFileName h

  step "assert bounded memory"
  assertBoundedMemory
  rmFiles
    where
      bigFileName = "bigFile.bin"
      narFileName = "bigFile.nar"
      rmFiles     = removeFile bigFileName >> removeFile narFileName


--------------------------------------------------------------------------------
test_streamManyFilesToNar :: TestTree
test_streamManyFilesToNar = HU.testCaseSteps "streamManyFilesToNar" $ \step ->
  Temp.withSystemTempDirectory "hnix-store" $ \baseDir -> do
    let

      packagePath = baseDir </> "package_with_many_files"
      packagePath' = baseDir </> "package_with_many_files2"
      narFilePath = packagePath <.> "nar"

      -- unused, see `step "check file exists"` bellow
      _rmFiles = try @SomeException @() $ do
        e <- doesPathExist narFilePath
        when e $ removeDirectoryRecursive narFilePath

      _run =  do
        filesPrecount <- countProcessFiles
        IO.withFile "hnar" IO.WriteMode $ \h ->
          buildNarIO narEffectsIO narFilePath h
        filesPostcount <- countProcessFiles
        pure $ filesPostcount - filesPrecount

    step "create test files"
    Directory.createDirectory packagePath
    flip mapM_ [0..1000] $ \i -> do
      BSL.writeFile (Printf.printf (packagePath </> "%08d") (i :: Int)) "hi\n"
      Concurrent.threadDelay 50

    filesPrecount <- countProcessFiles

    step "pack nar"
    IO.withFile narFilePath IO.WriteMode $ \h ->
      buildNarIO narEffectsIO packagePath h

    step "unpack nar"
    r <- IO.withFile narFilePath IO.ReadMode $ \h ->
      unpackNarIO narEffectsIO h packagePath'
    r `shouldBe` Right ()

    step "check constant file usage"
    filesPostcount <- countProcessFiles
    (filesPostcount - filesPrecount) `shouldSatisfy` (< 50)

    -- step "check file exists"
    -- e <- doesPathExist packagePath'
    -- e `shouldBe` True

    -- step "read the NAR back in"
    -- filesCreated <- run `finally` rmFiles
    -- filesCreated `shouldSatisfy` (< 50)



-- ****************  Utilities  ************************

-- | Generate the ground-truth encoding on the fly with
--   `nix-store --dump`, rather than generating fixtures
--   beforehand
filesystemNixStore :: String -> Nar -> IO ()
filesystemNixStore testErrorName n = do

  ver <- try (P.readProcess "nix-store" ["--version"] "")
  case ver of
    -- Left is not an error - testing machine simply doesn't have
    -- `nix-store` executable, so pass
    Left  (_ :: SomeException) -> print ("No nix-store on system" :: String)
    Right _ -> Temp.withSystemTempDirectory "hnix-store" $ \baseDir -> do

      let
        testFile    = baseDir </> "testfile"
        nixNarFile  = baseDir </> "nixstorenar.nar"
        hnixNarFile = baseDir </> "hnix.nar"

        assertExists f = do
          e <- doesPathExist f
          e `shouldBe` True

      -- stream nar contents to unpacked file(s)
      void $ withBytesAsHandle (runPut $ putNar n) $ \h ->
        unpackNarIO narEffectsIO h testFile

      assertExists testFile

      -- nix-store converts those files to nar
      getNixStoreDump testFile >>= BSL.writeFile nixNarFile
      assertExists nixNarFile

      -- hnix converts those files to nar
      IO.withFile hnixNarFile IO.WriteMode $ \h ->
        buildNarIO narEffectsIO testFile h
      assertExists hnixNarFile

      diffResult <- P.readProcess "diff" [nixNarFile, hnixNarFile] ""

      assertBoundedMemory
      HU.assertEqual testErrorName diffResult ""


-- | Assert that GHC uses less than 100M memory at peak
assertBoundedMemory :: IO ()
assertBoundedMemory = do
#ifdef BOUNDED_MEMORY
      bytes <- max_live_bytes <$> getRTSStats
      bytes < 100 * 1000 * 1000 `shouldBe` True
#else
      pure ()
#endif


packThenExtract
  :: String
     -- ^ Test name (will also be used for file name)
  -> (String -> IO ())
     -- ^ Action to create some files that we will
     --   pack into a NAR
  -> TestTree
packThenExtract testName setup =
  HU.testCaseSteps testName $ \step ->
  Temp.withSystemTempDirectory "hnix-store" $ \baseDir -> do
    setup baseDir

    let narFilePath = baseDir </> testName

    ver <- try (P.readProcess "nix-store" ["--version"] "")
    case ver of
      Left (_ :: SomeException) -> print ("No nix-store on system" :: String)
      Right _ -> do
        let
          nixNarFile  = narFilePath <> ".nix"
          hnixNarFile = narFilePath <> ".hnix"
          outputFile  = narFilePath <> ".out"

        step $ "Produce nix-store nar to " <> nixNarFile
        (_,_,_,handle) <- P.createProcess (P.shell $ "nix-store --dump " <> narFilePath <> " > " <> nixNarFile)
        void $ P.waitForProcess handle

        step $ "Build NAR from " <> narFilePath <> " to " <> hnixNarFile
        -- narBS <- buildNarIO narEffectsIO narFile
        IO.withFile hnixNarFile IO.WriteMode $ \h ->
          buildNarIO narEffectsIO narFilePath h

        -- BSL.writeFile hnixNarFile narBS

        step $ "Unpack NAR to " <> outputFile
        _narHandle <- IO.withFile nixNarFile IO.ReadMode $ \h ->
          unpackNarIO narEffectsIO h outputFile

        pure ()

-- | Count file descriptors owned by the current process
countProcessFiles :: IO Int
countProcessFiles = do
  pid <- Unix.getProcessID
  let fdDir = "/proc/" <> show pid <> "/fd"
  fds  <- P.readProcess "ls" [fdDir] ""
  pure $ length $ words fds


-- | Read the binary output of `nix-store --dump` for a filepath
getNixStoreDump :: String -> IO BSL.ByteString
getNixStoreDump fp = do
  (_,Just h, _, _) <- P.createProcess
                      (P.proc "nix-store" ["--dump", fp])
                      {P.std_out = P.CreatePipe}
  BSL.hGetContents h


-- * Several sample FSOs defined in Haskell, for use in encoding/decoding

-- | Simple regular text file with contents 'hi'
sampleRegular :: FileSystemObject
sampleRegular = Regular Nar.NonExecutable 3 "hi\n"

-- | Simple text file with some c code
sampleRegular' :: FileSystemObject
sampleRegular' = Regular Nar.NonExecutable (BSL.length str) str
  where str =
          "#include <stdio.h>\n\nint main(int argc, char *argv[]){ exit 0; }\n"

-- | Executable file
sampleExecutable :: FileSystemObject
sampleExecutable = Regular Nar.Executable (BSL.length str) str
  where str = "#!/bin/bash\n\ngcc -o hello hello.c\n"

-- | A simple symlink
sampleSymLink :: FileSystemObject
sampleSymLink = SymLink "hello.c"


-- | A directory that includes some of the above sample files
sampleDirectory :: FileSystemObject
sampleDirectory = Directory $ Map.fromList
  [(FilePathPart "hello.c", sampleRegular')
  ,(FilePathPart "build.sh", sampleExecutable)
  ,(FilePathPart "hi.c", sampleSymLink)
  ]

-- | A deeper directory tree with crossing links
sampleDirectory' :: FileSystemObject
sampleDirectory' = Directory $ Map.fromList [

    (FilePathPart "foo", Directory $ Map.fromList [
        (FilePathPart "foo.txt", Regular Nar.NonExecutable 8 "foo text")
      , (FilePathPart "tobar"  , SymLink "../bar/bar.txt")
      ])

  , (FilePathPart "bar", Directory $ Map.fromList [
        (FilePathPart "bar.txt", Regular Nar.NonExecutable 8 "bar text")
      , (FilePathPart "tofoo"  , SymLink "../foo/foo.txt")
      ])
  ]

sampleLargeFile :: Int64 -> FileSystemObject
sampleLargeFile fSize =
  Regular Nar.NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorem ipsum "))


sampleLargeFile' :: Int64 -> FileSystemObject
sampleLargeFile' fSize =
  Regular Nar.NonExecutable fSize (BSL.take fSize (BSL.cycle "Lorems ipsums "))

sampleLargeDir :: Int64 -> FileSystemObject
sampleLargeDir fSize = Directory $ Map.fromList $ [
    (FilePathPart "bf1", sampleLargeFile  fSize)
  , (FilePathPart "bf2", sampleLargeFile' fSize)
  ]
  <> [ (FilePathPart (BSC.pack $ 'f' : show n),
        Regular Nar.NonExecutable 10000 (BSL.take 10000 (BSL.cycle "hi ")))
     | n <- [1..100 :: Int]]
  <> [
  (FilePathPart "d", Directory $ Map.fromList
      [ (FilePathPart (BSC.pack $ "df" <> show n)
        , Regular Nar.NonExecutable 10000 (BSL.take 10000 (BSL.cycle "subhi ")))
      | n <- [1..100 :: Int]]
     )
  ]

--------------------------------------------------------------------------------
sampleDirWithManyFiles :: Int -> FileSystemObject
sampleDirWithManyFiles nFiles =
  Directory $ Map.fromList $ mkFile <$> take nFiles [0..]
  where
    mkFile :: Int -> (FilePathPart, FileSystemObject)
    mkFile i = (FilePathPart (BSC.pack (Printf.printf "%08d" i)),
                sampleRegular)

-- * For each sample above, feed it into `nix-store --dump`,
-- and base64 encode the resulting NAR binary. This lets us
-- check our Haskell NAR generator against `nix-store`

-- "hi" file turned to a NAR with `nix-store --dump`, Base64 encoded
sampleRegularBaseline :: BSL.ByteString
sampleRegularBaseline = B64.decodeLenient $ BSL.concat
  ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA"
  ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACAAAAA"
  ,"AAAABjb250ZW50cwMAAAAAAAAAaGkKAAAAAAABAAAAAAAAACkAA"
  ,"AAAAAAA"
  ]

sampleRegular'Baseline :: BSL.ByteString
sampleRegular'Baseline = B64.decodeLenient $ BSL.concat
  ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA"
  ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACAAAAA"
  ,"AAAABjb250ZW50c0AAAAAAAAAAI2luY2x1ZGUgPHN0ZGlvLmg+C"
  ,"gppbnQgbWFpbihpbnQgYXJnYywgY2hhciAqYXJndltdKXsgZXhp"
  ,"dCAwOyB9CgEAAAAAAAAAKQAAAAAAAAA="
  ]

sampleExecutableBaseline :: BSL.ByteString
sampleExecutableBaseline = B64.decodeLenient $ BSL.concat
  ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA"
  ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHJlZ3VsYXIACgAAAA"
  ,"AAAABleGVjdXRhYmxlAAAAAAAAAAAAAAAAAAAIAAAAAAAAAGNvb"
  ,"nRlbnRzIgAAAAAAAAAjIS9iaW4vYmFzaAoKZ2NjIC1vIGhlbGxv"
  ,"IGhlbGxvLmMKAAAAAAAAAQAAAAAAAAApAAAAAAAAAA=="
  ]

sampleSymLinkBaseline :: BSL.ByteString
sampleSymLinkBaseline = B64.decodeLenient $ BSL.concat
  ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA"
  ,"AAAQAAAAAAAAAdHlwZQAAAAAHAAAAAAAAAHN5bWxpbmsABgAAAA"
  ,"AAAAB0YXJnZXQAAAcAAAAAAAAAaGVsbG8uYwABAAAAAAAAACkAA"
  ,"AAAAAAA"
  ]

sampleDirectoryBaseline :: BSL.ByteString
sampleDirectoryBaseline = B64.decodeLenient $ BSL.concat
  ["DQAAAAAAAABuaXgtYXJjaGl2ZS0xAAAAAQAAAAAAAAAoAAAAAAA"
  ,"AAAQAAAAAAAAAdHlwZQAAAAAJAAAAAAAAAGRpcmVjdG9yeQAAAA"
  ,"AAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAAAAAAAAQAA"
  ,"AAAAAAAbmFtZQAAAAAIAAAAAAAAAGJ1aWxkLnNoBAAAAAAAAABu"
  ,"b2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAHR5cGUAAAA"
  ,"ABwAAAAAAAAByZWd1bGFyAAoAAAAAAAAAZXhlY3V0YWJsZQAAAA"
  ,"AAAAAAAAAAAAAACAAAAAAAAABjb250ZW50cyIAAAAAAAAAIyEvY"
  ,"mluL2Jhc2gKCmdjYyAtbyBoZWxsbyBoZWxsby5jCgAAAAAAAAEA"
  ,"AAAAAAAAKQAAAAAAAAABAAAAAAAAACkAAAAAAAAABQAAAAAAAAB"
  ,"lbnRyeQAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAG5hbWUAAA"
  ,"AABwAAAAAAAABoZWxsby5jAAQAAAAAAAAAbm9kZQAAAAABAAAAA"
  ,"AAAACgAAAAAAAAABAAAAAAAAAB0eXBlAAAAAAcAAAAAAAAAcmVn"
  ,"dWxhcgAIAAAAAAAAAGNvbnRlbnRzQAAAAAAAAAAjaW5jbHVkZSA"
  ,"8c3RkaW8uaD4KCmludCBtYWluKGludCBhcmdjLCBjaGFyICphcm"
  ,"d2W10peyBleGl0IDA7IH0KAQAAAAAAAAApAAAAAAAAAAEAAAAAA"
  ,"AAAKQAAAAAAAAAFAAAAAAAAAGVudHJ5AAAAAQAAAAAAAAAoAAAA"
  ,"AAAAAAQAAAAAAAAAbmFtZQAAAAAEAAAAAAAAAGhpLmMAAAAABAA"
  ,"AAAAAAABub2RlAAAAAAEAAAAAAAAAKAAAAAAAAAAEAAAAAAAAAH"
  ,"R5cGUAAAAABwAAAAAAAABzeW1saW5rAAYAAAAAAAAAdGFyZ2V0A"
  ,"AAHAAAAAAAAAGhlbGxvLmMAAQAAAAAAAAApAAAAAAAAAAEAAAAA"
  ,"AAAAKQAAAAAAAAABAAAAAAAAACkAAAAAAAAA"
  ]


-- | Control testcase sizes (bytes) by env variable
getBigFileSize :: IO Int64
getBigFileSize = fromMaybe 5000000 . readMaybe <$> (getEnv "HNIX_BIG_FILE_SIZE" <|> pure "")


-- | Add a link to a FileSystemObject. This is useful
--   when creating Arbitrary FileSystemObjects. It
--   isn't implemented yet
mkLink ::
     FilePath -- ^ Target
  -> FilePath -- ^ Link
  -> FileSystemObject -- ^ FileSystemObject to add link to
  -> FileSystemObject
mkLink = undefined -- TODO

mkBigFile :: FilePath -> IO ()
mkBigFile path = do
  fsize <- getBigFileSize
  BSL.writeFile path (BSL.take fsize $ BSL.cycle "Lorem ipsum")


-- | Construct FilePathPart from Text by checking that there
--   are no '/' or '\\NUL' characters
filePathPart :: BSC.ByteString -> Maybe FilePathPart
filePathPart p = case BSC.any (`elem` ['/', '\NUL']) p of
  False -> Just $ FilePathPart p
  True  -> Nothing

data Nar = Nar { narFile :: FileSystemObject }
    deriving (Eq, Show)

-- | A FileSystemObject (FSO) is an anonymous entity that can be NAR archived
data FileSystemObject =
    Regular Nar.IsExecutable Int64 BSL.ByteString
    -- ^ Reguar file, with its executable state, size (bytes) and contents
  | Directory (Map.Map FilePathPart FileSystemObject)
    -- ^ Directory with mapping of filenames to sub-FSOs
  | SymLink T.Text
    -- ^ Symbolic link target
  deriving (Eq, Show)

-- | A valid filename or directory name
newtype FilePathPart = FilePathPart { unFilePathPart :: BSC.ByteString }
  deriving (Eq, Ord, Show)


instance Arbitrary Nar where
  arbitrary = Nar <$> resize 10 arbitrary

instance Arbitrary FileSystemObject where
  -- To build an arbitrary Nar,
  arbitrary = do
    n <- getSize
    if n < 2
      then arbFile
      else arbDirectory n

      where

        arbFile :: Gen FileSystemObject
        arbFile = do
          Positive fSize <- arbitrary
          Regular
            <$> elements [Nar.NonExecutable, Nar.Executable]
            <*> pure (fromIntegral fSize)
            <*> oneof  [
                  fmap (BSL.take fSize . BSL.cycle . BSL.pack . getNonEmpty) arbitrary , -- Binary File
                  fmap (BSL.take fSize . BSL.cycle . BSLC.pack . getNonEmpty) arbitrary   -- ASCII  File
                  ]

        arbName :: Gen FilePathPart
        arbName = fmap (FilePathPart . BS.pack . fmap (fromIntegral . fromEnum)) $ do
          Positive n <- arbitrary
          replicateM n (elements $ ['a'..'z'] <> ['0'..'9'])

        arbDirectory :: Int -> Gen FileSystemObject
        arbDirectory n = fmap (Directory . Map.fromList) $ replicateM n $ do
          nm <- arbName
          f <- oneof [arbFile, arbDirectory (n `div` 2)]
          pure (nm,f)

------------------------------------------------------------------------------
-- | Serialize Nar to lazy ByteString
putNar :: Nar -> Put
putNar (Nar file) = header <> parens (putFile file)
    where

        header   = str "nix-archive-1"

        putFile (Regular isExec fSize contents) =
               strs ["type", "regular"]
            >> (if isExec == Nar.Executable
               then strs ["executable", ""]
               else pure ())
            >> putContents fSize contents

        putFile (SymLink target) =
               strs ["type", "symlink", "target", BSL.fromStrict $ E.encodeUtf8 target]

        -- toList sorts the entries by FilePathPart before serializing
        putFile (Directory entries) =
               strs ["type", "directory"]
            <> mapM_ putEntry (Map.toList entries)

        putEntry (FilePathPart name, fso) = do
            str "entry"
            parens $ do
              str "name"
              str (BSL.fromStrict name)
              str "node"
              parens (putFile fso)

        parens m = str "(" >> m >> str ")"

        -- Do not use this for file contents
        str :: BSL.ByteString -> Put
        str t = let len = BSL.length t
            in int len <> pad len t

        putContents :: Int64 -> BSL.ByteString -> Put
        putContents fSize bs = str "contents" <> int fSize <> (pad fSize bs)

        int :: Integral a => a -> Put
        int n = putInt64le $ fromIntegral n

        pad :: Int64 -> BSL.ByteString -> Put
        pad strSize bs = do
          putLazyByteString bs
          putLazyByteString (BSL.replicate (padLen strSize) 0)

        strs :: [BSL.ByteString] -> Put
        strs = mapM_ str

-- | Distance to the next multiple of 8
padLen :: Int64 -> Int64
padLen n = (8 - n) `mod` 8


------------------------------------------------------------------------------
-- | Deserialize a Nar from lazy ByteString
getNar :: Get Nar
getNar = fmap Nar $ header >> parens getFile
    where

      header   = assertStr "nix-archive-1"

      -- Fetch a FileSystemObject
      getFile = getRegularFile <|> getDirectory <|> getSymLink

      getRegularFile = do
          assertStr_ "type"
          assertStr_ "regular"
          mExecutable <- optional $ Nar.Executable <$ (assertStr "executable"
                                                       >> assertStr "")
          assertStr_ "contents"
          (fSize, contents) <- sizedStr
          pure $ Regular (fromMaybe Nar.NonExecutable mExecutable) fSize contents

      getDirectory = do
          assertStr_ "type"
          assertStr_ "directory"
          fs <- many getEntry
          pure $ Directory (Map.fromList fs)

      getSymLink = do
          assertStr_ "type"
          assertStr_ "symlink"
          assertStr_ "target"
          fmap (SymLink . E.decodeUtf8 . BSL.toStrict) str

      getEntry = do
          assertStr_ "entry"
          parens $ do
              assertStr_ "name"
              name <- E.decodeUtf8 . BSL.toStrict <$> str
              assertStr_ "node"
              file <- parens getFile
              maybe (fail $ "Bad FilePathPart: " <> show name)
                    (pure . (,file))
                    (filePathPart $ E.encodeUtf8 name)

      -- Fetch a length-prefixed, null-padded string
      str = fmap snd sizedStr

      sizedStr = do
          n <- getInt64le
          s <- getLazyByteString n
          _ <- getByteString . fromIntegral $ padLen n
          pure (n,s)

      parens m = assertStr "(" *> m <* assertStr ")"

      assertStr_ = void . assertStr
      assertStr s = do
          s' <- str
          if s == s'
              then pure s
              else fail "No"