-- SPDX-License-Identifier: MPL-2.0

{- | NPY v1/v2/v3 and NPZ (ZIP32 directory, stored or raw-DEFLATE members).
Scalar fixed-width dtypes only: object/pickle, records, strings and ZIP64
directories are rejected. NumPy's small-file ZIP64 local headers are
accepted. Input budgets cover aggregate uncompressed bytes. Nothing is
extracted to disk, so archive names can never become filesystem paths.
Specifications: <https://numpy.org/doc/stable/reference/generated/numpy.lib.format.html>
and <https://pkware.cachefly.net/webdocs/casestudies/APPNOTE.TXT>.
-}
module HMath.Interchange.Numpy (encodeNpy, decodeNpy, encodeNpz, decodeNpz) where

import Control.Monad (foldM, replicateM, unless, when)
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits ((.&.))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import Data.Char (isDigit)
import Data.List (intercalate, nub, sortOn)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Word
import HMath.Interchange.Array
import HMath.Interchange.Binary
import HMath.Interchange.Compression
import Text.ParserCombinators.ReadP hiding (count)

descriptor :: DType -> String
descriptor :: DType -> String
descriptor DType
dt = case DType
dt of
    DType
Bool8 -> String
"b1"
    DType
I8 -> String
"i1"
    DType
U8 -> String
"u1"
    DType
I16 -> String
"i2"
    DType
U16 -> String
"u2"
    DType
I32 -> String
"i4"
    DType
U32 -> String
"u4"
    DType
I64 -> String
"i8"
    DType
U64 -> String
"u8"
    DType
F32 -> String
"f4"
    DType
F64 -> String
"f8"
    DType
C64 -> String
"c8"
    DType
C128 -> String
"c16"

{- | Given limits,physical C/F order,then Array, repack and write a NumPy NPY v1 payload
with explicit dtype/endian/shape. Oversized header/output or unsupported layout
conversion fails.
-}
encodeNpy :: Limits -> Order -> Array -> Either InterchangeError B.ByteString
encodeNpy :: Limits -> Order -> Array -> Either InterchangeError ByteString
encodeNpy Limits
lim Order
order Array
a = do
    packed <- Limits -> Endian -> Order -> Array -> Either InterchangeError Array
repack Limits
lim (Array -> Endian
arrayEndian Array
a) Order
order Array
a
    let marker =
            if DType -> Int
elementBytes (Array -> DType
arrayDType Array
a) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Char
'|' else if Array -> Endian
arrayEndian Array
a Endian -> Endian -> Bool
forall a. Eq a => a -> a -> Bool
== Endian
LittleEndian then Char
'<' else Char
'>'
        dims = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show (Array -> [Int]
arrayShape Array
a)
        shape = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
dims String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
dims Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"," else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
        header =
            String
"{'descr': '"
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
marker]
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ DType -> String
descriptor (Array -> DType
arrayDType Array
a)
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"', 'fortran_order': "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Order
order Order -> Order -> Bool
forall a. Eq a => a -> a -> Bool
== Order
FOrder then String
"True" else String
"False")
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", 'shape': "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
shape
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", }"
        padding = (Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
header Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
64) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
64
        h = String -> ByteString
