-
Notifications
You must be signed in to change notification settings - Fork 1
/
Serialization.hs
253 lines (215 loc) · 8.77 KB
/
Serialization.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Serialization of Nars and NarExports
module Nix.Nar.Serialization where
import ClassyPrelude hiding (take, try, Builder)
#ifdef USE_CEREAL
#define BINARY_CLASS Serialize
import Data.Serialize (Serialize(get, put), Put, Get, runGetLazy)
import Data.Serialize (putByteString, getByteString, execPut)
import Data.Serialize (getInt64le, putInt64le, label, lookAhead, skip)
#else
#define BINARY_CLASS Binary
import Data.Binary (Binary(put, get))
import Data.Binary.Get (Get, getInt64le, getByteString, skip, lookAhead, label)
import Data.Binary.Get (runGetOrFail)
import Data.Binary.Put (Put, putByteString, putInt64le, execPut)
#endif
import Data.ByteString.Builder (toLazyByteString)
import qualified Codec.Compression.Lzma as Lzma
import qualified Codec.Compression.GZip as GZip
import qualified Data.HashMap.Strict as H
import qualified Data.HashSet as HS
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import Servant (MimeUnrender(..), OctetStream, MimeRender(..))
import Nix.StorePath (NixStoreDir(..), StorePath(..))
import Nix.StorePath (parseFullStorePath, spToFull)
import Nix.Nar.Types
-- | Wrap the Int64 type to create custom BINARY_CLASS instance
newtype NarInt = NarInt Int deriving (Show, Eq, Ord, Num)
-- NarInts are written as a 8 bytes in little endian format
instance BINARY_CLASS NarInt where
put (NarInt n) = putInt64le $ fromIntegral n
get = NarInt . fromIntegral <$> getInt64le
-- | Wrap to create custom BINARY_CLASS instance
newtype NarString = NarString ByteString deriving (Show, Eq, Ord, IsString)
instance BINARY_CLASS NarString where
put (NarString s) = put (NarInt $ length s) *> putByteString (padTo8 s)
where padTo8 bs | length bs `mod` 8 == 0 = bs
padTo8 bs = bs <> replicate (8 - (length bs `mod` 8)) 0
get = do
-- Get the length of the string
NarInt len <- get
-- Read that many bytes
result <- NarString <$> getByteString len
-- Read any bytes remaining (padded to a multiple of 8)
when (len `mod` 8 /= 0) $ do
skip (8 - (len `mod` 8))
pure result
-- | Convenience function to resolve type ambiguity.
putNS :: NarString -> Put
putNS = put
-- | Read a particular nar string, fail if it doesn't match
getExactNS :: NarString -> Get ()
getExactNS expected = do
s <- get
when (s /= expected) $ do
fail ("expected string " <> show expected <> " but got " <> show s)
-- | Read an arbitrary nar string, and then convert it into a bytestring.
getSomeNS :: Get ByteString
getSomeNS = get >>= \(NarString s) -> pure s
-- | Read a particular bytestring (not nar string -- exact bytes)
getThisByteString :: ByteString -> Get ()
getThisByteString expected = do
s <- getByteString (length expected)
when (s /= expected) $ do
fail ("expected string " <> show expected <> " but got " <> show s)
-- | Write a store directory and path into a Put monad.
putStorePath :: NixStoreDir -> StorePath -> Put
putStorePath sd sp = putNS $ NarString $ B8.pack $ spToFull sd sp
-- | Magic constant at the beginning of an export.
magicExportStartConstant :: ByteString
magicExportStartConstant = B.pack (1 : replicate 7 0)
-- | Magic constant to indicate start of export metadata.
magicExportMetadataConstant :: ByteString
magicExportMetadataConstant = "NIXE" <> B.pack (replicate 4 0)
-- | Parse a nar string into a store directory and store path.
getStorePath :: Get (NixStoreDir, StorePath)
getStorePath = do
NarString s <- get
case parseFullStorePath (decodeUtf8 s) of
Left err -> fail err
Right (sd, sp) -> pure (sd, sp)
instance BINARY_CLASS NarElement where
put element = inParens internal where
inParens p = putNS "(" *> p *> putNS ")"
internal = case element of
NarSymLink target -> do
mapM_ putNS ["type", "symlink", "target", NarString target]
NarFile exec contents -> do
mapM_ putNS ["type", "regular"]
when (exec == Executable) $ do
mapM_ putNS ["executable", ""]
mapM_ putNS ["contents", NarString contents]
NarDirectory elements -> do
mapM_ putNS ["type", "directory"]
forM_ (sortOn fst $ H.toList elements) $ \(name, element) -> do
putNS "entry"
inParens $ do
mapM_ putNS ["name", NarString name, "node"]
put element
get = label "NarElement" $ inParens element where
inParens p = label "openParens" (getExactNS "(") *> p
<* label "closeParens" (getExactNS ")")
try' getter = lookAhead getter >> getter
many_ p results = (p >>= \result -> many_ p (result:results))
<|> pure results
getDir = H.fromList <$> many_ entry [] where
entry = do
try' (getExactNS "entry")
inParens $ do
NarString name <- getExactNS "name" *> get
element <- getExactNS "node" *> get
pure (name, element)
element = do
getExactNS "type"
get >>= \case
"directory" -> NarDirectory <$> getDir
"symlink" -> NarSymLink <$> (getExactNS "target" *> getSomeNS)
"regular" -> do
isExecutable <- do
(try' (mapM getExactNS ["executable", ""]) *> pure Executable)
<|> pure NotExecutable
NarFile isExecutable <$> (getExactNS "contents" *> getSomeNS)
(t :: NarString) -> do
fail ("unsupported element type: " <> show t)
instance BINARY_CLASS Nar where
get = label "Nar" $ Nar <$> (getExactNS "nix-archive-1" *> get)
put (Nar elem) = putNS "nix-archive-1" >> put elem
instance BINARY_CLASS NarExport where
put export = do
let NarMetadata {..} = neMetadata export
-- Write the NAR surrounded by constants
putByteString magicExportStartConstant
put (neNar export)
putByteString magicExportMetadataConstant
-- Write the store path
put (NarString $ B8.pack $ spToFull nmStoreDirectory nmStorePath)
-- Write the references
put (NarInt $ length nmReferences)
forM (sort $ HS.toList nmReferences) $ \sp -> do
put (NarString $ B8.pack $ spToFull nmStoreDirectory sp)
-- If there's a deriver, write it. Otherwise an empty string
put $ case nmDeriver of
Nothing -> ""
Just sp -> NarString $ B8.pack $ spToFull nmStoreDirectory sp
-- If no signature, put 0, else 1 and then the signature
case nmSignature of
Nothing -> put (NarInt 0)
Just (Signature sig) -> put (NarInt 1) *> put (NarString sig)
-- The end of the export is eight zeroes
putByteString $ B.replicate 8 0
get = do
-- Read the NAR surrounded by constants
getThisByteString magicExportStartConstant
neNar <- get
getThisByteString magicExportMetadataConstant
-- Get the store path of the exported object
(nmStoreDirectory, nmStorePath) <- getStorePath
-- Get the references
nmReferences <- HS.fromList <$> do
NarInt numReferences <- get
forM [0 .. (numReferences - 1)] $ \_ -> do
snd <$> getStorePath
-- Get the deriver (optional)
nmDeriver <- getSomeNS >>= \case
"" -> pure Nothing
raw -> case parseFullStorePath (decodeUtf8 raw) of
Left err -> fail err
Right (_, path) -> pure $ Just path
-- Get the signature (optional)
nmSignature <- get >>= \case
(0 :: NarInt) -> pure Nothing
1 -> Just . Signature <$> getSomeNS
n -> fail ("Expected either 0 or 1 before the signature, got " <> show n)
-- Consume the final 8 bytes
getByteString 8
pure $ NarExport neNar (NarMetadata {..})
-- Byte sequence that all xzips start with
xzMagicHeader :: BL.ByteString
xzMagicHeader = BL.pack [0xFD, 0x37, 0x7A, 0x58, 0x5A, 0x00]
-- Byte sequence that all gzips start with
gzMagicHeader :: BL.ByteString
gzMagicHeader = BL.pack [0x1f, 0x8b, 0x08]
data Uncompressed
= FromGZip BL.ByteString
| FromXZip BL.ByteString
| Wasn'tCompressed BL.ByteString
deriving (Show, Eq, Generic)
-- | Detect if the bytestring is compressed, and decompress it if so.
decompressIfCompressed :: BL.ByteString -> BL.ByteString
decompressIfCompressed bytes =
if BL.isPrefixOf xzMagicHeader bytes
then Lzma.decompress bytes
else if BL.isPrefixOf gzMagicHeader bytes
then GZip.decompress bytes
else bytes
runGet_ :: BINARY_CLASS a => BL.ByteString -> Either String a
#ifdef USE_CEREAL
runGet_ = runGetLazy get
#else
runGet_ bs = case runGetOrFail get bs of
Right (_, _, a) -> Right a
Left (_, _, err) -> Left err
#endif
runPut_ :: BINARY_CLASS a => a -> BL.ByteString
runPut_ = toLazyByteString . execPut . put
instance MimeRender OctetStream Nar where
mimeRender _ = runPut_
instance MimeUnrender OctetStream Nar where
mimeUnrender _ bs = runGet_ $ decompressIfCompressed bs
instance MimeRender OctetStream NarExport where
mimeRender _ = runPut_
instance MimeUnrender OctetStream NarExport where
mimeUnrender _ bs = runGet_ $ decompressIfCompressed bs