Add provisional NAR parser and generator

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

@@ -17,10 +17,13 @@ extra-source-files:  ChangeLog.md, README.md
 cabal-version:       >=1.10
 
 library
-  exposed-modules:     Crypto.Hash.Truncated, System.Nix.Store
+  exposed-modules:     Crypto.Hash.Truncated
+                     , System.Nix.Nar
+                     , System.Nix.Store
   build-depends:       base >=4.10 && <4.11,
                        -- Drop foundation when we can drop cryptonite <0.25
-                       cryptonite, memory, foundation, basement,
+                       binary,
+                       bytestring, containers, cryptonite, memory, foundation, basement,
                        text, regex-base, regex-tdfa-text,
                        hashable, unordered-containers
   hs-source-dirs:      src

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

@@ -0,0 +1,181 @@
+{-# LANGUAGE KindSignatures    #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TupleSections    #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-|
+Description : Allowed effects for interacting with Nar files.
+Maintainer  : Shea Levy <shea@shealevy.com>
+|-}
+module System.Nix.Nar where
+
+import           Control.Monad (replicateM, replicateM_)
+import           Data.Monoid ((<>))
+import           Control.Applicative
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import qualified Data.Set as Set
+import qualified Data.Binary as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as E
+import qualified Data.Binary.Put as B
+import qualified Data.Binary.Get as B
+import           Debug.Trace
+
+import System.Nix.Path
+
+
+data NarEffects (m :: * -> *) = NarEffets {
+    readFile         :: FilePath -> m BSL.ByteString
+  , listDir          :: FilePath -> m [FileSystemObject]
+  , narFromFileBytes :: BSL.ByteString -> m Nar
+  , narFromDirectory :: FilePath -> m Nar
+}
+
+
+-- Directly taken from Eelco thesis
+-- https://nixos.org/%7Eeelco/pubs/phd-thesis.pdf
+
+-- TODO: Should we use rootedPath, validPath rather than FilePath?
+data Nar = Nar { narFile :: FileSystemObject }
+    deriving (Eq, Ord, Show)
+
+data FileSystemObject =
+    Regular IsExecutable BSL.ByteString
+  | Directory (Set.Set (PathName, FileSystemObject))
+  | SymLink BSL.ByteString
+  deriving (Eq, Show)
+
+-- TODO - is this right? How does thesis define ordering of FSOs?
+instance Ord FileSystemObject where
+    compare (Regular _ c1) (Regular _ c2) = compare c1 c2
+    compare (Regular _ _)  _              = GT
+    compare (Directory s1) (Directory s2) = compare s1 s2
+    compare (Directory _)  _              = GT
+    compare (SymLink l1) (SymLink l2)     = compare l1 l2
+
+data IsExecutable = NonExecutable | Executable
+    deriving (Eq, Show)
+
+-- data NarFile = NarFile
+--     { narFileIsExecutable :: IsExecutable
+--     , narFilePath         :: FilePath -- TODO: Correct type?
+--     } deriving (Show)
+
+data DebugPut = PutAscii | PutBinary
+
+putNar :: Nar -> B.Put
+putNar = putNar' PutBinary
+
+putNar' :: DebugPut -> Nar -> B.Put
+putNar' dbg (Nar file) = header <>
+                         parens (putFile file)
+    where
+
+        str' = case dbg of
+            PutAscii -> strDebug
+            PutBinary -> str
+
+        header   = str' "nix-archive-1"
+        parens m = str' "(" <> m <> str ")"
+
+        putFile (Regular isExec contents) =
+               str' "type" <> str' "regular"
+            <> if isExec == Executable
+               then str' "executable" <> str' ""
+               else str' ""
+            <> str' "contents" <> str' contents
+
+        putFile (SymLink target) =
+               str' "type" <> str' "symlink" <> str' "target" <> str' target
+
+        putFile (Directory entries) =
+               str' "type" <> str' "directory"
+            <> foldMap putEntry entries
+
+        putEntry (PathName name, fso) =
+            str' "entry" <>
+            parens (str' "name" <>
+                    str' (BSL.fromStrict $ E.encodeUtf8 name) <>
+                    str' "node" <>
+                    putFile fso)
+
+getNar :: B.Get Nar
+getNar = fmap Nar $ header >> parens getFile
+    where header   = trace "header " $ assertStr "nix-archive-1"
+
+          padLen n = let r = n `mod` 8
+                         p = (8 - n) `mod` 8
+                     in trace ("padLen: " ++ show p) p
+
+          str = do
+              n <- fmap fromIntegral B.getInt64le
+              s <- B.getLazyByteString n
+              p <- B.getByteString (padLen $ fromIntegral n)
+              traceShow (n,s) $ return s
+
+          assertStr s = trace ("Assert " ++ show s) $ do
+              s' <- str
+              if s == s'
+                  then trace ("Assert " ++ show s ++ " passed") (return s)
+                  else trace ("Assert " ++ show s ++ " failed") (fail "No")
+
+          parens m = assertStr "(" *> m <* assertStr ")"
+
+          getFile :: B.Get FileSystemObject
+          getFile = trace "getFile" (getRegularFile)
+                <|> trace "getDir" (getDirectory)
+                <|> trace "getLink" (getSymLink)
+
+          getRegularFile = trace "regular" $ do
+              trace "TESTING" (assertStr "type")
+              trace "HI" $ assertStr "regular"
+              trace "HI AGOIN" $ assertStr "contents"
+              contents <- str
+              return $ Regular (maybe NonExecutable
+                                   (const Executable) Nothing) contents
+
+          getDirectory = do
+              assertStr "type"
+              assertStr "directory"
+              fs <- many getEntry
+              return $ Directory (Set.fromList fs)
+
+          getSymLink = do
+              assertStr "type"
+              assertStr "symlink"
+              assertStr "target"
+              fmap SymLink str
+
+          getEntry = do
+              assertStr "entry"
+              parens $ do
+                  assertStr "name"
+                  mname <- pathName . E.decodeUtf8 . BSL.toStrict <$> str
+                  assertStr "node"
+                  file <- parens getFile
+                  maybe (fail "Bad PathName") (return . (,file)) mname
+
+str :: BSL.ByteString -> B.Put
+str t = let len = BSL.length t
+    in int len <> pad t
+
+int :: Integral a => a -> B.Put
+int n = B.putInt64le $ fromIntegral n
+
+pad :: BSL.ByteString -> B.Put
+pad bs =
+    let padLen = BSL.length bs `div` 8
+    in  B.put bs >> B.put (BSL.replicate padLen '\NUL')
+
+strDebug :: BSL.ByteString -> B.Put
+strDebug t = let len = BSL.length t
+    in intDebug len <> padDebug t
+
+intDebug :: Integral a => a -> B.Put
+intDebug a = B.put (show @Int (fromIntegral a))
+
+padDebug :: BSL.ByteString -> B.Put
+padDebug bs =
+    let padLen = BSL.length bs `div` 8
+    in  B.put bs >> B.put (BSL.replicate padLen '_')

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