C.pack (String
header String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
padding Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
    guardI (B.length h <= 65535 && B.length h <= maxMetadata lim) (LimitExceeded "NPY header")
    guardI
        (toInteger (B.length h) + 10 + toInteger (B.length (arrayBytes packed)) <= toInteger (maxBytes lim))
        (LimitExceeded "NPY output bytes")
    Right
        ( L.toStrict
            ( runPut
                ( putByteString (B.pack [147, 78, 85, 77, 80, 89, 1, 0])
                    >> putWord16le (fromIntegral (B.length h))
                    >> putByteString h
                    >> putByteString (arrayBytes packed)
                )
            )
        )

data HeaderValue = Descr String | Fortran Bool | Shape [Integer] deriving (Int -> HeaderValue -> String -> String
[HeaderValue] -> String -> String
HeaderValue -> String
(Int -> HeaderValue -> String -> String)
-> (HeaderValue -> String)
-> ([HeaderValue] -> String -> String)
-> Show HeaderValue
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> HeaderValue -> String -> String
showsPrec :: Int -> HeaderValue -> String -> String
$cshow :: HeaderValue -> String
show :: HeaderValue -> String
$cshowList :: [HeaderValue] -> String -> String
showList :: [HeaderValue] -> String -> String
Show)

-- ReadP parses a deliberately tiny Python-literal grammar, never eval/Read.
-- Every lexical token is bounded by the already-validated header length.
headerParser :: ReadP [(String, HeaderValue)]
headerParser :: ReadP [(String, HeaderValue)]
headerParser = ReadP Char -> ReadP Char
forall {a}. ReadP a -> ReadP a
lexeme (Char -> ReadP Char
char Char
'{') ReadP Char
-> ReadP [(String, HeaderValue)] -> ReadP [(String, HeaderValue)]
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP (String, HeaderValue)
-> ReadP Char -> ReadP [(String, HeaderValue)]
forall {a} {a}. ReadP a -> ReadP a -> ReadP [a]
sepEndBy ReadP (String, HeaderValue)
field (ReadP Char -> ReadP Char
forall {a}. ReadP a -> ReadP a
lexeme (Char -> ReadP Char
char Char
',')) ReadP [(String, HeaderValue)]
-> ReadP Char -> ReadP [(String, HeaderValue)]
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP Char -> ReadP Char
forall {a}. ReadP a -> ReadP a
lexeme (Char -> ReadP Char
char Char
'}') ReadP [(String, HeaderValue)]
-> ReadP () -> ReadP [(String, HeaderValue)]
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
eof
  where
    lexeme :: ReadP a -> ReadP a
lexeme ReadP a
p = ReadP a
p ReadP a -> ReadP () -> ReadP a
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces
    quoted :: ReadP String
quoted = ReadP String -> ReadP String
forall {a}. ReadP a -> ReadP a
lexeme (ReadP String -> ReadP String) -> ReadP String -> ReadP String
forall a b. (a -> b) -> a -> b
$ do
        q <- (Char -> Bool) -> ReadP Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')
        s <- munch (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
q Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\')
        _ <- char q
        pure s
    field :: ReadP (String, HeaderValue)
field = do
        key <- ReadP String
quoted
        _ <- lexeme (char ':')
        value <- case key of
            String
"descr" -> String -> HeaderValue
Descr (String -> HeaderValue) -> ReadP String -> ReadP HeaderValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
quoted
            String
"fortran_order" -> Bool -> HeaderValue
Fortran (Bool -> HeaderValue) -> ReadP Bool -> ReadP HeaderValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Bool -> ReadP Bool
forall {a}. ReadP a -> ReadP a
lexeme ((Bool
True Bool -> ReadP String -> ReadP Bool
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"True") ReadP Bool -> ReadP Bool -> ReadP Bool
forall a. ReadP a -> ReadP a -> ReadP a
<++ (Bool
False Bool -> ReadP String -> ReadP Bool
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string String
"False"))
            String
"shape" -> [Integer] -> HeaderValue
Shape ([Integer] -> HeaderValue) -> ReadP [Integer] -> ReadP HeaderValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadP Char -> ReadP Char
forall {a}. ReadP a -> ReadP a
lexeme (Char -> ReadP Char
char Char
'(') ReadP Char -> ReadP [Integer] -> ReadP [Integer]
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP Integer -> ReadP Char -> ReadP [Integer]
forall {a} {a}. ReadP a -> ReadP a -> ReadP [a]
sepEndBy ReadP Integer
integer (ReadP Char -> ReadP Char
forall {a}. ReadP a -> ReadP a
lexeme (Char -> ReadP Char
char Char
',')) ReadP [Integer] -> ReadP Char -> ReadP [Integer]
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP Char -> ReadP Char
forall {a}. ReadP a -> ReadP a
lexeme (Char -> ReadP Char
char Char
')'))
            String
_ -> ReadP HeaderValue
forall a. ReadP a
pfail
        pure (key, value)
    integer :: ReadP Integer
integer = ReadP Integer -> ReadP Integer
forall {a}. ReadP a -> ReadP a
lexeme (ReadP Integer -> ReadP Integer) -> ReadP Integer -> ReadP Integer
forall a b. (a -> b) -> a -> b
$ do
        digits <- (Char -> Bool) -> ReadP String
munch1 Char -> Bool
isDigit
        if length digits <= 20 then pure (read digits) else pfail
    sepEndBy :: ReadP a -> ReadP a -> ReadP [a]
sepEndBy ReadP a
p ReadP a
separator =
        ( do
            x <- ReadP a
p
            xs <- many (separator *> p)
            _ <- option Nothing (Just <$> separator)
            pure (x : xs)
        )
            ReadP [a] -> ReadP [a] -> ReadP [a]
forall a. ReadP a -> ReadP a -> ReadP a
<++ [a] -> ReadP [a]
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

{- | Given limits then NPY bytes, decode supported v1/v2/v3 fixed-width scalar dtype arrays.
Reject pickle/object/record/string dtypes, malformed headers, unknown endian/layout,
trailing bytes or exceeded budgets.
-}
decodeNpy :: Limits -> B.ByteString -> Either InterchangeError Array
decodeNpy :: Limits -> ByteString -> Either InterchangeError Array
decodeNpy Limits
lim ByteString
input = do
    Limits -> Either InterchangeError ()
checkLimits Limits
lim
    Bool -> InterchangeError -> Either InterchangeError ()
guardI (ByteString -> Int
B.length ByteString
input Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Limits -> Int
maxBytes Limits
lim) (String -> InterchangeError
LimitExceeded String
"NPY input bytes")
    (header, payload) <- Get (ByteString, ByteString)
-> ByteString -> Either InterchangeError (ByteString, ByteString)
forall a. Get a -> ByteString -> Either InterchangeError a
runDecoder Get (ByteString, ByteString)
parser ByteString
input
    headerString <-
        either (const (Left (InvalidData "invalid NPY UTF-8"))) (Right . T.unpack) (E.decodeUtf8' header)
    fields <- case readP_to_S (skipSpaces *> headerParser) headerString of
        [([(String, HeaderValue)]
x, String
"")] -> [(String, HeaderValue)]
-> Either InterchangeError [(String, HeaderValue)]
forall a b. b -> Either a b
Right [(String, HeaderValue)]
x
        [([(String, HeaderValue)], String)]
_ -> InterchangeError -> Either InterchangeError [(String, HeaderValue)]
forall a b. a -> Either a b
Left (String -> InterchangeError
InvalidData String
"invalid NPY literal header")
    guardI (length fields == 3 && length (nub (map fst fields)) == 3) (InvalidData "NPY header keys")
    (desc, order, sh) <- case (lookup "descr" fields, lookup "fortran_order" fields, lookup "shape" fields) of
        (Just (Descr String
d), Just (Fortran Bool
f), Just (Shape [Integer]
dims)) -> do
            shape <- (Integer -> Either InterchangeError Int)
-> [Integer] -> Either InterchangeError [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Integer -> Integer -> Either InterchangeError Int
boundedInt String
"NPY dimension" (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int))) [Integer]
dims
            Right (d, if f then FOrder else COrder, shape)
        (Maybe HeaderValue, Maybe HeaderValue, Maybe HeaderValue)
_ -> InterchangeError -> Either InterchangeError (String, Order, [Int])
forall a b. a -> Either a b
Left (String -> InterchangeError
InvalidData String
"NPY required header fields")
    (dt, en) <- case desc of
        Char
marker : String
dtype -> do
            dt <-
                Either InterchangeError DType
-> (DType -> Either InterchangeError DType)
-> Maybe DType
-> Either InterchangeError DType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                    (InterchangeError -> Either InterchangeError DType
forall a b. a -> Either a b
Left (String -> InterchangeError
Unsupported String
"NPY scalar dtype"))
                    DType -> Either InterchangeError DType
forall a b. b -> Either a b
Right
                    (String -> [(String, DType)] -> Maybe DType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
dtype [(DType -> String
descriptor DType
t, DType
t) | DType
t <- [DType
forall a. Bounded a => a
minBound .. DType
forall a. Bounded a => a
maxBound]])
            en <- case marker of
                Char
'<' -> Endian -> Either InterchangeError Endian
forall a b. b -> Either a b
Right Endian
LittleEndian
                Char
'>' -> Endian -> Either InterchangeError Endian
forall a b. b -> Either a b
Right Endian
BigEndian
                Char
'|' | DType -> Int
elementBytes DType
dt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Endian -> Either InterchangeError Endian
forall a b. b -> Either a b
Right Endian
LittleEndian
                Char
_ -> InterchangeError -> Either InterchangeError Endian
forall a b. a -> Either a b
Left (String -> InterchangeError
Unsupported String
"NPY requires explicit endian")
            Right (dt, en)
        String
_ -> InterchangeError -> Either InterchangeError (DType, Endian)
forall a b. a -> Either a b
Left (String -> InterchangeError
InvalidData String
"empty NPY descriptor")
    contiguousArray lim dt en order sh payload
  where
    parser :: Get (ByteString, ByteString)
parser = do
        magic <- Int -> Get ByteString
getByteString Int
6
        unless (magic == B.pack [147, 78, 85, 77, 80, 89]) (fail "NPY magic")
        major <- getWord8
        minor <- getWord8
        unless (minor == 0 && major `elem` [1, 2, 3]) (fail "unsupported NPY version")
        len <- if major == 1 then fromIntegral <$> getWord16le else getWord32le
        when (toInteger len > toInteger (maxMetadata lim)) (fail "NPY header budget")
        h <- getByteString (fromIntegral len)
        unless (not (B.null h) && B.last h == 10) (fail "NPY header newline")
        -- Older NPY writers align to 16 rather than modern NumPy's 64 bytes.
        unless
            ((fromIntegral len + (if major == 1 then 10 else 12) :: Integer) `mod` 16 == 0)
            (fail "NPY alignment")
        unless (major == 3 || B.all (< 128) h) (fail "non-ASCII NPY v1/v2 header")
        p <- L.toStrict <$> getRemainingLazyByteString
        pure (h, p)

-- ZIP central-directory metadata, validated before touching a member.
data Entry = Entry B.ByteString Word16 Word16 Word32 Int Int Int deriving (Int -> Entry -> String -> String
[Entry] -> String -> String
Entry -> String
(Int -> Entry -> String -> String)
-> (Entry -> String) -> ([Entry] -> String -> String) -> Show Entry
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Entry -> String -> String
showsPrec :: Int -> Entry -> String -> String
$cshow :: Entry -> String
show :: Entry -> String
$cshowList :: [Entry] -> String -> String
showList :: [Entry] -> String -> String
Show)
entryName :: Entry -> B.ByteString
entryName :: Entry -> ByteString
entryName (Entry ByteString
n Word16
_ Word16
_ Word32
_ Int
_ Int
_ Int
_) = ByteString
n
entrySize :: Entry -> Int
entrySize :: Entry -> Int
entrySize (Entry ByteString
_ Word16
_ Word16
_ Word32
_ Int
_ Int
n Int
_) = Int
n
entryOffset :: Entry -> Int
entryOffset :: Entry -> Int
entryOffset (Entry ByteString
_ Word16
_ Word16
_ Word32
_ Int
_ Int
_ Int
n) = Int
n

{- | Deterministic archives, DOS epoch timestamps and no ZIP comments. True
selects raw DEFLATE and requires the optional zlib build feature.
-}
encodeNpz :: Limits -> Bool -> [(String, Array)] -> IO (Either InterchangeError B.ByteString)
encodeNpz :: Limits
-> Bool
-> [(String, Array)]
-> IO (Either InterchangeError ByteString)
encodeNpz Limits
lim Bool
compressed [(String, Array)]
arrays = case Either InterchangeError [(ByteString, ByteString)]
validate of
    Left InterchangeError
err -> Either InterchangeError ByteString
-> IO (Either InterchangeError ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterchangeError -> Either InterchangeError ByteString
forall a b. a -> Either a b
Left InterchangeError
err)
    Right [(ByteString, ByteString)]
encoded -> do
        results <- ((ByteString, ByteString)
 -> IO
      (Either InterchangeError (ByteString, ByteString, ByteString)))
-> [(ByteString, ByteString)]
-> IO
     [Either InterchangeError (ByteString, ByteString, ByteString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ByteString, ByteString)
-> IO
     (Either InterchangeError (ByteString, ByteString, ByteString))
forall {a}.
(a, ByteString)
-> IO (Either InterchangeError (a, ByteString, ByteString))
pack [(ByteString, ByteString)]
encoded
        pure $ do
            members <- sequence results
            -- Check lengths before constructing any ZIP record buffers.
            let recordSizes = [Integer
30 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
B.length ByteString
name) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
B.length ByteString
payload) | (ByteString
name, ByteString
_, ByteString
payload) <- [(ByteString, ByteString, ByteString)]
members]
                directorySize = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
