Implement case-insensitive hack

Author: sandydoo

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
-            (Nar.NarEffects m)
-            m
-          )
+          (Reader.ReaderT (ParserEnv 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 =
+  parseEntryOrFinish :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> NarParser m ()
+  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 = do
+  parseEntry :: (IO.MonadIO m, Fail.MonadFail m) => FilePath -> NarParser m ()
+  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