3 files changed, 34 insertions(+), 16 deletions(-)

M src/Command/Pin.hs
M src/Util.hs
M src/Util/Nix.hs

@@ 11,7 11,7 @@ import Util.Nix
 
 import Options.Applicative
 
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, maybeToList)
 import Data.Foldable (traverse_)
 import Control.Monad (when, unless, forM_, void)
 


@@ 28,6 28,7 @@ import System.Directory
   , getModificationTime, setModificationTime
   , removeDirectoryRecursive
   , canonicalizePath
+  , pathIsSymbolicLink
   , getSymbolicLinkTarget )
 
 import System.Process (readProcess)


@@ 100,10 101,19 @@ processFile baseCtx pinCtx source = do
       target = gcrootsDir pinCtx </> hashed
   fileMod <- getModificationTime source
   when (fileMod > lastExecution pinCtx) $ do
-    contents <- LBS.readFile source
-    let storePaths = mapMaybe (lookupHash $ storeContents pinCtx)
-                   $ nubOrd
-                   $ findStoreHashes (storeDir baseCtx) contents
+    isLink <- pathIsSymbolicLink source
+    storePaths <- if isLink
+      then do
+        linkTarget <- getSymbolicLinkTarget source
+        let maybeHash = hashFromPath (storeDir baseCtx) linkTarget
+            maybeStorePath = maybeHash >>= lookupHash (storeContents pinCtx)
+        pure $ maybeToList maybeStorePath
+      else do
+        -- TODO check that it's a normal file (could be a socket or other special file)
+        contents <- LBS.readFile source
+        pure $ mapMaybe (lookupHash $ storeContents pinCtx)
+             $ nubOrd
+             $ findStoreHashes (storeDir baseCtx) contents
     unless (null storePaths) $ do
       createDirectoryIfMissing True $ target </> "roots"
       createFileLink source $ target </> "source"

@@ 2,23 2,19 @@ module Util where
 
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Foldable (traverse_)
-import Control.Monad (unless)
 import System.FilePath ((</>))
-import System.Directory (doesDirectoryExist, pathIsSymbolicLink, listDirectory)
+import System.Directory (doesDirectoryExist, listDirectory)
 import qualified Data.ByteString as BS
 import Numeric (showHex)
 
 traverseFileTree :: MonadIO m => (FilePath -> m ()) -> FilePath -> m ()
 traverseFileTree f path = do
   isDir <- liftIO $ doesDirectoryExist path
-  isLink <- liftIO $ pathIsSymbolicLink path
-  unless isLink $ -- TODO: decide what to do with *file* links
-    if isDir
-    then do
-      ls <- liftIO $ listDirectory path
-      traverseFileTrees f $ (path</>) <$> ls
-    -- TODO check that it's a file (could be a socket!)
-    else f path
+  if isDir
+  then do
+    ls <- liftIO $ listDirectory path
+    traverseFileTrees f $ (path</>) <$> ls
+  else f path
 
 traverseFileTrees :: MonadIO m => (FilePath -> m ()) -> [FilePath] -> m ()
 traverseFileTrees f = traverse_ $ traverseFileTree f

@@ 4,6 4,8 @@ module Util.Nix where
 import qualified Data.Map as Map
 import Data.Map (Map)
 
+import Data.List (stripPrefix)
+
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as BSC8
 


@@ 11,13 13,15 @@ import Data.String (fromString)
 
 import Data.ByteString.Lazy.Search (split)
 
-import System.FilePath ((</>), addTrailingPathSeparator)
+import System.FilePath ((</>), addTrailingPathSeparator, isPathSeparator)
 import System.Directory (listDirectory)
 
 type Hash = String
 
 type StoreContents = Map Hash FilePath
 
+-- MAYBE find bare hashes too, even without the store prefix. what does nix do?
+
 isHash :: String -> Bool
 isHash str = length str == 32
           && all isHashCharacter str


@@ 31,6 35,14 @@ findStoreHashes storePath bs =
   filter isHash $ take 32 . BSC8.unpack <$> split storePrefix bs
   where storePrefix = fromString $ addTrailingPathSeparator storePath
 
+hashFromPath :: FilePath -> FilePath -> Maybe Hash
+hashFromPath storePath path = do
+  afterPrefix <- stripPrefix storePath path
+  let hashCandidate = take 32 $ dropWhile isPathSeparator afterPrefix
+  if isHash hashCandidate
+  then pure hashCandidate
+  else Nothing
+
 lookupHash :: StoreContents -> Hash -> Maybe (Hash, FilePath)
 lookupHash storeContents hash =
   (hash,) <$> Map.lookup hash storeContents