46 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
B.length ByteString
name) | (ByteString
name, ByteString
_, ByteString
_) <- [(ByteString, ByteString, ByteString)]
members]
                total = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
recordSizes Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
directorySize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
22
            guardI
                (total <= toInteger (maxBytes lim) && total < 4294967295)
                (LimitExceeded "NPZ archive output")
            let localRecords = ((ByteString, ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString, ByteString) -> ByteString
local [(ByteString, ByteString, ByteString)]
members
                positions = (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int
0 :: Int) ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a. Num a => Integer -> a
fromInteger [Integer]
recordSizes)
                directory = [ByteString] -> ByteString
B.concat (((ByteString, ByteString, ByteString) -> Int -> ByteString)
-> [(ByteString, ByteString, ByteString)] -> [Int] -> [ByteString]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ByteString, ByteString, ByteString) -> Int -> ByteString
forall {a}.
Integral a =>
(ByteString, ByteString, ByteString) -> a -> ByteString
central [(ByteString, ByteString, ByteString)]
members [Int]
positions)
                start = Integer -> Int
forall a. Num a => Integer -> a
fromInteger ([Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
recordSizes) :: Int
            Right
                ( B.concat localRecords
                    <> directory
                    <> L.toStrict
                        ( runPut $ do
                            putWord32le 0x06054b50
                            putWord16le 0
                            putWord16le 0
                            putWord16le (fromIntegral (length members))
                            putWord16le (fromIntegral (length members))
                            putWord32le (fromIntegral (B.length directory))
                            putWord32le (fromIntegral start)
                            putWord16le 0
                        )
                )
  where
    validate :: Either InterchangeError [(ByteString, ByteString)]
validate = do
        Limits -> Either InterchangeError ()
checkLimits Limits
lim
        Bool -> InterchangeError -> Either InterchangeError ()
guardI
            ([(String, Array)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> [(String, Array)] -> [(String, Array)]
forall a. Int -> [a] -> [a]
take (Limits -> Int
maxArchiveEntries Limits
lim Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(String, Array)]
arrays) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Limits -> Int
maxArchiveEntries Limits
lim Bool -> Bool -> Bool
&& [(String, Array)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Array)]
arrays Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
65535)
            (String -> InterchangeError
LimitExceeded String
"archive member count")
        -- Validate bounded Unicode names before comparing them, then consume
        -- a shared budget incrementally. Encoding all members first could
        -- allocate maxArchiveEntries * maxBytes before rejecting an archive.
        names <- ((String, Array) -> Either InterchangeError ByteString)