@@ -0,0 +1,76 @@
+{-|
+Description : Types and effects for interacting with the Nix store.
+Maintainer  : Shea Levy <shea@shealevy.com>
+-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module System.Nix.Path
+  ( PathHashAlgo
+  , Path(..)
+  , SubstitutablePathInfo(..)
+  , PathName(..)
+  , pathName
+  ) where
+
+import Crypto.Hash               (Digest)
+import Crypto.Hash.Truncated     (Truncated)
+import Crypto.Hash.Algorithms    (SHA256)
+import qualified Data.ByteArray  as B
+import Data.Text                 (Text)
+import Text.Regex.Base.RegexLike (makeRegex, matchTest)
+import Text.Regex.TDFA.Text      (Regex)
+import Data.Hashable             (Hashable(..), hashPtrWithSalt)
+import Data.HashSet              (HashSet)
+import Data.HashMap.Strict       (HashMap)
+import System.IO.Unsafe          (unsafeDupablePerformIO)
+
+-- | The name portion of a Nix path.
+--
+-- Must be composed of a-z, A-Z, 0-9, +, -, ., _, ?, and =, can't
+-- start with a ., and must have at least one character.
+newtype PathName = PathName
+  { pathNameContents :: Text -- ^ The contents of the path name
+  } deriving (Eq, Ord, Show, Hashable)
+
+-- | A regular expression for matching a valid 'PathName'
+nameRegex :: Regex
+nameRegex =
+  makeRegex "[a-zA-Z0-9\\+\\-\\_\\?\\=][a-zA-Z0-9\\+\\-\\.\\_\\?\\=]*"
+
+-- | Construct a 'PathName', assuming the provided contents are valid.
+pathName :: Text -> Maybe PathName
+pathName n = case matchTest nameRegex n of
+  True -> Just $ PathName n
+  False -> Nothing
+
+-- | The hash algorithm used for store path hashes.
+type PathHashAlgo = Truncated SHA256 20
+
+-- | A path in a store.
+data Path = Path !(Digest PathHashAlgo) !PathName
+
+-- | Wrapper to defined a 'Hashable' instance for 'Digest'.
+newtype HashableDigest a = HashableDigest (Digest a)
+
+instance Hashable (HashableDigest a) where
+  hashWithSalt s (HashableDigest d) = unsafeDupablePerformIO $
+    B.withByteArray d $ \ptr -> hashPtrWithSalt ptr (B.length d) s
+
+instance Hashable Path where
+  hashWithSalt s (Path digest name) =
+    s `hashWithSalt`
+    (HashableDigest digest) `hashWithSalt` name
+
+
+-- | Information about substitutes for a 'Path'.
+data SubstitutablePathInfo = SubstitutablePathInfo
+  { -- | The .drv which led to this 'Path'.
+    deriver :: !(Maybe Path)
+  , -- | The references of the 'Path'
+    references :: !(HashSet Path)
+  , -- | The (likely compressed) size of the download of this 'Path'.
+    downloadSize :: !Integer
+  , -- | The size of the uncompressed NAR serialization of this
+    -- 'Path'.
+    narSize :: !Integer
+  }

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+
 {-|
 Description : Types and effects for interacting with the Nix store.
 Maintainer  : Shea Levy <shea@shealevy.com>
@@ -23,55 +25,9 @@ import Data.HashSet (HashSet)
 import Data.HashMap.Strict (HashMap)
 import System.IO.Unsafe (unsafeDupablePerformIO)
 
--- | The name portion of a Nix path.
---
--- Must be composed of a-z, A-Z, 0-9, +, -, ., _, ?, and =, can't
--- start with a ., and must have at least one character.
-newtype PathName = PathName
-  { pathNameContents :: Text -- ^ The contents of the path name
-  } deriving (Hashable)
+import System.Nix.Path
+import System.Nix.Nar
 
--- | A regular expression for matching a valid 'PathName'
-nameRegex :: Regex
-nameRegex =
-  makeRegex "[a-zA-Z0-9\\+\\-\\_\\?\\=][a-zA-Z0-9\\+\\-\\.\\_\\?\\=]*"
-
--- | Construct a 'PathName', assuming the provided contents are valid.
-pathName :: Text -> Maybe PathName
-pathName n = case matchTest nameRegex n of
-  True -> Just $ PathName n
-  False -> Nothing
-
--- | The hash algorithm used for store path hashes.
-type PathHashAlgo = Truncated SHA256 20
-
--- | A path in a store.
-data Path = Path !(Digest PathHashAlgo) !PathName
-
--- | Wrapper to defined a 'Hashable' instance for 'Digest'.
-newtype HashableDigest a = HashableDigest (Digest a)
-
-instance Hashable (HashableDigest a) where
-  hashWithSalt s (HashableDigest d) = unsafeDupablePerformIO $
-    B.withByteArray d $ \ptr -> hashPtrWithSalt ptr (B.length d) s
-
-instance Hashable Path where
-  hashWithSalt s (Path digest name) =
-    s `hashWithSalt`
-    (HashableDigest digest) `hashWithSalt` name
-
--- | Information about substitutes for a 'Path'.
-data SubstitutablePathInfo = SubstitutablePathInfo
-  { -- | The .drv which led to this 'Path'.
-    deriver :: !(Maybe Path)
-  , -- | The references of the 'Path'
-    references :: !(HashSet Path)
-  , -- | The (likely compressed) size of the download of this 'Path'.
-    downloadSize :: !Integer
-  , -- | The size of the uncompressed NAR serialization of this
-    -- 'Path'.
-    narSize :: !Integer
-  }
 
 -- | Interactions with the Nix store.
 --
@@ -109,4 +65,5 @@ data StoreEffects rootedPath validPath m =
       derivationOutputNames :: !(validPath -> m (HashSet Text))
     , -- | Get a full 'Path' corresponding to a given 'Digest'.
       pathFromHashPart :: !(Digest PathHashAlgo -> m Path)
+    , narEffects :: NarEffects m
     }