{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeInType #-}
module System.Nix.Internal.StorePath where
import System.Nix.Hash
( HashAlgorithm(Truncated, SHA256)
, Digest
, BaseEncoding(..)
, encodeInBase
, decodeBase
, SomeNamedDigest
)
import System.Nix.Internal.Base32 (digits32)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BC
import qualified Data.Char
import Data.Hashable (Hashable(..))
import Data.HashSet (HashSet)
import Data.Attoparsec.Text.Lazy (Parser, (<?>))
import qualified Data.Attoparsec.Text.Lazy
import qualified System.FilePath
data StorePath = StorePath
{
StorePath -> Digest StorePathHashAlgo
storePathHash :: !(Digest StorePathHashAlgo)
,
StorePath -> StorePathName
storePathName :: !StorePathName
,
StorePath -> FilePath
storePathRoot :: !FilePath
} deriving (StorePath -> StorePath -> Bool
(StorePath -> StorePath -> Bool)
-> (StorePath -> StorePath -> Bool) -> Eq StorePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StorePath -> StorePath -> Bool
$c/= :: StorePath -> StorePath -> Bool
== :: StorePath -> StorePath -> Bool
$c== :: StorePath -> StorePath -> Bool
Eq, Eq StorePath
Eq StorePath
-> (StorePath -> StorePath -> Ordering)
-> (StorePath -> StorePath -> Bool)
-> (StorePath -> StorePath -> Bool)
-> (StorePath -> StorePath -> Bool)
-> (StorePath -> StorePath -> Bool)
-> (StorePath -> StorePath -> StorePath)
-> (StorePath -> StorePath -> StorePath)
-> Ord StorePath
StorePath -> StorePath -> Bool
StorePath -> StorePath -> Ordering
StorePath -> StorePath -> StorePath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StorePath -> StorePath -> StorePath
$cmin :: StorePath -> StorePath -> StorePath
max :: StorePath -> StorePath -> StorePath
$cmax :: StorePath -> StorePath -> StorePath
>= :: StorePath -> StorePath -> Bool
$c>= :: StorePath -> StorePath -> Bool
> :: StorePath -> StorePath -> Bool
$c> :: StorePath -> StorePath -> Bool
<= :: StorePath -> StorePath -> Bool
$c<= :: StorePath -> StorePath -> Bool
< :: StorePath -> StorePath -> Bool
$c< :: StorePath -> StorePath -> Bool
compare :: StorePath -> StorePath -> Ordering
$ccompare :: StorePath -> StorePath -> Ordering
$cp1Ord :: Eq StorePath
Ord)
instance Hashable StorePath where
hashWithSalt :: Int -> StorePath -> Int
hashWithSalt Int
s (StorePath {FilePath
Digest StorePathHashAlgo
StorePathName
storePathRoot :: FilePath
storePathName :: StorePathName
storePathHash :: Digest StorePathHashAlgo
storePathRoot :: StorePath -> FilePath
storePathName :: StorePath -> StorePathName
storePathHash :: StorePath -> Digest StorePathHashAlgo
..}) =
Int
s Int -> Digest StorePathHashAlgo -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Digest StorePathHashAlgo
storePathHash Int -> StorePathName -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` StorePathName
storePathName
instance Show StorePath where
show :: StorePath -> FilePath
show StorePath
p = ByteString -> FilePath
BC.unpack (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ StorePath -> ByteString
storePathToRawFilePath StorePath
p
newtype StorePathName = StorePathName
{
StorePathName -> Text
unStorePathName :: Text
} deriving (StorePathName -> StorePathName -> Bool
(StorePathName -> StorePathName -> Bool)
-> (StorePathName -> StorePathName -> Bool) -> Eq StorePathName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StorePathName -> StorePathName -> Bool
$c/= :: StorePathName -> StorePathName -> Bool
== :: StorePathName -> StorePathName -> Bool
$c== :: StorePathName -> StorePathName -> Bool
Eq, Int -> StorePathName -> Int
StorePathName -> Int
(Int -> StorePathName -> Int)
-> (StorePathName -> Int) -> Hashable StorePathName
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: StorePathName -> Int
$chash :: StorePathName -> Int
hashWithSalt :: Int -> StorePathName -> Int
$chashWithSalt :: Int -> StorePathName -> Int
Hashable, Eq StorePathName
Eq StorePathName
-> (StorePathName -> StorePathName -> Ordering)
-> (StorePathName -> StorePathName -> Bool)
-> (StorePathName -> StorePathName -> Bool)
-> (StorePathName -> StorePathName -> Bool)
-> (StorePathName -> StorePathName -> Bool)
-> (StorePathName -> StorePathName -> StorePathName)
-> (StorePathName -> StorePathName -> StorePathName)
-> Ord StorePathName
StorePathName -> StorePathName -> Bool
StorePathName -> StorePathName -> Ordering
StorePathName -> StorePathName -> StorePathName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StorePathName -> StorePathName -> StorePathName
$cmin :: StorePathName -> StorePathName -> StorePathName
max :: StorePathName -> StorePathName -> StorePathName
$cmax :: StorePathName -> StorePathName -> StorePathName
>= :: StorePathName -> StorePathName -> Bool
$c>= :: StorePathName -> StorePathName -> Bool
> :: StorePathName -> StorePathName -> Bool
$c> :: StorePathName -> StorePathName -> Bool
<= :: StorePathName -> StorePathName -> Bool
$c<= :: StorePathName -> StorePathName -> Bool
< :: StorePathName -> StorePathName -> Bool
$c< :: StorePathName -> StorePathName -> Bool
compare :: StorePathName -> StorePathName -> Ordering
$ccompare :: StorePathName -> StorePathName -> Ordering
$cp1Ord :: Eq StorePathName
Ord)
type StorePathHashAlgo = 'Truncated 20 'SHA256
type StorePathSet = HashSet StorePath
data ContentAddressableAddress
=
Text !(Digest 'SHA256)
|
Fixed !NarHashMode !SomeNamedDigest
data NarHashMode
=
RegularFile
|
Recursive
makeStorePathName :: Text -> Either String StorePathName
makeStorePathName :: Text -> Either FilePath StorePathName
makeStorePathName Text
n = case Text -> Bool
validStorePathName Text
n of
Bool
True -> StorePathName -> Either FilePath StorePathName
forall a b. b -> Either a b
Right (StorePathName -> Either FilePath StorePathName)
-> StorePathName -> Either FilePath StorePathName
forall a b. (a -> b) -> a -> b
$ Text -> StorePathName
StorePathName Text
n
Bool
False -> FilePath -> Either FilePath StorePathName
forall a b. a -> Either a b
Left (FilePath -> Either FilePath StorePathName)
-> FilePath -> Either FilePath StorePathName
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
reasonInvalid Text
n
reasonInvalid :: Text -> String
reasonInvalid :: Text -> FilePath
reasonInvalid Text
n | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = FilePath
"Empty name"
reasonInvalid Text
n | (Text -> Int
T.length Text
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
211) = FilePath
"Path too long"
reasonInvalid Text
n | (Text -> Char
T.head Text
n Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') = FilePath
"Leading dot"
reasonInvalid Text
_ | Bool
otherwise = FilePath
"Invalid character"
validStorePathName :: Text -> Bool
validStorePathName :: Text -> Bool
validStorePathName Text
"" = Bool
False
validStorePathName Text
n = (Text -> Int
T.length Text
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
211)
Bool -> Bool -> Bool
&& Text -> Char
T.head Text
n Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.'
Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
validStorePathNameChar Text
n
validStorePathNameChar :: Char -> Bool
validStorePathNameChar :: Char -> Bool
validStorePathNameChar Char
c = ((Char -> Bool) -> Bool) -> [Char -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Char
c) ([Char -> Bool] -> Bool) -> [Char -> Bool] -> Bool
forall a b. (a -> b) -> a -> b
$
[ Char -> Bool
Data.Char.isAsciiLower
, Char -> Bool
Data.Char.isAsciiUpper
, Char -> Bool
Data.Char.isDigit
] [Char -> Bool] -> [Char -> Bool] -> [Char -> Bool]
forall a. [a] -> [a] -> [a]
++
(Char -> Char -> Bool) -> FilePath -> [Char -> Bool]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) FilePath
"+-._?="
type RawFilePath = ByteString
storePathToRawFilePath
:: StorePath
-> RawFilePath
storePathToRawFilePath :: StorePath -> ByteString
storePathToRawFilePath StorePath {FilePath
Digest StorePathHashAlgo
StorePathName
storePathRoot :: FilePath
storePathName :: StorePathName
storePathHash :: Digest StorePathHashAlgo
storePathRoot :: StorePath -> FilePath
storePathName :: StorePath -> StorePathName
storePathHash :: StorePath -> Digest StorePathHashAlgo
..} = [ByteString] -> ByteString
BS.concat
[ ByteString
root
, ByteString
"/"
, ByteString
hashPart
, ByteString
"-"
, ByteString
name
]
where
root :: ByteString
root = FilePath -> ByteString
BC.pack FilePath
storePathRoot
hashPart :: ByteString
hashPart = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ BaseEncoding -> Digest StorePathHashAlgo -> Text
forall (a :: HashAlgorithm). BaseEncoding -> Digest a -> Text
encodeInBase BaseEncoding
Base32 Digest StorePathHashAlgo
storePathHash
name :: ByteString
name = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ StorePathName -> Text
unStorePathName StorePathName
storePathName
storePathToFilePath
:: StorePath
-> FilePath
storePathToFilePath :: StorePath -> FilePath
storePathToFilePath = ByteString -> FilePath
BC.unpack (ByteString -> FilePath)
-> (StorePath -> ByteString) -> StorePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> ByteString
storePathToRawFilePath
storePathToText
:: StorePath
-> Text
storePathToText :: StorePath -> Text
storePathToText = FilePath -> Text
T.pack (FilePath -> Text) -> (StorePath -> FilePath) -> StorePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BC.unpack (ByteString -> FilePath)
-> (StorePath -> ByteString) -> StorePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> ByteString
storePathToRawFilePath
storePathToNarInfo
:: StorePath
-> BC.ByteString
storePathToNarInfo :: StorePath -> ByteString
storePathToNarInfo StorePath {FilePath
Digest StorePathHashAlgo
StorePathName
storePathRoot :: FilePath
storePathName :: StorePathName
storePathHash :: Digest StorePathHashAlgo
storePathRoot :: StorePath -> FilePath
storePathName :: StorePath -> StorePathName
storePathHash :: StorePath -> Digest StorePathHashAlgo
..} = [ByteString] -> ByteString
BS.concat
[ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ BaseEncoding -> Digest StorePathHashAlgo -> Text
forall (a :: HashAlgorithm). BaseEncoding -> Digest a -> Text
encodeInBase BaseEncoding
Base32 Digest StorePathHashAlgo
storePathHash
, ByteString
".narinfo"
]
parsePath
:: FilePath
-> BC.ByteString
-> Either String StorePath
parsePath :: FilePath -> ByteString -> Either FilePath StorePath
parsePath FilePath
expectedRoot ByteString
x =
let
(FilePath
rootDir, FilePath
fname) = FilePath -> (FilePath, FilePath)
System.FilePath.splitFileName (FilePath -> (FilePath, FilePath))
-> (ByteString -> FilePath) -> ByteString -> (FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BC.unpack (ByteString -> (FilePath, FilePath))
-> ByteString -> (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ ByteString
x
(Text
digestPart, Text
namePart) = Text -> Text -> (Text, Text)
T.breakOn Text
"-" (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fname
digest :: Either FilePath (Digest a)
digest = BaseEncoding -> Text -> Either FilePath (Digest a)
forall (a :: HashAlgorithm).
BaseEncoding -> Text -> Either FilePath (Digest a)
decodeBase BaseEncoding
Base32 Text
digestPart
name :: Either FilePath StorePathName
name = Text -> Either FilePath StorePathName
makeStorePathName (Text -> Either FilePath StorePathName)
-> (Text -> Text) -> Text -> Either FilePath StorePathName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
1 (Text -> Either FilePath StorePathName)
-> Text -> Either FilePath StorePathName
forall a b. (a -> b) -> a -> b
$ Text
namePart
rootDir' :: FilePath
rootDir' = ShowS
forall a. [a] -> [a]
init FilePath
rootDir
storeDir :: Either FilePath FilePath
storeDir = if FilePath
expectedRoot FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
rootDir'
then FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right FilePath
rootDir'
else FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left (FilePath -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Root store dir mismatch, expected" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
expectedRoot FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"got" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
rootDir'
in
Digest StorePathHashAlgo -> StorePathName -> FilePath -> StorePath
StorePath (Digest StorePathHashAlgo
-> StorePathName -> FilePath -> StorePath)
-> Either FilePath (Digest StorePathHashAlgo)
-> Either FilePath (StorePathName -> FilePath -> StorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either FilePath (Digest StorePathHashAlgo)
forall (a :: HashAlgorithm). Either FilePath (Digest a)
digest Either FilePath (StorePathName -> FilePath -> StorePath)
-> Either FilePath StorePathName
-> Either FilePath (FilePath -> StorePath)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either FilePath StorePathName
name Either FilePath (FilePath -> StorePath)
-> Either FilePath FilePath -> Either FilePath StorePath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either FilePath FilePath
storeDir
pathParser :: FilePath -> Parser StorePath
pathParser :: FilePath -> Parser StorePath
pathParser FilePath
expectedRoot = do
Text
_ <- Text -> Parser Text
Data.Attoparsec.Text.Lazy.string (FilePath -> Text
T.pack FilePath
expectedRoot)
Parser Text -> FilePath -> Parser Text
forall i a. Parser i a -> FilePath -> Parser i a
<?> FilePath
"Store root mismatch"
Char
_ <- Char -> Parser Char
Data.Attoparsec.Text.Lazy.char Char
'/'
Parser Char -> FilePath -> Parser Char
forall i a. Parser i a -> FilePath -> Parser i a
<?> FilePath
"Expecting path separator"
Either FilePath (Digest StorePathHashAlgo)
digest <- BaseEncoding -> Text -> Either FilePath (Digest StorePathHashAlgo)
forall (a :: HashAlgorithm).
BaseEncoding -> Text -> Either FilePath (Digest a)
decodeBase BaseEncoding
Base32
(Text -> Either FilePath (Digest StorePathHashAlgo))
-> Parser Text
-> Parser Text (Either FilePath (Digest StorePathHashAlgo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
Data.Attoparsec.Text.Lazy.takeWhile1 (Char -> Vector Char -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Vector Char
digits32)
Parser Text (Either FilePath (Digest StorePathHashAlgo))
-> FilePath
-> Parser Text (Either FilePath (Digest StorePathHashAlgo))
forall i a. Parser i a -> FilePath -> Parser i a
<?> FilePath
"Invalid Base32 part"
Char
_ <- Char -> Parser Char
Data.Attoparsec.Text.Lazy.char Char
'-'
Parser Char -> FilePath -> Parser Char
forall i a. Parser i a -> FilePath -> Parser i a
<?> FilePath
"Expecting dash (path name separator)"
Char
c0 <- (Char -> Bool) -> Parser Char
Data.Attoparsec.Text.Lazy.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.' Bool -> Bool -> Bool
&& Char -> Bool
validStorePathNameChar Char
c)
Parser Char -> FilePath -> Parser Char
forall i a. Parser i a -> FilePath -> Parser i a
<?> FilePath
"Leading path name character is a dot or invalid character"
Text
rest <- (Char -> Bool) -> Parser Text
Data.Attoparsec.Text.Lazy.takeWhile Char -> Bool
validStorePathNameChar
Parser Text -> FilePath -> Parser Text
forall i a. Parser i a -> FilePath -> Parser i a
<?> FilePath
"Path name contains invalid character"
let name :: Either FilePath StorePathName
name = Text -> Either FilePath StorePathName
makeStorePathName (Text -> Either FilePath StorePathName)
-> Text -> Either FilePath StorePathName
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons Char
c0 Text
rest
(FilePath -> Parser StorePath)
-> (StorePath -> Parser StorePath)
-> Either FilePath StorePath
-> Parser StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Parser StorePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail StorePath -> Parser StorePath
forall (m :: * -> *) a. Monad m => a -> m a
return
(Either FilePath StorePath -> Parser StorePath)
-> Either FilePath StorePath -> Parser StorePath
forall a b. (a -> b) -> a -> b
$ Digest StorePathHashAlgo -> StorePathName -> FilePath -> StorePath
StorePath (Digest StorePathHashAlgo
-> StorePathName -> FilePath -> StorePath)
-> Either FilePath (Digest StorePathHashAlgo)
-> Either FilePath (StorePathName -> FilePath -> StorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either FilePath (Digest StorePathHashAlgo)
digest Either FilePath (StorePathName -> FilePath -> StorePath)
-> Either FilePath StorePathName
-> Either FilePath (FilePath -> StorePath)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either FilePath StorePathName
name Either FilePath (FilePath -> StorePath)
-> Either FilePath FilePath -> Either FilePath StorePath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Either FilePath FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
expectedRoot