-> [(String, Array)] -> Either InterchangeError [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Either InterchangeError ByteString
archiveName (String -> Either InterchangeError ByteString)
-> ((String, Array) -> String)
-> (String, Array)
-> Either InterchangeError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Array) -> String
forall a b. (a, b) -> a
fst) [(String, Array)]
arrays
        guardI (length (nub names) == length names) (InvalidData "duplicate NPZ name")
        let overhead = Integer
22 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
76 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
B.length ByteString
name) | ByteString
name <- [ByteString]
names]
        guardI (overhead <= toInteger (maxBytes lim)) (LimitExceeded "NPZ metadata bytes")
        (_, encoded) <-
            foldM encodeMember (maxBytes lim - fromInteger overhead, []) (zip names (map snd arrays))
        Right (reverse encoded)
    encodeMember :: (Int, [(a, ByteString)])
-> (a, Array) -> Either InterchangeError (Int, [(a, ByteString)])
encodeMember (Int
budget, [(a, ByteString)]
encoded) (a
name, Array
a) = do
        bytes <- Limits -> Order -> Array -> Either InterchangeError ByteString
encodeNpy (Limits
lim{maxBytes = budget}) Order
COrder Array
a
        Right (budget - B.length bytes, (name, bytes) : encoded)
    pack :: (a, ByteString)
