static-bytes (empty) → 0.1.0

raw patch · 8 files changed

+442/−0 lines, 8 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, hspec, memory, primitive, rio, static-bytes, text, vector

Files

CHANGELOG.md +11/−0
LICENSE +28/−0
README.md +4/−0
Setup.hs +2/−0
src/Data/StaticBytes.hs +246/−0
static-bytes.cabal +67/−0
test/Data/StaticBytesSpec.hs +83/−0
test/Spec.hs +1/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `static-bytes`
+
+All notable changes to this project will be documented in this file.
+
+The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
+and this project adheres to the
+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+
+## 0.1.0 - 2023-07-07
+
+* Spin out module `Pantry.Internal.StaticBytes` from package `pantry-0.8.3`.

+ LICENSE view

@@ -0,0 +1,28 @@+BSD 3-Clause License
+
+Copyright (c) 2015-2023, Stack contributors
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its
+   contributors may be used to endorse or promote products derived from
+   this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,4 @@+# static-bytes
+
+A Haskell library providing types representing 8, 16, 32, 64 or 128 bytes of
+data.

+ Setup.hs view

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

+ src/Data/StaticBytes.hs view

@@ -0,0 +1,246 @@+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveDataTypeable  #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Data.StaticBytes
+  ( Bytes8
+  , Bytes16
+  , Bytes32
+  , Bytes64
+  , Bytes128
+  , DynamicBytes
+  , StaticBytes
+  , StaticBytesException (..)
+  , toStaticExact
+  , toStaticPad
+  , toStaticTruncate
+  , toStaticPadTruncate
+  , fromStatic
+  ) where
+
+import           Data.Bits
+import           Data.ByteArray
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as B
+import qualified Data.Primitive.ByteArray as BA
+import qualified Data.Vector.Primitive as VP
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Unboxed.Base as VU
+import           Foreign.ForeignPtr
+import           Foreign.Ptr
+import           Foreign.Storable
+import           RIO hiding ( words )
+import           System.IO.Unsafe ( unsafePerformIO )
+
+-- | A type representing 8 bytes of data.
+newtype Bytes8 = Bytes8 Word64
+  deriving (Eq, Ord, Generic, NFData, Hashable, Data)
+
+instance Show Bytes8 where
+  show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString)
+
+-- | A type representing 16 bytes of data.
+data Bytes16 = Bytes16 !Bytes8 !Bytes8
+  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data)
+
+-- | A type representing 32 bytes of data.
+data Bytes32 = Bytes32 !Bytes16 !Bytes16
+  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data)
+
+-- | A type representing 64 bytes of data.
+data Bytes64 = Bytes64 !Bytes32 !Bytes32
+  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data)
+
+-- | A type representing 128 bytes of data.
+data Bytes128 = Bytes128 !Bytes64 !Bytes64
+  deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data)
+
+-- | A type representing exceptions thrown by functions expecting data of a
+-- fixed number of bytes.
+data StaticBytesException
+  = NotEnoughBytes
+  | TooManyBytes
+  deriving (Eq, Show, Typeable)
+
+instance Exception StaticBytesException
+
+-- All lengths below are given in bytes
+
+class DynamicBytes dbytes where
+  lengthD :: dbytes -> Int
+  -- Yeah, it looks terrible to use a list here, but fusion should kick in
+  withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a
+  -- | May throw a runtime exception if invariants are violated!
+  fromWordsD :: Int -> [Word64] -> dbytes
+
+fromWordsForeign ::
+     (ForeignPtr a -> Int -> b)
+  -> Int
+  -> [Word64]
+  -> b
+fromWordsForeign wrapper len words0 = unsafePerformIO $ do
+  fptr <- B.mallocByteString len
+  withForeignPtr fptr $ \ptr -> do
+    let loop _ [] = pure ()
+        loop off (w:ws) = do
+          pokeElemOff (castPtr ptr) off w
+          loop (off + 1) ws
+    loop 0 words0
+  pure $ wrapper fptr len
+
+withPeekForeign ::
+     (ForeignPtr a, Int, Int)
+  -> ((Int -> IO Word64) -> IO b)
+  -> IO b
+withPeekForeign (fptr, off, len) inner =
+  withForeignPtr fptr $ \ptr -> do
+    let f off'
+          | off' >= len = pure 0
+          | off' + 8 > len = do
+              let loop w64 i
+                    | off' + i >= len = pure w64
+                    | otherwise = do
+                        w8 :: Word8 <- peekByteOff ptr (off + off' + i)
+                        let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64
+                        loop w64' (i + 1)
+              loop 0 0
+          | otherwise = peekByteOff ptr (off + off')
+    inner f
+
+instance DynamicBytes B.ByteString where
+  lengthD = B.length
+  fromWordsD = fromWordsForeign (`B.fromForeignPtr` 0)
+  withPeekD = withPeekForeign . B.toForeignPtr
+
+instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where
+  lengthD = VS.length
+  fromWordsD = fromWordsForeign VS.unsafeFromForeignPtr0
+  withPeekD = withPeekForeign . VS.unsafeToForeignPtr
+
+instance word8 ~ Word8 => DynamicBytes (VP.Vector word8) where
+  lengthD = VP.length
+  fromWordsD len words0 = unsafePerformIO $ do
+    ba <- BA.newByteArray len
+    let loop _ [] =
+          VP.Vector 0 len <$> BA.unsafeFreezeByteArray ba
+        loop i (w:ws) = do
+          BA.writeByteArray ba i w
+          loop (i + 1) ws
+    loop 0 words0
+  withPeekD (VP.Vector off len ba) inner = do
+    let f off'
+          | off' >= len = pure 0
+          | off' + 8 > len = do
+              let loop w64 i
+                    | off' + i >= len = pure w64
+                    | otherwise = do
+                        let w8 :: Word8 = BA.indexByteArray ba (off + off' + i)
+                        let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64
+                        loop w64' (i + 1)
+              loop 0 0
+          | otherwise = pure $ BA.indexByteArray ba (off + (off' `div` 8))
+    inner f
+
+instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where
+  lengthD = VU.length
+  fromWordsD len words = VU.V_Word8 (fromWordsD len words)
+  withPeekD (VU.V_Word8 v) = withPeekD v
+
+class StaticBytes sbytes where
+  lengthS :: proxy sbytes -> Int -- use type level literals instead?
+  -- difference list
+  toWordsS :: sbytes -> [Word64] -> [Word64]
+  usePeekS :: Int -> (Int -> IO Word64) -> IO sbytes
+
+instance StaticBytes Bytes8 where
+  lengthS _ = 8
+  toWordsS (Bytes8 w) = (w:)
+  usePeekS off f = Bytes8 <$> f off
+
+instance StaticBytes Bytes16 where
+  lengthS _ = 16
+  toWordsS (Bytes16 b1 b2) = toWordsS b1 . toWordsS b2
+  usePeekS off f = Bytes16 <$> usePeekS off f <*> usePeekS (off + 8) f
+
+instance StaticBytes Bytes32 where
+  lengthS _ = 32
+  toWordsS (Bytes32 b1 b2) = toWordsS b1 . toWordsS b2
+  usePeekS off f = Bytes32 <$> usePeekS off f <*> usePeekS (off + 16) f
+
+instance StaticBytes Bytes64 where
+  lengthS _ = 64
+  toWordsS (Bytes64 b1 b2) = toWordsS b1 . toWordsS b2
+  usePeekS off f = Bytes64 <$> usePeekS off f <*> usePeekS (off + 32) f
+
+instance StaticBytes Bytes128 where
+  lengthS _ = 128
+  toWordsS (Bytes128 b1 b2) = toWordsS b1 . toWordsS b2
+  usePeekS off f = Bytes128 <$> usePeekS off f <*> usePeekS (off + 64) f
+
+instance ByteArrayAccess Bytes8 where
+  length _ = 8
+  withByteArray = withByteArrayS
+
+instance ByteArrayAccess Bytes16 where
+  length _ = 16
+  withByteArray = withByteArrayS
+
+instance ByteArrayAccess Bytes32 where
+  length _ = 32
+  withByteArray = withByteArrayS
+
+instance ByteArrayAccess Bytes64 where
+  length _ = 64
+  withByteArray = withByteArrayS
+
+instance ByteArrayAccess Bytes128 where
+  length _ = 128
+  withByteArray = withByteArrayS
+
+withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a
+withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString)
+
+toStaticExact ::
+     forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes)
+  => dbytes
+  -> Either StaticBytesException sbytes
+toStaticExact dbytes =
+  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of
+    LT -> Left NotEnoughBytes
+    GT -> Left TooManyBytes
+    EQ -> Right (toStaticPadTruncate dbytes)
+
+toStaticPad ::
+     forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes)
+  => dbytes
+  -> Either StaticBytesException sbytes
+toStaticPad dbytes =
+  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of
+    GT -> Left TooManyBytes
+    _  -> Right (toStaticPadTruncate dbytes)
+
+toStaticTruncate ::
+     forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes)
+  => dbytes
+  -> Either StaticBytesException sbytes
+toStaticTruncate dbytes =
+  case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of
+    LT -> Left NotEnoughBytes
+    _  -> Right (toStaticPadTruncate dbytes)
+
+toStaticPadTruncate ::
+     (DynamicBytes dbytes, StaticBytes sbytes)
+  => dbytes
+  -> sbytes
+toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0))
+
+fromStatic ::
+     forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes)
+  => sbytes
+  -> dbytes
+fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS

