binrep (empty) → 0.1.0

raw patch · 11 files changed

+517/−0 lines, 11 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, cereal, refined, refined-with, text

Files

• CHANGELOG.md +4/−0
• LICENSE +20/−0
• README.md +14/−0
• Setup.hs +2/−0
• binrep.cabal +81/−0
• src/Binrep/ByteLen.hs +34/−0
• src/Binrep/Codec.hs +86/−0
• src/Binrep/Predicates/NullPadTo.hs +69/−0
• src/Binrep/Types/Ints.hs +89/−0
• src/Binrep/Types/Strings.hs +111/−0
• src/Binrep/Util.hs +7/−0

@@ -0,0 +1,4 @@+## 0.1.0 (2022-04-22)+Initial release.++  * extracted from gtvm-hs

@@ -0,0 +1,20 @@+Copyright (c) 2022 Ben Orchard (@raehik) <thefirstmuffinman@gmail.com>++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.

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <thefirstmuffinman@gmail.com>+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

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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