├── .gitignore ├── Main.hs ├── Makefile ├── default.nix └── hello-2.10.nar /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | Main 4 | TAGS 5 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-do-bind -Wall #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | module Main where 8 | 9 | import Control.Applicative 10 | import Control.Arrow 11 | import Control.Concurrent.MVar 12 | import Control.Exception 13 | import Control.Lens 14 | import Control.Monad 15 | import Data.Binary 16 | import Data.Binary.Get 17 | import qualified Data.ByteString as BS 18 | import qualified Data.ByteString.Lazy as LBS 19 | import qualified Data.ByteString.Lazy.Char8 as LBSC 20 | import Data.Foldable 21 | import Data.Hashable 22 | import qualified Data.HashMap.Lazy as Map 23 | import Data.Int 24 | import Data.List 25 | import Data.Maybe 26 | import Data.Monoid 27 | import Data.Time 28 | import Data.Time.Clock.POSIX 29 | import Data.Word 30 | import Debug.Trace 31 | import GHC.Generics (Generic) 32 | import System.Directory 33 | import System.Environment 34 | import System.Fuse 35 | import System.IO.Posix.MMap.Lazy 36 | import System.Posix.Files 37 | import System.Posix.Types 38 | 39 | type Map = Map.HashMap 40 | 41 | type Offset = Int 42 | 43 | type Size = Int 44 | 45 | data MMap a = MMapPure !a 46 | | MMapModify !Offset !Size 47 | !(LBS.ByteString -> (Maybe LBS.ByteString, a)) 48 | 49 | instance Functor MMap where 50 | fmap f (MMapPure x) = MMapPure $ f x 51 | fmap f (MMapModify o s cb) = MMapModify o s $ second f . cb 52 | 53 | type Path = LBS.ByteString 54 | type Name = LBS.ByteString 55 | 56 | data NARNode = NFile { _isExecutable :: !Bool 57 | , _contents :: LBS.ByteString } 58 | | NSymlink { _target :: Path } 59 | | NDirectory { _children :: Map Name NARNode } 60 | deriving (Eq, Read, Generic) 61 | 62 | newtype NARFile = NARFile { _root :: NARNode } 63 | deriving (Eq, Show, Read, Generic) 64 | 65 | data RuntimeState = RuntimeState { _dataDir :: FilePath 66 | , _narCache :: MVar (Map String NARFile) } 67 | deriving () 68 | 69 | data HT = HT { _handle :: NARNode } 70 | 71 | choice :: (Alternative m) => [m a] -> m a 72 | choice = foldl' (<|>) empty 73 | 74 | whenFail :: (Monad m) => String -> Bool -> m () 75 | whenFail str True = fail str 76 | whenFail _ False = return () 77 | 78 | padNum :: (Integral n) => n -> n -> n 79 | padNum m x = if r > 0 then x + m - r else x 80 | where 81 | r = x `mod` m 82 | 83 | getLBS :: Integral i => i -> Get LBS.ByteString 84 | getLBS = getLazyByteString . fromIntegral 85 | 86 | narStringG :: Get (Word64, LBS.ByteString) 87 | narStringG = do 88 | len <- getWord64le 89 | if len == 0 90 | then return (8, "") 91 | else do str <- getLBS len 92 | let 93 | padded = padNum 8 len 94 | expectedZeros = fromIntegral $ padded - len 95 | zeros <- replicateM expectedZeros getWord8 96 | whenFail "padding was not filled with zeroes" 97 | $ zeros /= replicate expectedZeros 0 98 | return (8 + padded, str) 99 | 100 | match :: (Eq a, Show a) => Get a -> a -> Get () 101 | match g bs = do 102 | input <- g 103 | whenFail ("match failed: " <> show input <> " != " <> show bs) (input /= bs) 104 | 105 | matchNSG :: LBS.ByteString -> Get () 106 | matchNSG = match (snd <$> narStringG) 107 | 108 | matchNSGPair :: LBS.ByteString -> LBS.ByteString -> Get () 109 | matchNSGPair bs1 bs2 = matchNSG bs1 >> matchNSG bs2 110 | 111 | tryGet :: Get a -> Get (Maybe a) 112 | tryGet g = (Just <$> g) <|> return Nothing 113 | 114 | execGet :: Get Bool 115 | execGet = isJust <$> tryGet (matchNSGPair "executable" "") 116 | 117 | contentsGet :: Get LBS.ByteString 118 | contentsGet = matchNSG "contents" >> snd <$> narStringG 119 | 120 | entryGet :: Get (Name, NARNode) 121 | entryGet = do matchNSG "entry" 122 | matchNSG "(" 123 | matchNSG "name" 124 | name <- snd <$> narStringG 125 | matchNSG "node" 126 | node <- get 127 | matchNSG ")" 128 | return $ trace "entry thunked" (name, node) 129 | 130 | regularGet :: Get NARNode 131 | regularGet = trace "got file" $ NFile <$> execGet <*> contentsGet 132 | 133 | symlinkGet :: Get NARNode 134 | symlinkGet = matchNSG "target" >> NSymlink . snd <$> narStringG 135 | 136 | directoryGet :: Get NARNode 137 | directoryGet = NDirectory . Map.fromList <$> many entryGet 138 | 139 | magicGet :: Get () 140 | magicGet = do (_, magic) <- narStringG 141 | when (magic /= "nix-archive-1") $ fail "magic number was wrong" 142 | 143 | data Foo = Foo { getFoo :: [(Word64, LBS.ByteString)] } 144 | deriving (Eq, Generic) 145 | 146 | instance Show Foo where 147 | show = concatMap ((<> "\n") . showX) . getFoo 148 | where 149 | showB bs = if (LBS.length bs > 1024) || isJust (LBS.findIndex (== 0) bs) 150 | then "\ESC[31m\ESC[0m" 151 | else show bs 152 | showX (l, bs) = "{ length = " <> show l <> ", bs = " <> showB bs <> " }" 153 | 154 | instance Show NARNode where 155 | show = go 2 156 | where 157 | go :: Int -> NARNode -> String 158 | go _ (NFile exec contents) = (if exec then "executable " else "") <> "FILE " <> showB contents <> "\n" 159 | go i (NDirectory entries) = "{\n" <> (mconcat $ intersperse "" $ toList $ Map.mapWithKey showX entries) <> indent (i-2) <> "}\n" 160 | where 161 | showX name node = indent i <> "dir entry " <> show name <> "=" <> go (i+2) node 162 | go _ (NSymlink l) = "symlink to " <> show l <> "\n" 163 | indent :: Int -> String 164 | indent i = if i < 1 then "" else ' ' : indent (i - 1) 165 | showB bs = if (LBS.length bs > 1024) || isJust (LBS.findIndex (== 0) bs) 166 | then "\ESC[31m\ESC[0m" 167 | else show bs 168 | 169 | showDot :: NARFile -> String 170 | showDot (NARFile node) = "digraph test123 {\n" <> go "" "root" node <> "}" 171 | where 172 | go :: String -> String -> NARNode -> String 173 | go parent name (NFile exec _) = quote parent <> " -> " <> quote (name <> (if exec then " (executable)" else "")) <> ";\n" 174 | go parent name (NDirectory entries) = quote parent <> " -> " <> quote name <> ";\n" <> (mconcat $ intersperse "" $ toList $ Map.mapWithKey showX entries) 175 | where 176 | showX entry_name node2 = go name (LBSC.unpack entry_name) node2 177 | go parent name (NSymlink l) = quote parent <> " -> " <> quote name <> ";\n" <> quote name <> " -> " <> quote (LBSC.unpack l) <> " [color=blue];\n" 178 | quote x = "\"" <> x <> "\"" 179 | 180 | traverseNodes :: NARNode -> [String] -> Maybe NARNode 181 | traverseNodes node path = go path node 182 | where 183 | go (x : xs) (NDirectory es) = Map.lookup (LBSC.pack x) es >>= go xs 184 | go _ n = Just n 185 | 186 | instance Binary Foo where 187 | get = Foo <$> many narStringG 188 | 189 | instance Binary NARNode where 190 | put = undefined 191 | get = do matchNSG "(" 192 | matchNSG "type" 193 | (_, t) <- narStringG 194 | r <- case t of "regular" -> regularGet 195 | "symlink" -> symlinkGet 196 | "directory" -> directoryGet 197 | _ -> fail "invalid type" 198 | matchNSG ")" 199 | return r 200 | 201 | instance Binary NARFile where 202 | get = magicGet >> NARFile <$> get 203 | 204 | tinyFile, shortFile, mediumFile, longFile :: FilePath 205 | tinyFile = "./container_data/5kfrplg1gj753j10k8xka9c9ggap6918-etc-fstab.nar" 206 | shortFile = "./container_data/s0aqc77hi1vhm95j0rd3xhdynspccik7-system-units.nar" 207 | mediumFile = "./container_data/14fqnkfb0dqs3grn4jh2xyii0kaik9br-util-linux-2.27.1.nar" 208 | longFile = "./container_data/0b0y9jz2b1q0hlf40p50ygrj2vhbk0fq-glibc-locales-2.23.nar" 209 | 210 | decodeNARFile :: FilePath -> IO NARFile 211 | decodeNARFile = decodeFile 212 | 213 | decodeFooFile :: FilePath -> IO Foo 214 | decodeFooFile = decodeFile 215 | 216 | splitPath :: String -> [String] 217 | splitPath x = map reverse $ go "" x 218 | where 219 | go :: String -> String -> [String] 220 | go "" ('/':ys) = go "" ys 221 | go sofar ('/':ys) = sofar : go "" ys 222 | go sofar (y:ys) = go (y : sofar) ys 223 | go sofar "" = [ sofar ] 224 | 225 | oldmain :: IO () 226 | oldmain = do 227 | args <- getArgs 228 | file <- decodeNARFile (head args) 229 | --decodeNARFile (head args) >>= print 230 | --decodeNARFile (head args) >>= putStrLn . showDot 231 | let path = splitPath "/share/man/man1" 232 | case traverseNodes (_root file) path of 233 | Nothing -> putStrLn "404" 234 | Just n -> print ("found " <> show n) 235 | 236 | endsWith :: String -> String -> Maybe String 237 | endsWith str ext = go "" (length ext) (length str) str 238 | where 239 | go _ _ _ [] = Nothing 240 | go _ _ 0 _ = Nothing 241 | go a le ls s | ls == le && s == ext = Just $ reverse a 242 | go a le ls (s:ss) = go (s:a) le (ls - 1) ss 243 | 244 | -- return storePaths or Nothings 245 | isNar :: String -> Maybe String 246 | isNar name = name `endsWith` ".nar" 247 | 248 | 249 | -- strip out the Nothings 250 | reFilter :: [Maybe String] -> [String] 251 | reFilter list = go [] list 252 | where 253 | go rest (x:xs) = case x of Nothing -> go rest xs 254 | Just n -> go (n : rest) xs 255 | go rest _ = rest 256 | 257 | getNARFiles :: [FilePath] -> [FilePath] 258 | getNARFiles = concatMap (toList . isNar) 259 | 260 | test1 :: IO () 261 | test1 = do 262 | listing <- getDirectoryContents "/home/clever/apps/data_files/" 263 | print $ getNARFiles listing 264 | 265 | newNarCache :: Map.HashMap String NARFile 266 | newNarCache = Map.empty 267 | 268 | main :: IO () 269 | main = do 270 | args <- getArgs 271 | prog <- getProgName 272 | let opts = [ "-f", "-o", "allow_other", "/home/clever/apps/narparser/mnt" ] 273 | empty_map <- newMVar newNarCache 274 | let state = RuntimeState "/home/clever/apps/container_data" empty_map 275 | --let state = RuntimeState "/home/clever/apps/narparser/sample" empty_map 276 | fuseRun prog opts (narFSOps state) defaultExceptionHandler 277 | --fuseMain (narFSOps state) defaultExceptionHandler 278 | 279 | newDecodeNARFile :: FilePath -> IO NARFile 280 | newDecodeNARFile path = do 281 | rawfile <- unsafeMMapFile path 282 | return $ decode rawfile 283 | 284 | test4 :: IO () 285 | test4 = do 286 | file <- newDecodeNARFile "/nix/store/wla2an5q64wddgz7zjxkkllpvibzxw7p-data/0b0y9jz2b1q0hlf40p50ygrj2vhbk0fq-glibc-locales-2.23.nar" 287 | a <- getPOSIXTime 288 | print file 289 | b <- getPOSIXTime 290 | print file 291 | c <- getPOSIXTime 292 | print (b-a) 293 | print (c-b) 294 | 295 | narFSOps :: RuntimeState -> FuseOperations HT 296 | narFSOps x = defaultFuseOps { fuseGetFileStat = narGetFileStat x 297 | , fuseReadSymbolicLink = narReadSymlink x 298 | , fuseOpenDirectory = narOpenDirectory x 299 | , fuseReadDirectory = narReadDirectory x 300 | , fuseOpen = narOpen x 301 | , fuseRead = narRead x } 302 | 303 | unionModes :: [FileMode] -> FileMode 304 | unionModes = foldr1 unionFileModes 305 | 306 | readModes, execModes :: [FileMode] 307 | readModes = [ownerReadMode, groupReadMode, otherReadMode] 308 | execModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode] 309 | 310 | dirStat :: FileStat 311 | dirStat = FileStat { statEntryType = Directory 312 | , statFileMode = unionModes $ readModes <> execModes 313 | , statLinkCount = 2 314 | , statFileOwner = 0 315 | , statFileGroup = 0 316 | , statSpecialDeviceID = 0 317 | , statFileSize = 4096 318 | , statBlocks = 1 319 | , statAccessTime = 0 320 | , statModificationTime = 0 321 | , statStatusChangeTime = 0 } 322 | 323 | fileStat :: Bool -> Int64 -> FileStat 324 | fileStat exec size = FileStat { statEntryType = RegularFile 325 | , statFileMode = fileModes 326 | , statLinkCount = 1 327 | , statFileOwner = 0 328 | , statFileGroup = 0 329 | , statSpecialDeviceID = 0 330 | , statFileSize = fromIntegral size 331 | , statBlocks = 1 332 | , statAccessTime = 0 333 | , statModificationTime = 0 334 | , statStatusChangeTime = 0 } 335 | where 336 | fileModes = unionModes $ readModes <> if exec then execModes else [] 337 | 338 | linkStat :: Path -> FileStat 339 | linkStat t = FileStat { statEntryType = SymbolicLink 340 | , statFileMode = unionModes readModes 341 | , statLinkCount = 1 342 | , statFileOwner = 0 343 | , statFileGroup = 0 344 | , statSpecialDeviceID = 0 345 | , statFileSize = fromIntegral $ LBSC.length t 346 | , statBlocks = 1 347 | , statAccessTime = 0 348 | , statModificationTime = 0 349 | , statStatusChangeTime = 0 } 350 | 351 | statNode :: NARNode -> FileStat 352 | statNode (NFile e c) = fileStat e $ fromIntegral $ LBS.length c 353 | statNode (NDirectory _) = dirStat 354 | statNode (NSymlink t) = linkStat t 355 | 356 | -- possibly rename 357 | findNode :: RuntimeState -> String -> IO (Maybe NARNode) 358 | findNode state p = go $ splitPath p 359 | where 360 | go (sp:pp) = (>>= (`traverseNodes` pp) . _root) <$> getNarHandle state sp 361 | go _ = return Nothing 362 | 363 | narGetFileStat :: RuntimeState -> FilePath -> IO (Either Errno FileStat) 364 | narGetFileStat _ "/" = return $ Right dirStat 365 | narGetFileStat state x = maybe (Left eNOENT) (Right . statNode) 366 | <$> findNode state x 367 | 368 | narReadSymlink :: RuntimeState -> FilePath -> IO (Either Errno FilePath) 369 | narReadSymlink state x = do m <- findNode state x 370 | return $ case m 371 | of Just (NSymlink t) -> Right $ LBSC.unpack t 372 | Just _ -> Left eFAULT 373 | Nothing -> Left eNOENT 374 | 375 | narOpen :: RuntimeState -> FilePath -> OpenMode -> OpenFileFlags -> IO (Either Errno HT) 376 | narOpen state p _ _ = maybe (Left eNOENT) (Right . HT) <$> findNode state p 377 | 378 | narRead :: RuntimeState -> FilePath -> HT -> ByteCount -> FileOffset -> IO (Either Errno BS.ByteString) 379 | narRead _ path hnd byteCount offset = do 380 | let pathparts = splitPath path 381 | let fullContents = _contents (_handle hnd) 382 | putStrLn $ "read " <> show pathparts <> " x " <> show (_handle hnd) 383 | return $ Right $ LBSC.toStrict (substr (fromIntegral offset) (fromIntegral byteCount) fullContents) 384 | where 385 | substr :: Int64 -> Int64 -> LBSC.ByteString -> LBSC.ByteString 386 | substr offset2 size input = LBSC.take size (LBSC.drop offset2 input) 387 | 388 | getNarHandle :: RuntimeState -> String -> IO (Maybe NARFile) 389 | getNarHandle state p = takeMVar (_narCache state) 390 | >>= \c -> decide (Map.lookup p c) c 391 | where 392 | file1 = _dataDir state <> "/" <> head (splitPath p) <> ".nar" 393 | newHandle file = catch (Just <$> newDecodeNARFile file) handleError 394 | handleError :: IOException -> IO (Maybe a) 395 | handleError e = putStrLn ("caught:" <> show e) >> return Nothing 396 | decide :: Maybe NARFile -> Map String NARFile -> IO (Maybe NARFile) 397 | decide res cache = case res of 398 | Just f -> putMVar (_narCache state) cache >> return (Just f) 399 | Nothing -> do newEntry <- newHandle file1 400 | case newEntry 401 | of Just e -> do 402 | putMVar (_narCache state) $ Map.insert p e cache 403 | return newEntry 404 | Nothing -> do 405 | putStrLn "open fail" 406 | putMVar (_narCache state) cache 407 | return Nothing 408 | 409 | dotDirs :: [(FilePath, FileStat)] 410 | dotDirs = [(".", dirStat), ("..", dirStat)] 411 | 412 | narOpenDirectory :: RuntimeState -> FilePath -> IO Errno 413 | --narOpenDirectory state "/" = return eOK 414 | narOpenDirectory _ _ = return eOK -- TODO, check if dir is a directory 415 | 416 | narReadDirectory :: RuntimeState -> FilePath -> IO (Either Errno [(FilePath, FileStat)]) 417 | narReadDirectory state "/" = do 418 | listing <- getDirectoryContents $ _dataDir state 419 | return $ Right $ dotDirs <> makeListing listing 420 | where 421 | makeListing listing = map (\nar -> (nar, dirStat)) $ getNARFiles listing 422 | -- FIXME, return the right stat 423 | narReadDirectory state (splitPath -> storepath:pathparts) = do 424 | hnd1 <- getNarHandle state storepath 425 | return $ case hnd1 >>= (`traverseNodes` pathparts) . _root 426 | of Just dir -> Right $ dotDirs <> addStats dir 427 | _ -> Left eNOENT 428 | where 429 | mapFn1 :: Name -> NARNode -> (String, FileStat) 430 | mapFn1 = curry (LBSC.unpack *** statNode) 431 | 432 | addStats :: NARNode -> [(String, FileStat)] 433 | addStats (NDirectory e) = toList $ Map.mapWithKey mapFn1 e 434 | narReadDirectory state _ = error "FIXME" 435 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | Main: Main.hs 2 | ghc -O2 Main.hs -rtsopts -threaded 3 | do_test: Main 4 | ./Main ../input.nar 5 | do_test2: Main 6 | ./Main ../input.nar +RTS -t --machine-readable -s 7 | do_test3: Main 8 | ./Main ../input.nar +RTS -s 9 | do_test4: Main 10 | ./Main ../container_data/ikzdbd65z7453spdvm05r0izd56zdvkx-gcc-4.9.3.nar 11 | install: 12 | mkdir -p ${out}/bin 13 | cp Main ${out}/bin/narparser 14 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { stdenv, haskellPackages }: 2 | 3 | let 4 | hsEnv = haskellPackages.ghcWithPackages (hsPkgs: with hsPkgs; [ bytestring-mmap HFuse hashable unordered-containers ]); 5 | in 6 | stdenv.mkDerivation { 7 | name = "narparser"; 8 | src = ./.; 9 | 10 | buildInputs = [ hsEnv ]; 11 | } 12 | -------------------------------------------------------------------------------- /hello-2.10.nar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/taktoa/narfuse/86757825a970d483898bb4728f6f05789e3f44b4/hello-2.10.nar --------------------------------------------------------------------------------