Merge pull request #218 from sandydoo/fix/213

Handle case conflicts on case-insensitive filesystems

hnix-store-core/ChangeLog.md

@@ -7,6 +7,13 @@
       have a stand-alone `StoreDir` type instead to be used instead of `FilePath`
       when store root directory is needed as a context.
 
+* Additional:
+    * [(link)](https://github.com/haskell-nix/hnix-store/pull/218) NAR encoding and decoding now supports case-insensitive filesystems.
+      * The "case hack" replicates the behavior of the `use-case-hack` option in Nix, which adds a suffix to conflicting filenames.
+        This feature is enabled by default on macOS (darwin).
+      * `data NarOptions` has been added to configure NAR encoding and decoding. The `optUseCaseHack` field can be used to enable or disable the case hack.
+      * New `streamNarIOWithOptions` and `runParserWithOptions` functions have been added to `System.Nix.Nar` to support the new configurable options.
+
 ## [0.6.1.0](https://github.com/haskell-nix/hnix-store/compare/core-0.6.0.0...core-0.6.1.0) 2023-01-02
 
 * Fixed:

hnix-store-core/hnix-store-core.cabal

@@ -40,6 +40,7 @@ library
     , System.Nix.Internal.Nar.Parser
     , System.Nix.Internal.Nar.Streamer
     , System.Nix.Internal.Nar.Effects
+    , System.Nix.Internal.Nar.Options
     , System.Nix.Internal.Signature
     , System.Nix.Internal.StorePath
     , System.Nix.Nar
@@ -55,6 +56,7 @@ library
     , base16-bytestring
     , base64-bytestring
     , bytestring
+    , case-insensitive
     , cereal
     , containers
     -- Required for cryptonite low-level type convertion

hnix-store-core/src/System/Nix/Internal/Nar/Options.hs

@@ -0,0 +1,28 @@
+module System.Nix.Internal.Nar.Options 
+  ( NarOptions(..)
+  , defaultNarOptions
+  , caseHackSuffix
+  ) where
+
+import qualified System.Info
+
+-- | Options for configuring how NAR files are encoded and decoded.
+data NarOptions = NarOptions {
+  optUseCaseHack :: Bool
+  -- ^ Whether to enable a case hack to support case-insensitive filesystems.
+  -- Equivalent to the 'use-case-hack' option in the Nix client.
+  --
+  -- The case hack rewrites file names to avoid collisions on case-insensitive file systems, e.g. APFS and HFS+ on macOS.
+  -- Enabled by default on macOS (Darwin).
+}
+
+defaultNarOptions :: NarOptions
+defaultNarOptions = NarOptions {
+  optUseCaseHack =
+    if System.Info.os == "darwin"
+      then True
+      else False
+}
+
+caseHackSuffix :: Text
+caseHackSuffix = "~nix~case~hack~"

hnix-store-core/src/System/Nix/Internal/Nar/Parser.hs

@@ -7,6 +7,7 @@
 
 module System.Nix.Internal.Nar.Parser
   ( runParser
+  , runParserWithOptions
   , parseNar
   , testParser
   , testParser'
@@ -26,6 +27,8 @@ import qualified Control.Monad.State             as State
 import qualified Control.Monad.Trans             as Trans
 import qualified Control.Monad.Trans.Control     as Base
 import qualified Data.ByteString                 as Bytes
+import qualified Data.CaseInsensitive            as CI
+import qualified Data.HashMap.Strict             as HashMap
 import qualified Data.List                       as List
 import qualified Data.Map                        as Map
 import qualified Data.Serialize                  as Serialize
@@ -35,6 +38,7 @@ import           System.FilePath                 as FilePath
 import qualified System.IO                       as IO
 
 import qualified System.Nix.Internal.Nar.Effects as Nar
+import qualified System.Nix.Internal.Nar.Options as Nar
 
 
 -- | NarParser is a monad for parsing a Nar file as a byte stream
@@ -48,19 +52,34 @@ newtype NarParser m a = NarParser
         ParserState
         (Except.ExceptT
           String
-          (Reader.ReaderT
+          (Reader.ReaderT (ParserEnv m) m)
-            (Nar.NarEffects m)
-            m
-          )
         )
         a
   }
   deriving ( Functor, Applicative, Monad, Fail.MonadFail
            , Trans.MonadIO, State.MonadState ParserState
            , Except.MonadError String
-           , Reader.MonadReader (Nar.NarEffects m)
+           , Reader.MonadReader (ParserEnv m)
            )
 
+
+data ParserEnv m = ParserEnv
+  { envNarEffects :: Nar.NarEffects m
+  , envNarOptions :: Nar.NarOptions
+  }
+
+
+getNarEffects :: Monad m => NarParser m (Nar.NarEffects m)
+getNarEffects = fmap envNarEffects ask
+
+
+getNarEffect :: Monad m => (Nar.NarEffects m -> a) -> NarParser m a
+getNarEffect eff = fmap eff getNarEffects
+
+
+getNarOptions :: Monad m => NarParser m Nar.NarOptions
+getNarOptions = fmap envNarOptions ask
+
 -- | Run a @NarParser@ over a byte stream
 --   This is suitable for testing the top-level NAR parser, or any of the
 --   smaller utilities parsers, if you have bytes appropriate for them
@@ -77,9 +96,26 @@ runParser
   -> FilePath
      -- ^ The root file system object to be created by the NAR
   -> m (Either String a)
-runParser effs (NarParser action) h target = do
+runParser effs parser h target = do
+  runParserWithOptions Nar.defaultNarOptions effs parser h target
+
+runParserWithOptions
+  :: forall m a
+   . (IO.MonadIO m, Base.MonadBaseControl IO m)
+  => Nar.NarOptions
+  -> Nar.NarEffects m
+     -- ^ Provide the effects set, usually @narEffectsIO@
+  -> NarParser m a
+     -- ^ A parser to run, such as @parseNar@
+  -> IO.Handle
+     -- ^ A handle the stream containg the NAR. It should already be
+     --   open and in @ReadMode@
+  -> FilePath
+     -- ^ The root file system object to be created by the NAR
+  -> m (Either String a)
+runParserWithOptions opts effs (NarParser action) h target = do
   unpackResult <-
-    runReaderT (runExceptT $ State.evalStateT action state0) effs
+    runReaderT (runExceptT $ State.evalStateT action state0) (ParserEnv effs opts)
       `Exception.Lifted.catch` exceptionHandler
   when (isLeft unpackResult) cleanup
   pure unpackResult
@@ -92,6 +128,7 @@ runParser effs (NarParser action) h target = do
       , handle         = h
       , directoryStack = [target]
       , links          = []
+      , filePaths      = HashMap.empty
       }
 
   exceptionHandler :: Exception.Lifted.SomeException -> m (Either String a)
