diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +## 0.1.0 (2022-04-22) +Initial release. + + * extracted from gtvm-hs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2022 Ben Orchard (@raehik) + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +# binrep +Haskell data types with their binary representation explicitly built into the +types. Intended for simple binary file parsing. + +The binary and cereal libraries are for passing Haskell data between other +binary and cereal users. Thus, data representation is largely obscured. For +example, in `cereal`, all data is handled in big-endian format. If you use the +`Serialize` typeclass methods for parsing and serializing, you would never know. + +binrep never makes decisions by itself. You can't parse/serialize a `Word64` +without either providing the endianness to use at runtime, or encoding the +endianness into the type. + +See the Hackage documentation for details. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/binrep.cabal b/binrep.cabal new file mode 100644 --- /dev/null +++ b/binrep.cabal @@ -0,0 +1,81 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: binrep +version: 0.1.0 +synopsis: Encode binary representations via types. +description: Please see README.md. +category: Data +homepage: https://github.com/raehik/binrep#readme +bug-reports: https://github.com/raehik/binrep/issues +author: Ben Orchard +maintainer: Ben Orchard +license: MIT +license-file: LICENSE +build-type: Simple +tested-with: + GHC ==8.10.7 || ==9.2.2 +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/raehik/binrep + +library + exposed-modules: + Binrep.ByteLen + Binrep.Codec + Binrep.Predicates.NullPadTo + Binrep.Types.Ints + Binrep.Types.Strings + Binrep.Util + other-modules: + Paths_binrep + hs-source-dirs: + src + default-extensions: + EmptyCase + FlexibleContexts + FlexibleInstances + InstanceSigs + MultiParamTypeClasses + PolyKinds + LambdaCase + DerivingStrategies + StandaloneDeriving + DeriveAnyClass + DeriveGeneric + DeriveDataTypeable + DeriveFunctor + DeriveFoldable + DeriveTraversable + DeriveLift + ImportQualifiedPost + StandaloneKindSignatures + DerivingVia + RoleAnnotations + TypeApplications + DataKinds + TypeFamilies + TypeOperators + BangPatterns + GADTs + DefaultSignatures + RankNTypes + UndecidableInstances + MagicHash + ScopedTypeVariables + build-depends: + aeson ==2.0.* + , base >=4.14 && <5 + , bytestring ==0.11.* + , cereal >=0.5.8.1 && <0.6 + , refined >=0.6.3 && <0.7 + , refined-with >=0.1.0 && <0.2 + , text ==1.2.* + default-language: Haskell2010 diff --git a/src/Binrep/ByteLen.hs b/src/Binrep/ByteLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/ByteLen.hs @@ -0,0 +1,34 @@ +{- TODO +Potentially should be moved into BinaryCodec. We need this for padding-based +combinators. Each inside combinator must report the number of bytes they +serialized. It *should* be extremely cheap. + +So far I haven't got another use for it, and I feel there should be some better +way to define it but the types don't fit well. So I'll leave it as is for now. +-} + +module Binrep.ByteLen where + +import Numeric.Natural + +-- | The size in bytes of the type can be known, preferably on the cheap e.g. +-- reading a length field. +-- +-- Aim to make this O(1). Except for where you can't like lists lol. +-- +-- Importantly goes hand in hand with BinaryCodec! Maybe we should make it a +-- function there lol! +-- +-- This is useful for padding types generically, without having to track the +-- read/write cursor. Yes, that feature *is* common and cheap for parsers (and +-- to lesser extent, serializers), but you should really only be padding types +-- that have a "static-ish" (= cheaply calculated) size. At least, I think so? +-- I'm not quite sure. +-- +-- Some instances ignore the argument. It would be possible to pull those out +-- into a statically-known bytelength typeclass, but it wouldn't improve clarity +-- or performance, just get rid of a couple 'undefined's. +class ByteLen a where + blen :: a -> Natural + +instance ByteLen a => ByteLen [a] where blen = sum . map blen diff --git a/src/Binrep/Codec.hs b/src/Binrep/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Codec.hs @@ -0,0 +1,86 @@ +module Binrep.Codec where + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Builder qualified as B +import Data.Serialize + +-- | Types that can be coded precisely between binary and a Haskell type. +-- +-- This class looks identical to cereal's 'Serialize', but we take a different +-- approach to instances. +-- +-- 'Data.Serialize.Serialize' defines an internal binary codec for common +-- Haskell types. It makes implicit decisions, such as big-endian for all +-- integer types, and coding lists with a (big-endian) 'Word64' length prefix. +-- It only works with other data serialized with the same library. +-- +-- This typeclass defines composable binary codec combinators. If you want to +-- write a codec for a 'Word64', it needs to specify its endianness in the type. +-- If you want to write a codec for a list with a 'Word8' length prefix, it must +-- come with a proof that it's not oversized. +-- +-- The idea is to use this typeclass along with various annotated newtypes to +-- allow defining a Haskell type's binary representation directly in the types. +-- In cases where you're doing intermediate serialization and not much else, it +-- may be convenient. You will need to do a bunch of (free at runtime) wrapping +-- though. +class BinaryCodec a where + toBin :: Putter a -- ^ Encode to binary. Same as cereal's 'put'. + fromBin :: Get a -- ^ Decode from binary. Same as cereal's 'get'. + +-- | Run the encoder for a supporting type. +binEncode :: BinaryCodec a => a -> BS.ByteString +binEncode = runPut . toBin + +-- | Run the decoder a supporting type. +binDecode :: BinaryCodec a => BS.ByteString -> Either String a +binDecode = runGet fromBin + +-- | Serialize each element in order. No length indicator, so parse until either +-- error or EOF. Usually not what you want, but sometimes used at the "top" of +-- binary formats. +instance BinaryCodec a => BinaryCodec [a] where + toBin as = mapM_ toBin as + fromBin = go [] + where + go as = do + a <- fromBin + isEmpty >>= \case + True -> return $ reverse $ a : as + False -> go $ a : as + +-- | Types that can be coded between binary and a Haskell type given some +-- runtime information. +-- +-- We can't prove something related to a value and pass that proof along without +-- dependent types, meaning we can't split validation from encoding like in +-- 'BinaryCodec', so encoding can fail. However, by allowing an arbitrary +-- environment, we can define many more convenient instances. +-- +-- For example, you can't write a 'BinaryCodec' instance for 'Word16' because it +-- doesn't specify its endianness. But you can define 'BinaryCodecWith +-- Endianness Word16'! This was, you can decide how much of the binary schema +-- you want to place directly in the types, and how much to configure +-- dynamically. +-- +-- This class defaults to the free implementation provided by 'BinaryCodec', +-- which ignores the environment and wraps serializing with 'Right'. +class BinaryCodecWith r a where + -- | Encode to binary with the given environment. + toBinWith :: r -> a -> Either String B.Builder + default toBinWith :: BinaryCodec a => r -> a -> Either String B.Builder + toBinWith = const $ Right . execPut . toBin + + -- | Decode to binary with the given environment. + fromBinWith :: r -> Get a + default fromBinWith :: BinaryCodec a => r -> Get a + fromBinWith = const fromBin + +-- | Run the encoder for a supporting type using the given environment. +binEncodeWith :: BinaryCodecWith r a => r -> a -> Either String BS.ByteString +binEncodeWith r a = BL.toStrict . B.toLazyByteString <$> toBinWith r a + +-- | Run the decoder for a supporting type using the given environment. +binDecodeWith :: BinaryCodecWith r a => r -> BS.ByteString -> Either String a +binDecodeWith = runGet . fromBinWith diff --git a/src/Binrep/Predicates/NullPadTo.hs b/src/Binrep/Predicates/NullPadTo.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Predicates/NullPadTo.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Binrep.Predicates.NullPadTo where + +import Binrep.Codec +import Binrep.ByteLen +import Binrep.Util ( tshow ) +import Refined +import Refined.WithRefine +import Data.Serialize +import GHC.TypeNats +import Numeric.Natural +import GHC.Natural ( minusNaturalMaybe ) +import GHC.Exts ( proxy#, Proxy# ) +import Data.Typeable +import Data.ByteString qualified as BS + +data NullPadTo (n :: Nat) + +instance KnownNat n => ByteLen (WithRefine 'Enforced (NullPadTo n) a) where + blen = const n + where n = natVal' (proxy# :: Proxy# n) + +instance (ByteLen a, KnownNat n) => Predicate (NullPadTo n) a where + validate p a + | len > n + = throwRefineOtherException (typeRep p) $ + "too long: " <> tshow len <> " > " <> tshow n + | otherwise = success + where + n = natVal' (proxy# :: Proxy# n) + len = blen a + +-- | predicate is inherently enforced due to checking length to calculate how +-- many succeeding nulls to parse +-- +-- Note that the consumer probably doesn't care about the content of the +-- padding, just that the data is chunked correctly. I figure we care about +-- correctness here, so it'd be nice to know about the padding well-formedness +-- (i.e. that it's all nulls). +instance (BinaryCodec a, ByteLen a, KnownNat n) + => BinaryCodec (WithRefine 'Enforced (NullPadTo n) a) where + fromBin = do + a <- fromBin + let len = blen a + case minusNaturalMaybe n len of + Nothing -> fail $ "too long: " <> show len <> " > " <> show n + Just nullstrLen -> do + getNNulls nullstrLen + return $ reallyUnsafeEnforce a + where + n = natVal' (proxy# :: Proxy# n) + toBin wrnpa = do + let npa = unWithRefine wrnpa + toBin npa + let paddingLength = n - blen npa + putByteString $ BS.replicate (fromIntegral paddingLength) 0x00 + where + n = natVal' (proxy# :: Proxy# n) + +getNNulls :: Natural -> Get () +getNNulls = \case 0 -> return () + n -> getWord8 >>= \case + 0x00 -> getNNulls $ n-1 + nonNull -> do + offset <- bytesRead + fail $ "expected null, found: "<> show nonNull + <> " at offset " <> show offset + <> ", " <> show n <> " more nulls to go" diff --git a/src/Binrep/Types/Ints.hs b/src/Binrep/Types/Ints.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Types/Ints.hs @@ -0,0 +1,89 @@ +module Binrep.Types.Ints where + +import Binrep.Codec +import Binrep.ByteLen +import GHC.Generics ( Generic ) +import Data.Typeable +import Data.Word +import Data.Int +import Data.Aeson +import Data.Serialize + +-- | Wrapper type grouping machine integers (sign, size) along with an explicit +-- endianness. +newtype I (sign :: ISign) (size :: ISize) (e :: Endianness) + = I { getI :: IRep sign size } + deriving stock (Generic, Typeable) + +-- | Lots of deriving boilerplate due to the type family usage. +deriving stock instance Show (IRep sign size) => Show (I sign size e) +deriving via (IRep sign size) instance Eq (IRep sign size) => Eq (I sign size e) +deriving via (IRep sign size) instance Ord (IRep sign size) => Ord (I sign size e) +deriving via (IRep sign size) instance Bounded (IRep sign size) => Bounded (I sign size e) +deriving via (IRep sign size) instance Num (IRep sign size) => Num (I sign size e) +deriving via (IRep sign size) instance Real (IRep sign size) => Real (I sign size e) +deriving via (IRep sign size) instance Enum (IRep sign size) => Enum (I sign size e) +deriving via (IRep sign size) instance Integral (IRep sign size) => Integral (I sign size e) +deriving via (IRep sign size) instance ToJSON (IRep sign size) => ToJSON (I sign size e) +deriving via (IRep sign size) instance FromJSON (IRep sign size) => FromJSON (I sign size e) + +instance ByteLen (I s 'I1 e) where blen = const 1 +instance ByteLen (I s 'I2 e) where blen = const 2 +instance ByteLen (I s 'I4 e) where blen = const 4 +instance ByteLen (I s 'I8 e) where blen = const 8 + +-- | Endianness doesn't apply for single-byte machine integers. +instance BinaryCodec (I 'U 'I1 e) where toBin = putWord8 . getI + fromBin = I <$> getWord8 +instance BinaryCodec (I 'S 'I1 e) where toBin = putInt8 . getI + fromBin = I <$> getInt8 + +instance BinaryCodec (I 'U 'I2 'BE) where toBin = putWord16be . getI + fromBin = I <$> getWord16be +instance BinaryCodec (I 'U 'I2 'LE) where toBin = putWord16le . getI + fromBin = I <$> getWord16le +instance BinaryCodec (I 'S 'I2 'BE) where toBin = putInt16be . getI + fromBin = I <$> getInt16be +instance BinaryCodec (I 'S 'I2 'LE) where toBin = putInt16le . getI + fromBin = I <$> getInt16le + +instance BinaryCodec (I 'U 'I4 'BE) where toBin = putWord32be . getI + fromBin = I <$> getWord32be +instance BinaryCodec (I 'U 'I4 'LE) where toBin = putWord32le . getI + fromBin = I <$> getWord32le +instance BinaryCodec (I 'S 'I4 'BE) where toBin = putInt32be . getI + fromBin = I <$> getInt32be +instance BinaryCodec (I 'S 'I4 'LE) where toBin = putInt32le . getI + fromBin = I <$> getInt32le + +instance BinaryCodec (I 'U 'I8 'BE) where toBin = putWord64be . getI + fromBin = I <$> getWord64be +instance BinaryCodec (I 'U 'I8 'LE) where toBin = putWord64le . getI + fromBin = I <$> getWord64le +instance BinaryCodec (I 'S 'I8 'BE) where toBin = putInt64be . getI + fromBin = I <$> getInt64be +instance BinaryCodec (I 'S 'I8 'LE) where toBin = putInt64le . getI + fromBin = I <$> getInt64le + +-- | Byte order. +data Endianness + = BE -- ^ big endian, MSB first. e.g. most network protocols + | LE -- ^ little endian, MSB last. e.g. most processor architectures + +-- | Machine integer sign +data ISign + = S -- ^ signed + | U -- ^ unsigned + +-- | Machine integer size in number of bytes. +data ISize = I1 | I2 | I4 | I8 + +type family IRep (sign :: ISign) (size :: ISize) where + IRep 'U 'I1 = Word8 + IRep 'S 'I1 = Int8 + IRep 'U 'I2 = Word16 + IRep 'S 'I2 = Int16 + IRep 'U 'I4 = Word32 + IRep 'S 'I4 = Int32 + IRep 'U 'I8 = Word64 + IRep 'S 'I8 = Int64 diff --git a/src/Binrep/Types/Strings.hs b/src/Binrep/Types/Strings.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Types/Strings.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Binrep.Types.Strings where + +import Binrep.Codec +import Binrep.ByteLen +import Binrep.Types.Ints +import Binrep.Util +import Refined +import Refined.WithRefine +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Builder qualified as B +import Data.Serialize +import Data.Word +import Data.Typeable ( Typeable, typeRep ) +import Control.Monad ( replicateM ) + +-- | TODO +data StrRep = C | Pascal ISize Endianness + +-- | TODO +-- +-- We also use this as a predicate, because the 'Pascal' constructor looks +-- identical to what we would want for a @LengthPrefixed@ predicate. +newtype Str (rep :: StrRep) + = Str { getStr :: BS.ByteString } + +fromBinCString :: Get BS.ByteString +fromBinCString = go mempty + where go buf = do + getWord8 >>= \case + 0x00 -> return $ BL.toStrict $ B.toLazyByteString buf + nonNull -> go $ buf <> B.word8 nonNull + +instance ByteLen (Str 'C) where + blen cstr = fromIntegral $ BS.length (getStr cstr) + 1 + +instance ByteLen (I 'U size e) => ByteLen (Str ('Pascal size e )) where + blen pstr = fromIntegral (blen @(I 'U size e) undefined) + fromIntegral (BS.length (getStr pstr)) + +-- | Total shite parsing efficiency. But, to be fair, that's why we don't +-- serialize arbitrary-length C strings! +instance BinaryCodec (Str 'C) where + toBin cstr = do + putByteString $ getStr cstr + putWord8 0x00 + fromBin = Str <$> fromBinCString + +instance BinaryCodecWith _r (Str 'C) + +-- TODO yeah I gotta do this because now the size info is actually in the +-- newtype -- which makes the most sense, because I want to do similar on the +-- value level! looks a tiny bit jank but ✓ +data WellSized + +-- | TODO explain why safe +instance BinaryCodec (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))) where + toBin wrepstr = do + toBin @(I 'U 'I1 e) $ fromIntegral $ BS.length bs + putByteString bs + where bs = getStr $ unWithRefine wrepstr + fromBin = do + len <- fromBin @(I 'U 'I1 e) + bs <- getByteString $ fromIntegral len + return $ reallyUnsafeEnforce $ Str bs + +instance BinaryCodecWith StrRep BS.ByteString where + toBinWith strRep bs = + case strRep of + C -> toBinWith undefined $ Str @'C bs + Pascal size _e -> do + case size of + I1 -> do + if len > fromIntegral (maxBound @Word8) + then Left "bytestring too long for configured static-size length prefix" + else Right $ B.byteString bs + _ -> undefined + where len = BS.length bs + fromBinWith = \case C -> fromBinCString + Pascal _size _e -> undefined + +-- Fun and correct, but it does give us an orphan instance lol +type LenPfx size e = Str ('Pascal size e) + +-- | TODO why safe +instance (ByteLen a, itype ~ I 'U size e, ByteLen itype) + => ByteLen (WithRefine 'Enforced (LenPfx size e) a) where + blen wrelpa = blen @itype undefined + blen (unWithRefine wrelpa) + +instance (Foldable f, Typeable f, Typeable e) => Predicate (LenPfx 'I4 e) (f a) where + validate p a + | len > fromIntegral max' + = throwRefineOtherException (typeRep p) $ + "too long for given length prefix type: "<>tshow len<>" > "<>tshow max' + | otherwise = success + where + len = length a + max' = maxBound @(IRep 'U 'I4) + +-- | TODO why safe +instance (BinaryCodec a, irep ~ IRep 'U size, itype ~ I 'U size e, Num irep, Integral irep, BinaryCodec itype) + => BinaryCodec (WithRefine 'Enforced (LenPfx size e) [a]) where + fromBin = do + len <- fromBin @itype + as <- replicateM (fromIntegral len) (fromBin @a) + return $ reallyUnsafeEnforce as + toBin wreas = do + toBin @itype $ fromIntegral $ length as + mapM_ (toBin @a) as + where as = unWithRefine wreas diff --git a/src/Binrep/Util.hs b/src/Binrep/Util.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Util.hs @@ -0,0 +1,7 @@ +module Binrep.Util where + +import Data.Text qualified as Text +import Data.Text ( Text ) + +tshow :: Show a => a -> Text +tshow = Text.pack . show