-> IO (Either InterchangeError (a, ByteString, ByteString))
pack (a
name, ByteString
bytes) = do
        content <- if Bool
compressed then Limits
-> Compression
-> ByteString
-> IO (Either InterchangeError ByteString)
compress Limits
lim Compression
RawDeflate ByteString
bytes else Either InterchangeError ByteString
-> IO (Either InterchangeError ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either InterchangeError ByteString
forall a b. b -> Either a b
Right ByteString
bytes)
        pure ((\ByteString
p -> (a
name, ByteString
bytes, ByteString
p)) <$> content)
    method :: Word16
method = if Bool
compressed then Word16
8 else Word16
0
    local :: (ByteString, ByteString, ByteString) -> ByteString
local (ByteString
name, ByteString
bytes, ByteString
payload) =
        LazyByteString -> ByteString
L.toStrict
            ( Put -> LazyByteString
runPut (Put -> LazyByteString) -> Put -> LazyByteString
forall a b. (a -> b) -> a -> b
$ do
                Word32 -> Put
putWord32le Word32
0x04034b50
                Word16 -> Put
putWord16le Word16
20
                Word16 -> Put
putWord16le Word16
0x800
                Word16 -> Put
putWord16le Word16
method
                Word16 -> Put
putWord16le Word16
0
                Word16 -> Put
putWord16le Word16
33
                Word32 -> Put
putWord32le (ByteString -> Word32
crc32 ByteString
bytes)
                Word32 -> Put
putWord32le (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
payload))
                Word32 -> Put
putWord32le (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bytes))
                Word16 -> Put
putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
name))
                Word16 -> Put
putWord16le Word16
0
                ByteString -> Put
putByteString ByteString
name
                ByteString -> Put
putByteString ByteString
payload
            )
    central :: (ByteString, ByteString, ByteString) -> a -> ByteString
central (ByteString
name, ByteString
bytes, ByteString
payload) a
offset =
        LazyByteString -> ByteString