@@ -126,6 +163,9 @@ data ParserState = ParserState
   , links          :: [LinkInfo]
     -- ^ Unlike with files and directories, we collect symlinks
     --   from the NAR on
+  , filePaths      :: HashMap.HashMap (CI.CI FilePath) Int
+    -- ^ A map of case-insensitive files paths to the number of collisions encountered.
+    -- See @Nar.NarOptions.optUseCaseHack@ for details.
   }
 
 
@@ -230,11 +270,11 @@ parseFile = do
           pure $ Just chunk
 
   target     <- currentFile
-  streamFile <- asks Nar.narStreamFile
+  streamFile <- getNarEffect Nar.narStreamFile
   lift (streamFile target getChunk)
 
   when (s == "executable") $ do
-    effs :: Nar.NarEffects m <- ask
+    effs :: Nar.NarEffects m <- getNarEffects
     lift $ do
       p <- Nar.narGetPerms effs target
       Nar.narSetPerms effs target (p { Directory.executable = True })
@@ -246,34 +286,50 @@ parseFile = do
 --   handles for target files longer than needed
 parseDirectory :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
 parseDirectory = do
-  createDirectory <- asks Nar.narCreateDir
+  createDirectory <- getNarEffect Nar.narCreateDir
   target          <- currentFile
   lift $ createDirectory target
-  parseEntryOrFinish
+  parseEntryOrFinish target
 
  where
 
-  parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
+  parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> NarParser m ()
-  parseEntryOrFinish =
+  parseEntryOrFinish path =
     -- If we reach a ")", we finished the directory's entries, and we have
     -- to put ")" back into the stream, because the outer call to @parens@
     -- expects to consume it.
     -- Otherwise, parse an entry as a fresh file system object
     matchStr
       [ ( ")"   , pushStr ")" )
-      , ("entry", parseEntry  )
+      , ("entry", parseEntry path  )
       ]
 