+ static-bytes.cabal view

@@ -0,0 +1,67 @@+cabal-version: 1.12
++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           static-bytes+version:        0.1.0+synopsis:       A Haskell library providing types representing 8, 16, 32, 64 or 128 bytes of data.+description:    Please see the README on GitHub at <https://github.com/commercialhaskell/static-bytes#readme>+category:       Data+homepage:       https://github.com/commercialhaskell/static-bytes#readme+bug-reports:    https://github.com/commercialhaskell/static-bytes/issues+author:         Michael Snoyman+maintainer:     Mike Pilgrem <public@pilgrem.com>+copyright:      2018-2023 FP Complete+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/commercialhaskell/static-bytes++library+  exposed-modules:+      Data.StaticBytes+  other-modules:+      Paths_static_bytes+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.12 && <5+    , bytestring+    , memory+    , primitive+    , rio+    , vector+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Data.StaticBytesSpec+      Paths_static_bytes+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      QuickCheck+    , base >=4.12 && <5+    , bytestring+    , hspec+    , memory+    , primitive+    , rio+    , static-bytes+    , text+    , vector+  default-language: Haskell2010

+ test/Data/StaticBytesSpec.hs view

@@ -0,0 +1,83 @@+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.StaticBytesSpec
+  ( spec
+  ) where
+
+import           Control.Monad ( replicateM )
+import qualified Data.ByteString as B
+import           Data.StaticBytes
+                   ( Bytes128, Bytes16, Bytes32, Bytes8,  DynamicBytes
+                   , StaticBytesException (..), fromStatic, toStaticExact
+                   , toStaticPad, toStaticPadTruncate
+                   )
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Vector.Primitive as VP
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Unboxed as VU
+import           RIO
+import           Test.Hspec ( Spec, describe, it, shouldBe )
+import           Test.Hspec.QuickCheck ( prop )
+import           Test.QuickCheck ( arbitrary, forAll, property )
+
+spec :: Spec
+spec = do
+  describe "ByteString" $ tests B.pack
+  describe "Storable Vector" $ tests VS.fromList
+  describe "Unboxed Vector" $ tests VU.fromList
+  describe "Primitive Vector" $ tests VP.fromList
+
+tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec
+tests pack = do
+  it "disallows 4 bytes" $ property $ \(w1,w2,w3,w4) ->
+    toStaticExact (pack [w1,w2,w3,w4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8)
+  it "toStaticExact matches ByteString" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do
+    let octets =  [w1,w2,w3,w4,w5,w6,w7,w8]
+        (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets)
+        actual = either impureThrow id $ toStaticExact (pack octets)
+    actual `shouldBe` expected
+
+  it "fromStatic round trips" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do
+    let octets = [w1,w2,w3,w4,w5,w6,w7,w8]
+        v1 = pack octets
+        (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1
+        v2 = fromStatic b8
+    v2 `shouldBe` v1
+
+  it "allows 8 bytes" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do
+    let bs = pack [w1,w2,w3,w4,w5,w6,w7,w8]
+    case toStaticExact bs of
+      Left e -> throwIO e
+      Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs
+    toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16)
+  it "padding is the same as trailing nulls" $ property $ \(w1,w2,w3,w4) -> do
+    let ws = [w1,w2,w3,w4]
+        bs1 = pack $ ws ++ replicate 4 0
+        bs2 = pack ws
+    Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1
+
+  prop "handles bytes16" $ \octets -> do
+    let bs = pack $ take 16 octets
+        (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs
+    fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0))
+
+  it "spot check bytes16" $ forAll (replicateM 16 arbitrary) $ \ws -> do
+    let bs = pack ws
+        (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs
+    fromStatic b16 `shouldBe` pack ws
+
+  prop "handles bytes32" $ \octets -> do
+    let bs = pack $ take 32 octets
+        (b32 :: Bytes32) = either impureThrow id $ toStaticPad bs
+    fromStatic b32 `shouldBe` pack (take 32 (take 32 octets ++ replicate 32 0))
+
+  prop "fuzz with encodeUtf8" $ \chars -> do
+    let t = T.pack $ filter (/= '\0') chars
+        bs = TE.encodeUtf8 t
+        bs128 = pack $ B.unpack $ B.take 128 $ bs `B.append` B.replicate 128 0
+        b128 = toStaticPadTruncate (pack $ B.unpack bs) :: Bytes128
+
+    fromStatic b128 `shouldBe` bs128

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}