L.toStrict
            ( Put -> LazyByteString
runPut (Put -> LazyByteString) -> Put -> LazyByteString
forall a b. (a -> b) -> a -> b
$ do
                Word32 -> Put
putWord32le Word32
0x02014b50
                Word16 -> Put
putWord16le Word16
20
                Word16 -> Put
putWord16le Word16
20
                Word16 -> Put
putWord16le Word16
0x800
                Word16 -> Put
putWord16le Word16
method
                Word16 -> Put
putWord16le Word16
0
                Word16 -> Put
putWord16le Word16
33
                Word32 -> Put
putWord32le (ByteString -> Word32
crc32 ByteString
bytes)
                Word32 -> Put
putWord32le (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
payload))
                Word32 -> Put
putWord32le (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bytes))
                Word16 -> Put
putWord16le (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
name))
                Word16 -> Put
putWord16le Word16
0
                Word16 -> Put
putWord16le Word16
0
                Word16 -> Put
putWord16le Word16
0
                Word16 -> Put
putWord16le Word16
0
                Word32 -> Put
putWord32le Word32
0
                Word32 -> Put
putWord32le (a -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
offset)
                ByteString -> Put
putByteString ByteString
name
            )

archiveName :: String -> Either InterchangeError B.ByteString
archiveName :: String -> Either InterchangeError ByteString
archiveName String
name = do
    Bool -> InterchangeError -> Either InterchangeError ()
guardI
        ( Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name)
            Bool -> Bool -> Bool
&& String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1025 String
name) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1024
            Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\xD800' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
> Char
'\xDFFF')) String
name
            Bool -> Bool -> Bool
&& String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"."
            Bool -> Bool -> Bool
&& String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
".."
        )
        (String -> InterchangeError
InvalidData String
"NPZ key must be a nonempty flat name")
    let encoded :: ByteString
encoded = Text -> ByteString
E.encodeUtf8 (String -> Text
T.pack (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".npy"))
    Bool -> InterchangeError -> Either InterchangeError ()
guardI (ByteString -> Int
B.length ByteString
encoded Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
65535) (String -> InterchangeError
LimitExceeded String
"NPZ member name")
    ByteString -> Either InterchangeError ByteString
forall a b. b -> Either a b
Right ByteString
encoded

{- | Checks directory/local consistency, CRC, exact deflate length, duplicate
names, overlapping member ranges and aggregate expanded bytes. Data
descriptors/encryption/multi-disk/ZIP64 directories are explicitly rejected.
-}
decodeNpz :: Limits -> B.ByteString -> IO (Either InterchangeError [(String, Array)])
decodeNpz :: Limits
-> ByteString -> IO (Either InterchangeError [(String, Array)])
decodeNpz Limits
lim ByteString
input = case Either InterchangeError [(Entry, String, ByteString, Int)]
directory of
    Left InterchangeError
err -> Either InterchangeError [(String, Array)]
-> IO (Either InterchangeError [(String, Array)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterchangeError -> Either InterchangeError [(String, Array)]
forall a b. a -> Either a b
Left InterchangeError
err)
    Right [(Entry, String, ByteString, Int)]
members -> ([Either InterchangeError (String, Array)]
 -> Either InterchangeError [(String, Array)])
-> IO [Either InterchangeError (String, Array)]
-> IO (Either InterchangeError [(String, Array)])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either InterchangeError (String, Array)]
-> Either InterchangeError [(String, Array)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (((Entry, String, ByteString, Int)
 -> IO (Either InterchangeError (String, Array)))
-> [(Entry, String, ByteString, Int)]
-> IO [Either InterchangeError (String, Array)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Entry, String, ByteString, Int)
-> IO (Either InterchangeError (String, Array))
forall {a} {d}.
(Entry, a, ByteString, d)
-> IO (Either InterchangeError (a, Array))
unpack [(Entry, String, ByteString, Int)]
members)
  where
    directory :: Either InterchangeError [(Entry, String, ByteString, Int)]
directory = do
        Limits -> Either InterchangeError ()
checkLimits Limits
lim
        Bool -> InterchangeError -> Either InterchangeError ()
guardI (ByteString -> Int
B.length ByteString
input Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Limits -> Int
maxBytes Limits
lim Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
input Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
22) (String -> InterchangeError
LimitExceeded String
"NPZ input size")
        end <- case [ Int
i
                    | Int
i <- [ByteString -> Int
B.length ByteString
input Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
22, ByteString -> Int
B.length ByteString
input Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
23 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (ByteString -> Int
B.length ByteString
input Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
65557)]
                    , Int -> ByteString -> ByteString
B.take Int
4 (Int -> ByteString -> ByteString
B.drop Int
i ByteString
input) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== [Word8] -> ByteString
B.pack [Word8
80, Word8
75, Word8
5, Word8
6]
                    , let tailBytes :: ByteString
tailBytes = Int -> ByteString -> ByteString
B.drop Int
i ByteString
input
                    , ByteString -> Int
B.length ByteString
tailBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
22
                    , Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
tailBytes Int
20) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
tailBytes Int
21)
                        Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