-  parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => NarParser m ()
+  parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> NarParser m ()
-  parseEntry = do
+  parseEntry path = do
+    opts <- getNarOptions
     parens $ do
       expectStr "name"
-      fName <- parseStr
+      fName <-
+        if Nar.optUseCaseHack opts then
+          addCaseHack path =<< parseStr
+        else
+          parseStr
       pushFileName (toString fName)
       expectStr "node"
       parens parseFSO
       popFileName
-    parseEntryOrFinish
+    parseEntryOrFinish path
+
+  addCaseHack :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> Text -> NarParser m Text
+  addCaseHack path fName = do
+    let key = path </> Text.unpack fName
+    recordFilePath key
+    conflictCount <- getFilePathConflictCount key
+    pure $
+      if conflictCount > 0 then
+        fName <> Nar.caseHackSuffix <> show conflictCount
+      else
+        fName
 
 
 
@@ -373,7 +429,7 @@ parens act = do
 --   (Targets must be created before the links that target them)
 createLinks :: IO.MonadIO m => NarParser m ()
 createLinks = do
-  createLink  <- asks Nar.narCreateLink
+  createLink  <- getNarEffect Nar.narCreateLink
   allLinks    <- State.gets links
   sortedLinks <- IO.liftIO $ sortLinksIO allLinks
   forM_ sortedLinks $ \li -> do
@@ -473,6 +529,16 @@ pushLink :: Monad m => LinkInfo -> NarParser m ()
 pushLink linkInfo = State.modify (\s -> s { links = linkInfo : links s })
 
 
+-- | Add a file path to the collection of encountered file paths
+recordFilePath :: Monad m => FilePath -> NarParser m ()
+recordFilePath fPath =
+  State.modify (\s -> s { filePaths = HashMap.insertWith (\_ v -> v + 1) (CI.mk fPath) 0 (filePaths s) })
+
+getFilePathConflictCount :: Monad m => FilePath -> NarParser m Int
+getFilePathConflictCount fPath = do
+  fileMap <- State.gets filePaths
+  pure $ HashMap.findWithDefault 0 (CI.mk fPath) fileMap
+
 ------------------------------------------------------------------------------
 -- * Utilities
 

hnix-store-core/src/System/Nix/Internal/Nar/Streamer.hs

@@ -7,6 +7,7 @@ module System.Nix.Internal.Nar.Streamer
   , dumpString
   , dumpPath
   , streamNarIO
+  , streamNarIOWithOptions
   , IsExecutable(..)
   )
 where
@@ -15,12 +16,13 @@ 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.Serialize                  as Serial
-import qualified Data.Text                       as T (pack)
+import qualified Data.Text                       as T (pack, breakOn)
 import qualified Data.Text.Encoding              as TE (encodeUtf8)
 import qualified System.Directory                as Directory
 import           System.FilePath                 ((</>))
 
 import qualified System.Nix.Internal.Nar.Effects as Nar
+import qualified System.Nix.Internal.Nar.Options as Nar
 
 
 -- | NarSource
@@ -56,7 +58,11 @@ dumpPath = streamNarIO Nar.narEffectsIO
 --   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 effs basePath yield = do
+streamNarIO effs basePath yield =
+  streamNarIOWithOptions Nar.defaultNarOptions effs basePath yield
+
+streamNarIOWithOptions :: forall m . IO.MonadIO m => Nar.NarOptions -> Nar.NarEffects IO -> FilePath -> NarSource m
+streamNarIOWithOptions opts effs basePath yield = do
   yield $ str "nix-archive-1"
   parens $ go basePath
  where
@@ -76,7 +82,12 @@ streamNarIO effs basePath yield = do
             yield $ str "entry"
             parens $ do
               let fullName = path </> f
-              yield $ strs ["name", filePathToBS f, "node"]
+              let serializedPath =
+                    if Nar.optUseCaseHack opts then
+                      filePathToBSWithCaseHack f
+                    else
+                      filePathToBS f
+              yield $ strs ["name", serializedPath, "node"]
               parens $ go fullName
         else do
           isExec <- IO.liftIO $ isExecutable effs path
@@ -87,8 +98,6 @@ streamNarIO effs basePath yield = do
           yield $ int fSize
           yieldFile path fSize
 
-  filePathToBS = TE.encodeUtf8 . T.pack
-
   parens act = do
     yield $ str "("
     r <- act