B.length ByteString
tailBytes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
22
                    ] of
            Int
i : [Int]
_ -> Int -> Either InterchangeError Int
forall a b. b -> Either a b
Right Int
i
            [Int]
_ -> InterchangeError -> Either InterchangeError Int
forall a b. a -> Either a b
Left (String -> InterchangeError
InvalidData String
"ZIP end directory missing")
        (count, start, size) <- runDecoder endParser (B.drop end input)
        guardI (toInteger start + toInteger size == toInteger end) (InvalidData "central directory extent")
        entries <- runDecoder (replicateM count entryParser) (B.take size (B.drop start input))
        guardI
            (length (nub (map entryName entries)) == length entries)
            (InvalidData "duplicate archive member name")
        guardI
            (sum (map (toInteger . entrySize) entries) <= toInteger (maxBytes lim))
            (LimitExceeded "aggregate expanded bytes")
        members <- mapM (member start) entries
        let intervals = ((Int, Int) -> Int) -> [(Int, Int)] -> [(Int, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, Int) -> Int
forall a b. (a, b) -> a
fst [(Entry -> Int
entryOffset Entry
e, Int
z) | (Entry
e, String
_, ByteString
_, Int
z) <- [(Entry, String, ByteString, Int)]
members]
        guardI
            (and (zipWith (\(Int
_, Int
endOffset) (Int
next, Int
_) -> Int
endOffset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
next) intervals (drop 1 intervals)))
            (InvalidData "overlapping ZIP members")
        Right members
    endParser :: Get (Int, Int, Int)
endParser = do
        Word32 -> Get ()
signature Word32
0x06054b50
        disk <- Get Word16
getWord16le
        directoryDisk <- getWord16le
        countDisk <- getWord16le
        count <- getWord16le
        unless
            (disk == 0 && directoryDisk == 0 && countDisk == count && count /= 65535)
            (fail "multi-disk/ZIP64 not supported")
        when (fromIntegral count > maxArchiveEntries lim) (fail "archive entry budget")
        size <- size32
        start <- size32
        comment <- getWord16le
        _ <- getByteString (fromIntegral comment)
        pure (fromIntegral count, start, size)
    signature :: Word32 -> Get ()
signature Word32
expected = do
        actual <- Get Word32
getWord32le
        unless (actual == expected) (fail "ZIP signature")
    size32 :: Get Int
size32 = do
        x <- Get Word32
getWord32le
        when (toInteger x > toInteger (maxBytes lim)) (fail "ZIP size budget")
        pure (fromIntegral x)
    entryParser :: Get Entry
entryParser = do
        Word32 -> Get ()
signature Word32
0x02014b50
        _ <- Get Word16
getWord16le
        version <- getWord16le
        flags <- getWord16le
        method <- getWord16le
        unless
            (version <= 45 && flags .&. 0xf7ff == 0 && method `elem` [0, 8])
            (fail "unsupported ZIP flags/method/version")
        _ <- getWord16le
        _ <- getWord16le
        checksum <- getWord32le
        compressed <- size32
        expanded <- size32
        nl <- getWord16le
        el <- getWord16le
        cl <- getWord16le
        disk <- getWord16le
        _ <- getWord16le
        _ <- getWord32le
        offset <- size32
        unless (disk == 0) (fail "multi-disk member")
        name <- getByteString (fromIntegral nl)
        extra <- getByteString (fromIntegral el)
        _ <- getByteString (fromIntegral cl)
        _ <- either (fail . show) pure (runDecoder extras extra)
        pure (Entry name flags method checksum compressed expanded offset)
    extras :: Get [(Word16, ByteString)]
extras = do
        empty <- Get Bool
isEmpty
        if empty
            then pure []
            else do
                ident <- getWord16le
                len <- getWord16le
                bytes <- getByteString (fromIntegral len)
                ((ident, bytes) :) <$> extras
    member :: Int
-> Entry
-> Either InterchangeError (Entry, String, ByteString, Int)
member Int
directoryStart entry :: Entry
entry@(Entry ByteString
name Word16
flags Word16
method Word32
checksum Int
compressed Int
expanded Int
offset) = do
        Bool -> InterchangeError -> Either InterchangeError ()
guardI (Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
directoryStart) (String -> InterchangeError
InvalidData String
"local header offset")
        (payloadStart, len) <-
            Get (Int, Int) -> ByteString -> Either InterchangeError (Int, Int)
forall a. Get a -> ByteString -> Either InterchangeError a
runDecoder
                ( do
                    Word32 -> Get ()
signature Word32
0x04034b50
                    _ <- Get Word16
getWord16le
                    f <- getWord16le
                    m <- getWord16le
                    unless (f == flags && m == method) (fail "local/directory flags mismatch")
                    _ <- getWord16le
                    _ <- getWord16le
                    c <- getWord32le
                    cs <- getWord32le
                    us <- getWord32le
                    nl <- getWord16le
                    el <- getWord16le
                    n <- getByteString (fromIntegral nl)
                    e <- getByteString (fromIntegral el)
                    unless (n == name && c == checksum) (fail "local/directory name or CRC mismatch")
                    extra <- either (fail . show) pure (runDecoder extras e)
                    (actualU, actualC) <-
                        if us == 0xffffffff || cs == 0xffffffff
                            then case lookup 1 extra of
                                Maybe ByteString
Nothing -> String -> Get (Word64, Word64)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"missing ZIP64 local sizes"
                                Just ByteString
bytes ->
                                    (InterchangeError -> Get (Word64, Word64))
-> ((Word64, Word64) -> Get (Word64, Word64))
-> Either InterchangeError (Word64, Word64)
-> Get (Word64, Word64)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                                        (String -> Get (Word64, Word64)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (Word64, Word64))
-> (InterchangeError -> String)
-> InterchangeError
-> Get (Word64, Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterchangeError -> String
forall a. Show a => a -> String
show)
                                        (Word64, Word64) -> Get (Word64, Word64)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                        ( Get (Word64, Word64)
-> ByteString -> Either InterchangeError (Word64, Word64)
forall a. Get a -> ByteString -> Either InterchangeError a
runDecoder
                                            ( (,)
                                                (Word64 -> Word64 -> (Word64, Word64))
-> Get Word64 -> Get (Word64 -> (Word64, Word64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (if Word32
us Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xffffffff then Get Word64
getWord64le else Word64 -> Get Word64
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
us))
                                                Get (Word64 -> (Word64, Word64))
-> Get Word64 -> Get (Word64, Word64)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (if Word32
cs Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xffffffff then Get Word64
getWord64le else Word64 -> Get Word64
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cs))
                                            )
                                            ByteString
bytes
                                        )
                            else pure (fromIntegral us, fromIntegral cs)
                    unless
                        (actualU == fromIntegral expanded && actualC == fromIntegral compressed)
                        (fail "local/directory size mismatch")
                    consumed <- bytesRead
                    _ <- getRemainingLazyByteString
                    pure (offset + fromIntegral consumed, compressed)
                )
                (Int -> ByteString -> ByteString
B.take (Int
directoryStart Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset) (Int -> ByteString -> ByteString
B.drop Int
offset ByteString
input))
        guardI
            (toInteger payloadStart + toInteger len <= toInteger directoryStart)
            (InvalidData "ZIP payload overlaps directory")
        str <-
            either
                (const (Left (InvalidData "invalid UTF-8 archive key")))
                (Right . T.unpack)
                (E.decodeUtf8' name)
        guardI
            (length str >= 4 && drop (length str - 4) str == ".npy")
            (Unsupported "NPZ member must end .npy")
        let key = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) String
str
        canonical <- archiveName key
        guardI (canonical == name) (InvalidData "noncanonical NPZ member name")
        Right (entry, key, B.take len (B.drop payloadStart input), payloadStart + len)
    unpack :: (Entry, a, ByteString, d)
-> IO (Either InterchangeError (a, Array))
unpack (Entry ByteString
_ Word16
_ Word16
method Word32
checksum Int
_ Int
expanded Int
_, a
key, ByteString
bytes, d
_) = do
        decoded <- if Word16
method Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0 then Either InterchangeError ByteString
-> IO (Either InterchangeError ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either InterchangeError ByteString
forall a b. b -> Either a b
Right ByteString
bytes) else Limits
-> Compression
-> Int
-> ByteString
-> IO (Either InterchangeError ByteString)
decompress Limits
lim Compression
RawDeflate Int
expanded ByteString
bytes
        pure $ do
            payload <- decoded
            guardI
                (B.length payload == expanded && crc32 payload == checksum)
                (InvalidData "ZIP uncompressed size/CRC mismatch")
            a <- decodeNpy lim payload
            Right (key, a)