@@ -130,3 +139,12 @@ padBS strSize bs = bs <> Bytes.replicate (padLen strSize) 0
 
 strs :: [ByteString] -> ByteString
 strs xs = Bytes.concat $ str <$> xs
+
+filePathToBS :: FilePath -> ByteString
+filePathToBS = TE.encodeUtf8 . T.pack
+
+filePathToBSWithCaseHack :: FilePath -> ByteString
+filePathToBSWithCaseHack = TE.encodeUtf8 . undoCaseHack . T.pack
+
+undoCaseHack :: Text -> Text
+undoCaseHack = fst . T.breakOn Nar.caseHackSuffix

hnix-store-core/src/System/Nix/Nar.hs

@@ -23,9 +23,14 @@ module System.Nix.Nar
   , Nar.NarEffects(..)
   , Nar.narEffectsIO
 
+  , Nar.NarOptions(..)
+  , Nar.defaultNarOptions
+
   -- * Internal
   , Nar.streamNarIO
+  , Nar.streamNarIOWithOptions
   , Nar.runParser
+  , Nar.runParserWithOptions
   , Nar.dumpString
   , Nar.dumpPath
 
@@ -39,6 +44,7 @@ import qualified Data.ByteString                   as BS
 import qualified System.IO                         as IO
 
 import qualified System.Nix.Internal.Nar.Effects   as Nar
+import qualified System.Nix.Internal.Nar.Options   as Nar
 import qualified System.Nix.Internal.Nar.Parser    as Nar
 import qualified System.Nix.Internal.Nar.Streamer  as Nar
 

hnix-store-core/tests/NarFormat.hs

@@ -5,6 +5,7 @@ module NarFormat where
 
 import qualified Control.Concurrent               as Concurrent
 import           Control.Exception                (try)
+import           Data.Binary                      (Binary(..), decodeFile)
 import           Data.Binary.Get                  (Get, getByteString,
                                                    getInt64le,
                                                    getLazyByteString, runGet)
@@ -100,6 +101,10 @@ spec_narEncoding = do
     it "roundtrips directory" $ do
       roundTrip "sampleDirectory" (Nar sampleDirectory)
 
+    it "roundtrips case conflicts" $ do
+      nar <- decodeFile "tests/fixtures/case-conflict.nar"
+      roundTrip "caseConflict" nar
+
   describe "matches-nix-store fixture" $ do
     it "matches regular" $ do
       encEqualsNixStore (Nar sampleRegular) sampleRegularBaseline
@@ -115,6 +120,7 @@ spec_narEncoding = do
 
     it "matches directory" $ do
       encEqualsNixStore (Nar sampleDirectory) sampleDirectoryBaseline
+
     it "matches symlink to directory" $ do
       encEqualsNixStore (Nar sampleLinkToDirectory) sampleLinkToDirectoryBaseline
 
@@ -578,7 +584,7 @@ filePathPart :: BSC.ByteString -> Maybe FilePathPart
 filePathPart p = if BSC.any (`elem` ['/', '\NUL']) p then Nothing else Just $ FilePathPart p
 
 newtype Nar = Nar { narFile :: FileSystemObject }
-    deriving (Eq, Show)
+    deriving (Eq, Show, Generic)
 
 -- | A FileSystemObject (FSO) is an anonymous entity that can be NAR archived
 data FileSystemObject =
@@ -594,6 +600,9 @@ data FileSystemObject =
 newtype FilePathPart = FilePathPart { unFilePathPart :: BSC.ByteString }
   deriving (Eq, Ord, Show)
 
+instance Binary Nar where
+  get = getNar
+  put = putNar
 
 instance Arbitrary Nar where
   arbitrary = Nar <$> resize 10 arbitrary

hnix-store-core/tests/fixtures/.gitignore

@@ -0,0 +1,3 @@
+*
+!*.nar
+!*.*

hnix-store-core/tests/fixtures/generate-fixtures.sh

@@ -0,0 +1,8 @@
+#!/usr/bin/env bash
+
+# Generate a NAR file with case conflicts in the file names.
+mkdir -p case-conflict/bar
+touch case-conflict/{Foo.txt,foo.txt,Baz.txt,bar/baz.txt}
+
+storePath=$(nix-store --add ./case-conflict)
+nix-store --dump $storePath > case-conflict.nar