diff --git a/ip.cabal b/ip.cabal --- a/ip.cabal +++ b/ip.cabal @@ -1,5 +1,5 @@ name: ip -version: 0.8.7 +version: 0.9 synopsis: Library for IP and MAC addresses homepage: https://github.com/andrewthad/haskell-ip#readme license: BSD3 @@ -53,15 +53,24 @@ Net.IP Net.Types Net.Internal + Data.Word.Synthetic + Data.Word.Synthetic.Word48 + Data.Word.Synthetic.Word12 + Data.Text.Builder.Fixed + Data.Text.Builder.Variable + Data.Text.Builder.Common.Internal + Data.ByteString.Builder.Fixed build-depends: base >= 4.8 && < 5 , attoparsec - , aeson >= 0.9 && < 0.12 + , aeson >= 0.9 && < 1.1 , hashable >= 1.2 && < 1.3 , text >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11 , vector >= 0.11 && < 0.12 , primitive + -- if impl(ghcjs) + -- build-depends: ghcjs-base >= 0.2 && < 0.3 ghc-options: -Wall -O2 default-language: Haskell2010 @@ -86,6 +95,7 @@ IPv4Text1 IPv4Text2 IPv4ByteString1 + IPv4TextVariableBuilder ghc-options: -Wall -O2 default-language: Haskell2010 @@ -116,6 +126,7 @@ IPv4DecodeText1 IPv4DecodeText2 IPv4ByteString1 + IPv4TextVariableBuilder ghc-options: -Wall -O2 default-language: Haskell2010 hs-source-dirs: test @@ -124,3 +135,4 @@ source-repository head type: git location: https://github.com/andrewthad/haskell-ip + diff --git a/src/Data/ByteString/Builder/Fixed.hs b/src/Data/ByteString/Builder/Fixed.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Builder/Fixed.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_GHC -O2 -Wall -funbox-strict-fields #-} + +{-| For concatenating fixed-width strings that are only a few + characters each, this can be six times faster than the builder + that ships with @bytestring@. +-} +module Data.ByteString.Builder.Fixed + ( Builder + , fromByteString + , run + , contramapBuilder + , char8 + , word8 + , word8HexFixedLower + , word8HexFixedUpper + , word12HexFixedLower + , word12HexFixedUpper + ) where + +import Control.Monad.ST +import Data.Monoid +import Data.Word +import Data.Word.Synthetic (Word12) +import Data.Bits +import Data.Char (ord) +import Text.Printf +import Debug.Trace +import Data.ByteString.Internal (ByteString(..)) +import Foreign +import Data.ByteString.Short (ShortByteString) +import System.IO.Unsafe +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Builder as BBuilder +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LByteString +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString.Short.Internal as SBS + +data Builder a where + BuilderStatic :: !ByteString -> Builder a + BuilderFunction :: !ByteString -> !(Int -> Ptr Word8 -> a -> IO ()) -> Builder a + +instance Monoid (Builder a) where + {-# INLINE mempty #-} + mempty = BuilderStatic ByteString.empty + {-# INLINE mappend #-} + mappend x y = case x of + BuilderStatic t1@(PS _ _ len1) -> case y of + BuilderStatic t2 -> BuilderStatic (t1 <> t2) + BuilderFunction t2 f -> BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a) + BuilderFunction t1@(PS _ _ len1) f1 -> case y of + BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1 + BuilderFunction t2 f2 -> BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a) + +contramapBuilder :: (b -> a) -> Builder a -> Builder b +contramapBuilder f x = case x of + BuilderStatic t -> BuilderStatic t + BuilderFunction t g -> BuilderFunction t (\ix marr b -> g ix marr (f b)) +{-# INLINE contramapBuilder #-} + +fromByteString :: ByteString -> Builder a +fromByteString = BuilderStatic +{-# INLINE fromByteString #-} + +run :: Builder a -> a -> ByteString +run x a = case x of + BuilderStatic t -> t + BuilderFunction (PS inArr off len) f -> + BI.unsafeCreate len $ \ptr -> withForeignPtr inArr $ \inPtr -> do + copyArray ptr (advancePtr inPtr off) len + f 0 ptr a + +word12HexFixedGeneral :: Bool -> Builder Word12 +word12HexFixedGeneral upper = BuilderFunction (BC8.pack "---") $ \i marr w -> do + let !wInt = fromIntegral w + !ix = wInt + wInt + wInt + !arr = if upper then hexValuesWord12Upper else hexValuesWord12Lower + pokeByteOff marr i (SBS.unsafeIndex arr ix) + pokeByteOff marr (i + 1) (SBS.unsafeIndex arr (ix + 1)) + pokeByteOff marr (i + 2) (SBS.unsafeIndex arr (ix + 2)) +{-# INLINE word12HexFixedGeneral #-} + +word12HexFixedUpper :: Builder Word12 +word12HexFixedUpper = word12HexFixedGeneral True +{-# INLINE word12HexFixedUpper #-} + +word12HexFixedLower :: Builder Word12 +word12HexFixedLower = word12HexFixedGeneral False +{-# INLINE word12HexFixedLower #-} + +hexValuesWord12Upper :: ShortByteString +hexValuesWord12Upper = + SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03X") [0 :: Int ..4095] +{-# NOINLINE hexValuesWord12Upper #-} + +hexValuesWord12Lower :: ShortByteString +hexValuesWord12Lower = + SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03x") [0 :: Int ..4095] +{-# NOINLINE hexValuesWord12Lower #-} + +word8HexFixedUpper :: Builder Word8 +word8HexFixedUpper = word8HexFixedGeneral True +{-# INLINE word8HexFixedUpper #-} + +word8HexFixedLower :: Builder Word8 +word8HexFixedLower = word8HexFixedGeneral False +{-# INLINE word8HexFixedLower #-} + +-- The Bool is True if the hex digits are upper case. +word8HexFixedGeneral :: Bool -> Builder Word8 +word8HexFixedGeneral upper = BuilderFunction (BC8.pack "--") $ \i marr w -> do + let !ix = unsafeShiftL (fromIntegral w) 1 + !ix2 = ix + 1 + !arr = if upper then hexValuesWord8Upper else hexValuesWord8Lower + pokeByteOff marr i (SBS.unsafeIndex arr ix) + pokeByteOff marr (i + 1) (SBS.unsafeIndex arr ix2) +{-# INLINE word8HexFixedGeneral #-} + +hexValuesWord8Upper :: ShortByteString +hexValuesWord8Upper = + SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02X") [0 :: Int ..255] +{-# NOINLINE hexValuesWord8Upper #-} + +hexValuesWord8Lower :: ShortByteString +hexValuesWord8Lower = + SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02x") [0 :: Int ..255] +{-# NOINLINE hexValuesWord8Lower #-} + +char8 :: Builder Char +char8 = BuilderFunction (BC8.pack "-") $ \i marr c -> pokeByteOff marr i (c2w c) +{-# INLINE char8 #-} + +word8 :: Builder Word8 +word8 = BuilderFunction (BC8.pack "-") $ \i marr w -> pokeByteOff marr i w +{-# INLINE word8 #-} + +word8At :: Int -> Word64 -> Word8 +word8At i w = fromIntegral (unsafeShiftR w i) +{-# INLINE word8At #-} + +-- | Taken from @Data.ByteString.Internal@. The same warnings +-- apply here. +c2w :: Char -> Word8 +c2w = fromIntegral . ord +{-# INLINE c2w #-} + +-- macBuilder :: Builder Word64 +-- macBuilder = +-- contramapBuilder (word8At 40) twoDigitWord8Hex +-- <> BuilderStatic ":" +-- <> contramapBuilder (word8At 32) twoDigitWord8Hex +-- <> BuilderStatic ":" +-- <> contramapBuilder (word8At 24) twoDigitWord8Hex +-- <> BuilderStatic ":" +-- <> contramapBuilder (word8At 16) twoDigitWord8Hex +-- <> BuilderStatic ":" +-- <> contramapBuilder (word8At 8) twoDigitWord8Hex +-- <> BuilderStatic ":" +-- <> contramapBuilder (word8At 0) twoDigitWord8Hex + + diff --git a/src/Data/Text/Builder/Common/Internal.hs b/src/Data/Text/Builder/Common/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Common/Internal.hs @@ -0,0 +1,89 @@ +module Data.Text.Builder.Common.Internal where + +import Data.Text (Text) +import Control.Monad.ST +import Data.Monoid +import Data.Word +import Data.Bits +import Text.Printf +import Debug.Trace +import Data.Char (ord) +import Data.Word.Synthetic (Word12) +import Data.Vector (Vector) +import Data.Foldable (fold) +import qualified Data.Vector as Vector +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.IO as LText +import qualified Data.Text.Lazy.Builder as TBuilder +import qualified Data.Text.Lazy.Builder.Int as TBuilder +import qualified Data.Text.IO as Text +import qualified Data.Text.Array as A +import qualified Data.Text.Internal as TI +import qualified Data.Text.Internal.Unsafe.Char as TC + +-- | This is slower that just pattern matching on the Text data constructor. +-- However, it will work with GHCJS. This should only be used in places +-- where we know that it will only be evaluated once. +portableTextArray :: Text -> A.Array +portableTextArray = fst . portableUntext +{-# INLINE portableTextArray #-} + +-- | This length is not the character length. It is the length of Word16s +-- required by a UTF16 representation. +portableTextLength :: Text -> Int +portableTextLength = snd . portableUntext +{-# INLINE portableTextLength #-} + +portableUntext :: Text -> (A.Array,Int) +portableUntext t = + let str = Text.unpack t + Sum len = foldMap (Sum . charUtf16Size) str + arr = A.run $ do + marr <- A.new len + writeString marr str + return marr + in (arr,len) +{-# NOINLINE portableUntext #-} + +writeString :: A.MArray s -> String -> ST s () +writeString marr = go 0 where + go i s = case s of + c : cs -> do + n <- TC.unsafeWrite marr i c + go (i + n) cs + [] -> return () + +charUtf16Size :: Char -> Int +charUtf16Size c = if ord c < 0x10000 then 1 else 2 + +hexValuesWord12Upper :: A.Array +hexValuesWord12Upper = portableTextArray $ fold + $ map (Text.pack . printf "%03X") [0 :: Int ..4096] +{-# NOINLINE hexValuesWord12Upper #-} + +hexValuesWord12Lower :: A.Array +hexValuesWord12Lower = portableTextArray $ fold + $ map (Text.pack . printf "%03x") [0 :: Int ..4096] +{-# NOINLINE hexValuesWord12Lower #-} + +hexValuesWord8Upper :: A.Array +hexValuesWord8Upper = portableTextArray $ fold + $ map (Text.pack . printf "%02X") [0 :: Int ..255] +{-# NOINLINE hexValuesWord8Upper #-} + +hexValuesWord8Lower :: A.Array +hexValuesWord8Lower = portableTextArray $ fold + $ map (Text.pack . printf "%02x") [0 :: Int ..255] +{-# NOINLINE hexValuesWord8Lower #-} + +twoDecimalDigits :: A.Array +twoDecimalDigits = portableTextArray + $ foldMap (Text.pack . printf "%02d") [0 :: Int ..99] +{-# NOINLINE twoDecimalDigits #-} + +threeDecimalDigits :: A.Array +threeDecimalDigits = portableTextArray + $ foldMap (Text.pack . printf "%03d") [0 :: Int ..255] +{-# NOINLINE threeDecimalDigits #-} + diff --git a/src/Data/Text/Builder/Fixed.hs b/src/Data/Text/Builder/Fixed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Fixed.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_GHC -O2 -Wall -funbox-strict-fields #-} + +{-| For concatenating fixed-width strings that are only a few + characters each, this can be ten times faster than the builder + that ships with @text@. +-} +module Data.Text.Builder.Fixed + ( Builder + , fromText + , run + , contramapBuilder + , charBmp + , word8HexFixedLower + , word8HexFixedUpper + , word12HexFixedLower + , word12HexFixedUpper + ) where + +import Control.Monad.ST +import Data.Monoid +import Data.Word +import Data.Bits +import Text.Printf +import Debug.Trace +import Data.Char (ord) +import Data.Word.Synthetic (Word12) +import Data.Vector (Vector) +import Data.Foldable (fold) +import Data.Text (Text) +import qualified Data.Vector as Vector +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.IO as LText +import qualified Data.Text.Lazy.Builder as TBuilder +import qualified Data.Text.Lazy.Builder.Int as TBuilder +import qualified Data.Text.IO as Text +import qualified Data.Text.Array as A +import qualified Data.Text.Internal as TI +import qualified Data.Text.Internal.Unsafe.Char as TC +import qualified Data.Text.Builder.Common.Internal as I + +data Builder a where + BuilderStatic :: Text -> Builder a + BuilderFunction :: Text -> (forall s. Int -> A.MArray s -> a -> ST s ()) -> Builder a + +instance Monoid (Builder a) where + {-# INLINE mempty #-} + mempty = BuilderStatic Text.empty + {-# INLINE mappend #-} + mappend x y = case x of + BuilderStatic t1 -> case y of + BuilderStatic t2 -> BuilderStatic (t1 <> t2) + BuilderFunction t2 f -> + let len1 = I.portableTextLength t1 + in BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a) + BuilderFunction t1 f1 -> case y of + BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1 + BuilderFunction t2 f2 -> + let len1 = I.portableTextLength t1 + in BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a) + +fromText :: Text -> Builder a +fromText = BuilderStatic +{-# INLINE fromText #-} + +contramapBuilder :: (b -> a) -> Builder a -> Builder b +contramapBuilder f x = case x of + BuilderStatic t -> BuilderStatic t + BuilderFunction t g -> BuilderFunction t (\ix marr b -> g ix marr (f b)) +{-# INLINE contramapBuilder #-} + +run :: Builder a -> a -> Text +run x = case x of + BuilderStatic t -> \_ -> t + BuilderFunction t f -> + let (inArr, len) = I.portableUntext t + in \a -> + let outArr = runST $ do + marr <- A.new len + A.copyI marr 0 inArr 0 len + f 0 marr a + A.unsafeFreeze marr + in TI.text outArr 0 len +{-# INLINE run #-} + +word8HexFixedUpper :: Builder Word8 +word8HexFixedUpper = word8HexFixedGeneral True +{-# INLINE word8HexFixedUpper #-} + +word8HexFixedLower :: Builder Word8 +word8HexFixedLower = word8HexFixedGeneral False +{-# INLINE word8HexFixedLower #-} + +-- The Bool is True if the hex digits are upper case. +word8HexFixedGeneral :: Bool -> Builder Word8 +word8HexFixedGeneral upper = + BuilderFunction (Text.pack "--") $ \i marr w -> do + let ix = unsafeShiftL (fromIntegral w) 1 + ix2 = ix + 1 + arr = if upper then I.hexValuesWord8Upper else I.hexValuesWord8Lower + A.unsafeWrite marr i (A.unsafeIndex arr ix) + A.unsafeWrite marr (i + 1) (A.unsafeIndex arr ix2) +{-# INLINE word8HexFixedGeneral #-} + +-- | Characters outside the basic multilingual plane are not handled +-- correctly by this function. They will not cause a program to crash; +-- instead, the character will have the upper bits masked out. +charBmp :: Builder Char +charBmp = + BuilderFunction (Text.pack "-") $ \i marr c -> A.unsafeWrite marr i (fromIntegral (ord c)) +{-# INLINE charBmp #-} + +word12HexFixedGeneral :: Bool -> Builder Word12 +word12HexFixedGeneral upper = + BuilderFunction (Text.pack "---") $ \i marr w -> do + let !wInt = fromIntegral w + !ix = wInt + wInt + wInt + !arr = if upper then I.hexValuesWord12Upper else I.hexValuesWord12Lower + A.unsafeWrite marr i (A.unsafeIndex arr ix) + A.unsafeWrite marr (i + 1) (A.unsafeIndex arr (ix + 1)) + A.unsafeWrite marr (i + 2) (A.unsafeIndex arr (ix + 2)) +{-# INLINE word12HexFixedGeneral #-} + +word12HexFixedUpper :: Builder Word12 +word12HexFixedUpper = word12HexFixedGeneral True +{-# INLINE word12HexFixedUpper #-} + +word12HexFixedLower :: Builder Word12 +word12HexFixedLower = word12HexFixedGeneral False +{-# INLINE word12HexFixedLower #-} + diff --git a/src/Data/Text/Builder/Variable.hs b/src/Data/Text/Builder/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Builder/Variable.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} + +{-| This is a builder optimized for concatenating short + variable-length strings whose length has a known upper + bound. In these cases, this can be up to ten times faster + than the builder provided by the @text@ library. However, + data whose textual encoding has no known upper bound cannot + be encoded by the builder provided here. For example, it + is possible to provide decimal builders for types like 'Int8' and + 'Word16', whose lengths are respectively bounded by + 4 and 5. However, this is not possible for 'Integer', since + its decimal representation could be arbitrarily long. +-} +module Data.Text.Builder.Variable + ( Builder + , run + , contramap + , charBmp + , staticCharBmp + , word8 + ) where + +import Data.Monoid +import Data.Word +import Data.Text (Text) +import Text.Printf (printf) +import Control.Monad.ST +import Data.Char (ord) +import Data.Vector (Vector) +import Data.Function (on) +import Data.Maybe (fromMaybe) +import qualified Data.Vector as Vector +import qualified Data.Text as Text +import qualified Data.Text.Array as A +import qualified Data.Text.Builder.Common.Internal as I +import qualified Data.Text.Internal as TI + +data Builder a + = Builder + {-# UNPACK #-} !Int -- the maximum length, not a character count + !(forall s. Int -> A.MArray s -> a -> ST s Int) + +instance Monoid (Builder a) where + {-# INLINE mempty #-} + mempty = Builder 0 (\i _ _ -> return i) + {-# INLINE mappend #-} + mappend (Builder len1 f) (Builder len2 g) = + Builder (len1 + len2) $ \ix1 marr a -> do + ix2 <- f ix1 marr a + g ix2 marr a + +run :: Builder a -> a -> Text +run (Builder maxLen f) = \a -> + let (outArr,len) = A.run2 $ do + marr <- A.new maxLen + finalIx <- f 0 marr a + return (marr,finalIx) + in TI.text outArr 0 len +{-# INLINE run #-} + +contramap :: (b -> a) -> Builder a -> Builder b +contramap f (Builder len g) = Builder len $ \i marr b -> + g i marr (f b) +{-# INLINE contramap #-} + +-- finish writing this. it's important for completeness +-- char :: Builder a +-- char = Builder 2 $ \ + +-- | A character in the basic multilingual plane. +charBmp :: Builder Char +charBmp = Builder 1 $ \i marr c -> do + A.unsafeWrite marr i (fromIntegral (ord c)) + return (i + 1) +{-# INLINE charBmp #-} + +staticCharBmp :: Char -> Builder a +staticCharBmp c = Builder 1 $ \i marr _ -> do + A.unsafeWrite marr i (fromIntegral (ord c)) + return (i + 1) +{-# INLINE staticCharBmp #-} + +word8 :: Builder Word8 +word8 = Builder 3 $ \pos marr w -> if + | w < 10 -> do + A.unsafeWrite marr pos (i2w w) + return (pos + 1) + | w < 100 -> do + let wInt = fromIntegral w + ix = wInt + wInt + A.unsafeWrite marr pos (A.unsafeIndex I.twoDecimalDigits ix) + A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.twoDecimalDigits (ix + 1)) + return (pos + 2) + | otherwise -> do + let wInt = fromIntegral w + ix = wInt + wInt + wInt + A.unsafeWrite marr pos (A.unsafeIndex I.threeDecimalDigits ix) + A.unsafeWrite marr (pos + 1) (A.unsafeIndex I.threeDecimalDigits (ix + 1)) + A.unsafeWrite marr (pos + 2) (A.unsafeIndex I.threeDecimalDigits (ix + 2)) + return (pos + 3) +{-# INLINE word8 #-} + +-- This has not yet been tested. +vector :: + Text -- ^ Default, used when index is out of range + -> Vector Text -- ^ Texts to index into + -> Builder Int +vector tDef v = + let xs = Vector.map I.portableUntext v + xDef = I.portableUntext tDef + in Builder + (Vector.maximum $ Vector.map I.portableTextLength $ Vector.cons tDef v) + $ \pos marr i -> do + let (arr,len) = fromMaybe xDef (xs Vector.!? i) + finalIx = i + len + A.copyI marr i arr 0 finalIx + return finalIx +{-# INLINE vector #-} + +i2w :: Integral a => a -> Word16 +i2w v = asciiZero + fromIntegral v +{-# INLINE i2w #-} + +asciiZero :: Word16 +asciiZero = 48 +{-# INLINE asciiZero #-} + diff --git a/src/Data/Word/Synthetic.hs b/src/Data/Word/Synthetic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Word/Synthetic.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Word.Synthetic + ( Word48 + , Word12 + ) where + +import Data.Word.Synthetic.Word48 (Word48) +import Data.Word.Synthetic.Word12 (Word12) + diff --git a/src/Data/Word/Synthetic/Word12.hs b/src/Data/Word/Synthetic/Word12.hs new file mode 100644 --- /dev/null +++ b/src/Data/Word/Synthetic/Word12.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} + + +-- | +-- Module : Data.Word.Word12 +-- License : see src/Data/LICENSE +-- Stability : experimental +-- Portability : non-portable (GHC Extensions) + +-- Provide a 12-bit unsigned integral type: 'Word12', analagous to Word8, +-- Word16, etc. +-- + +module Data.Word.Synthetic.Word12 ( + -- * Word12 type + Word12(..) + -- * Internal helpers + , narrow12Word# + , clz12# + , ctz12# + , popCnt12# + ) + +where + +import Data.Bits +import Data.Data +import Data.Maybe +import Foreign.Storable + +import GHC.Arr +import GHC.Base +import GHC.Enum +import GHC.Num +import GHC.Ptr +import GHC.Read +import GHC.Real +import GHC.Show +import GHC.Word + +------------------------------------------------------------------------ + +-- Word12 is represented in the same way as Word. Operations may assume and +-- must ensure that it holds only values in its logical range. + +-- | 12-bit unsigned integer type +-- +data Word12 = W12# Word# deriving (Eq, Ord) + +word12Type :: DataType +word12Type = mkIntType "Data.Word.Synthetic.Word12.Word12" + +instance Data Word12 where + toConstr x = mkIntegralConstr word12Type x + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c + ++ " is not of type Word12." + dataTypeOf _ = word12Type + +-- | narrowings represented as primop 'and#' in GHC. +narrow12Word# :: Word# -> Word# +narrow12Word# = and# 0xFFF## + +-- | count leading zeros +-- +clz12# :: Word# -> Word# +clz12# w# = clz32# (narrow12Word# w#) `minusWord#` 20## + +-- | count trailing zeros +-- +ctz12# :: Word# -> Word# +ctz12# w# = ctz# w# + +-- | the number of set bits +-- +popCnt12# :: Word# -> Word# +popCnt12# w# = popCnt# (narrow12Word# w#) + +instance Show Word12 where + showsPrec p x = showsPrec p (fromIntegral x :: Int) + +instance Num Word12 where + (W12# x#) + (W12# y#) = W12# (narrow12Word# (x# `plusWord#` y#)) + (W12# x#) - (W12# y#) = W12# (narrow12Word# (x# `minusWord#` y#)) + (W12# x#) * (W12# y#) = W12# (narrow12Word# (x# `timesWord#` y#)) + negate (W12# x#) = W12# (narrow12Word# (int2Word# (negateInt# (word2Int# x#)))) + abs x = x + signum 0 = 0 + signum _ = 1 + fromInteger i = W12# (narrow12Word# (integerToWord i)) + +instance Real Word12 where + toRational x = toInteger x % 1 + +instance Enum Word12 where + succ x + | x /= maxBound = x + 1 + | otherwise = succError "Word12" + pred x + | x /= minBound = x - 1 + | otherwise = predError "Word12" + toEnum i@(I# i#) + | i >= 0 && i <= fromIntegral (maxBound :: Word12) + = W12# (int2Word# i#) + | otherwise = toEnumError "Word12" i (minBound::Word12, maxBound::Word12) + fromEnum (W12# x#) = I# (word2Int# x#) + enumFrom = boundedEnumFrom + enumFromThen = boundedEnumFromThen + +instance Integral Word12 where + quot (W12# x#) y@(W12# y#) + | y /= 0 = W12# (x# `quotWord#` y#) + | otherwise = divZeroError + rem (W12# x#) y@(W12# y#) + | y /= 0 = W12# (x# `remWord#` y#) + | otherwise = divZeroError + div (W12# x#) y@(W12# y#) + | y /= 0 = W12# (x# `quotWord#` y#) + | otherwise = divZeroError + mod (W12# x#) y@(W12# y#) + | y /= 0 = W12# (x# `remWord#` y#) + | otherwise = divZeroError + quotRem (W12# x#) y@(W12# y#) + | y /= 0 = (W12# (x# `quotWord#` y#), W12# (x# `remWord#` y#)) + | otherwise = divZeroError + divMod (W12# x#) y@(W12# y#) + | y /= 0 = (W12# (x# `quotWord#` y#), W12# (x# `remWord#` y#)) + | otherwise = divZeroError + toInteger (W12# x#) = smallInteger (word2Int# x#) + +instance Bounded Word12 where + minBound = 0 + maxBound = 0xFFFFFF + +instance Ix Word12 where + range (m,n) = [m..n] + unsafeIndex (m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + +instance Read Word12 where + readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] + +instance Bits Word12 where + {-# INLINE shift #-} + {-# INLINE bit #-} + {-# INLINE testBit #-} + + (W12# x#) .&. (W12# y#) = W12# (x# `and#` y#) + (W12# x#) .|. (W12# y#) = W12# (x# `or#` y#) + (W12# x#) `xor` (W12# y#) = W12# (x# `xor#` y#) + complement (W12# x#) = W12# (x# `xor#` mb#) where !(W12# mb#) = maxBound + (W12# x#) `shift` (I# i#) + | isTrue# (i# >=# 0#) = W12# (narrow12Word# (x# `shiftL#` i#)) + | otherwise = W12# (x# `shiftRL#` negateInt# i#) + (W12# x#) `shiftL` (I# i#) = W12# (narrow12Word# (x# `shiftL#` i#)) + (W12# x#) `unsafeShiftL` (I# i#) = + W12# (narrow12Word# (x# `uncheckedShiftL#` i#)) + (W12# x#) `shiftR` (I# i#) = W12# (x# `shiftRL#` i#) + (W12# x#) `unsafeShiftR` (I# i#) = W12# (x# `uncheckedShiftRL#` i#) + (W12# x#) `rotate` i + | isTrue# (i'# ==# 0#) = W12# x# + | otherwise = W12# (narrow12Word# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (12# -# i'#)))) + where + !(I# i'#) = i `mod` 12 + bitSizeMaybe i = Just (finiteBitSize i) + bitSize = finiteBitSize + isSigned _ = False + popCount (W12# x#) = I# (word2Int# (popCnt12# x#)) + bit = bitDefault + testBit = testBitDefault + +instance FiniteBits Word12 where + finiteBitSize _ = 12 + countLeadingZeros (W12# x#) = I# (word2Int# (clz12# x#)) + countTrailingZeros (W12# x#) = I# (word2Int# (ctz12# x#)) + +{-# RULES +"fromIntegral/Word8->Word12" fromIntegral = \(W8# x#) -> W12# x# +"fromIntegral/Word12->Word12" fromIntegral = id :: Word12 -> Word12 +"fromIntegral/Word12->Integer" fromIntegral = toInteger :: Word12 -> Integer +"fromIntegral/a->Word12" fromIntegral = \x -> case fromIntegral x of W# x# -> W12# (narrow12Word# x#) +"fromIntegral/Word12->a" fromIntegral = \(W12# x#) -> fromIntegral (W# x#) + #-} + +{-# RULES +"properFraction/Float->(Word12,Float)" + properFraction = \x -> + case properFraction x of { + (n, y) -> ((fromIntegral :: Int -> Word12) n, y :: Float) } +"truncate/Float->Word12" + truncate = (fromIntegral :: Int -> Word12) . (truncate :: Float -> Int) +"floor/Float->Word12" + floor = (fromIntegral :: Int -> Word12) . (floor :: Float -> Int) +"ceiling/Float->Word12" + ceiling = (fromIntegral :: Int -> Word12) . (ceiling :: Float -> Int) +"round/Float->Word12" + round = (fromIntegral :: Int -> Word12) . (round :: Float -> Int) + #-} + +{-# RULES +"properFraction/Double->(Word12,Double)" + properFraction = \x -> + case properFraction x of { + (n, y) -> ((fromIntegral :: Int -> Word12) n, y :: Double) } +"truncate/Double->Word12" + truncate = (fromIntegral :: Int -> Word12) . (truncate :: Double -> Int) +"floor/Double->Word12" + floor = (fromIntegral :: Int -> Word12) . (floor :: Double -> Int) +"ceiling/Double->Word12" + ceiling = (fromIntegral :: Int -> Word12) . (ceiling :: Double -> Int) +"round/Double->Word12" + round = (fromIntegral :: Int -> Word12) . (round :: Double -> Int) + #-} + + diff --git a/src/Data/Word/Synthetic/Word48.hs b/src/Data/Word/Synthetic/Word48.hs new file mode 100644 --- /dev/null +++ b/src/Data/Word/Synthetic/Word48.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Word.Synthetic.Word48 where + +import Data.Bits +import Data.Word +import Data.Int +import Data.Ratio +import GHC.Arr +import GHC.Enum +import Data.Primitive.Types +import Data.Hashable (Hashable) +import qualified Data.Vector.Unboxed as UVector +import qualified Data.Vector.Generic as GVector +import qualified Data.Vector.Unboxed.Mutable as MUVector +import qualified Data.Vector.Generic.Mutable as MGVector + +newtype Word48 = W48 Word64 + deriving (Eq,Ord,Hashable) + +narrow48Word :: Word64 -> Word64 +narrow48Word = (.&.) 0xFFFFFFFFFFFF +{-# INLINE narrow48Word #-} + +popCnt48 :: Word64 -> Int +popCnt48 = popCount . narrow48Word +{-# INLINE popCnt48 #-} + +word48UpperWord16 :: Word48 -> Word16 +word48UpperWord16 (W48 w) = fromIntegral (unsafeShiftR w 32) + +word48LowerWord32 :: Word48 -> Word32 +word48LowerWord32 (W48 w) = fromIntegral w + +word48FromUpperLower :: Word16 -> Word32 -> Word48 +word48FromUpperLower a b = + W48 (unsafeShiftL (fromIntegral a) 32 .|. fromIntegral b) + +instance Show Word48 where + showsPrec p (W48 x) = showsPrec p x + +instance Num Word48 where + (W48 x) + (W48 y) = W48 (narrow48Word (x + y)) + (W48 x) - (W48 y) = W48 (narrow48Word (x - y)) + (W48 x) * (W48 y) = W48 (narrow48Word (x * y)) + negate (W48 x) = W48 (negate (fromIntegral (negate (fromIntegral x :: Int64)))) + abs x = x + signum 0 = 0 + signum _ = 1 + fromInteger i = W48 (narrow48Word (fromInteger i)) + +instance Real Word48 where + toRational (W48 x) = toInteger x % 1 + +instance Enum Word48 where + succ x + | x /= maxBound = x + 1 + | otherwise = succError "Word48" + pred x + | x /= minBound = x - 1 + | otherwise = predError "Word48" + toEnum i + | i >= 0 && i <= fromIntegral (maxBound :: Word48) + = W48 (fromIntegral i) + | otherwise = toEnumError "Word48" i (minBound::Word48, maxBound::Word48) + -- Causes a bounds check to occur twice + fromEnum (W48 x) + | x <= fromIntegral (maxBound :: Int) = fromIntegral x + | otherwise = fromEnumError "Word48" x + enumFrom = boundedEnumFrom + enumFromThen = boundedEnumFromThen + +instance Integral Word48 where + quot (W48 x) (W48 y) = W48 (x `quot` y) + rem (W48 x) (W48 y) = W48 (x `rem` y) + div (W48 x) (W48 y) = W48 (x `quot` y) + mod (W48 x) (W48 y) = W48 (x `rem` y) + quotRem (W48 x) (W48 y) = (W48 (x `quot` y), W48 (x `rem` y)) + divMod (W48 x) (W48 y) = (W48 (x `quot` y), W48 (x `rem` y)) + toInteger (W48 x) = toInteger x + +instance Bounded Word48 where + minBound = 0 + maxBound = 0xFFFFFFFFFFFF + +instance Ix Word48 where + range (m,n) = [m..n] + unsafeIndex (m,_) i = fromIntegral (i - m) + inRange (m,n) i = m <= i && i <= n + +instance Read Word48 where + readsPrec p s = [(fromIntegral (x::Word64), r) | (x, r) <- readsPrec p s] + +instance Bits Word48 where + {-# INLINE shift #-} + {-# INLINE bit #-} + {-# INLINE testBit #-} + + (W48 x) .&. (W48 y) = W48 (x .&. y) + (W48 x) .|. (W48 y) = W48 (x .|. y) + (W48 x) `xor` (W48 y) = W48 (x `xor` y) + complement (W48 x) = W48 (x `xor` mb) where !(W48 mb) = maxBound + (W48 x) `shift` i + | i >= 0 = W48 (narrow48Word (x `shiftL` i)) + | otherwise = W48 (x `shiftR` negate i) + (W48 x) `shiftL` i = W48 (narrow48Word (x `shiftL` i)) + (W48 x) `unsafeShiftL` i = + W48 (narrow48Word (x `unsafeShiftL` i)) + (W48 x) `shiftR` i = W48 (x `shiftR` i) + (W48 x) `unsafeShiftR` i = W48 (x `unsafeShiftR` i) + (W48 x) `rotate` i + | i' == 0 = W48 x + | otherwise = W48 (narrow48Word ((x `unsafeShiftL` i') .|. + (x `unsafeShiftR` (48 - i')))) + where + !i' = i `mod` 48 + bitSizeMaybe i = Just (finiteBitSize i) + bitSize = finiteBitSize + isSigned _ = False + popCount (W48 x) = popCnt48 x + bit = bitDefault + testBit = testBitDefault + +instance FiniteBits Word48 where + finiteBitSize _ = 48 + countLeadingZeros (W48 x) = countLeadingZeros x - 16 + countTrailingZeros (W48 x) = countTrailingZeros x + +data instance MUVector.MVector s Word48 + = MV_Word48 + {-# UNPACK #-} !Int + !(MUVector.MVector s Word16) + !(MUVector.MVector s Word32) + +data instance UVector.Vector Word48 + = V_Word48 + {-# UNPACK #-} !Int + !(UVector.Vector Word16) + !(UVector.Vector Word32) + +instance UVector.Unbox Word48 + +instance MGVector.MVector MUVector.MVector Word48 where + {-# INLINE basicLength #-} + basicLength (MV_Word48 n_ as bs) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (MV_Word48 n_ as bs) + = MV_Word48 m_ + (MGVector.basicUnsafeSlice i_ m_ as) + (MGVector.basicUnsafeSlice i_ m_ bs) + {-# INLINE basicOverlaps #-} + basicOverlaps (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 as2 bs2) + = MGVector.basicOverlaps as1 as2 + || MGVector.basicOverlaps bs1 bs2 + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n_ + = do + as <- MGVector.basicUnsafeNew n_ + bs <- MGVector.basicUnsafeNew n_ + return $ MV_Word48 n_ as bs + {-# INLINE basicInitialize #-} + basicInitialize (MV_Word48 _ as bs) + = do + MGVector.basicInitialize as + MGVector.basicInitialize bs + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n_ w + = do + let upper = word48UpperWord16 w + lower = word48LowerWord32 w + as <- MGVector.basicUnsafeReplicate n_ upper + bs <- MGVector.basicUnsafeReplicate n_ lower + return $ MV_Word48 n_ as bs + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_Word48 n_ as bs) i_ + = do + a <- MGVector.basicUnsafeRead as i_ + b <- MGVector.basicUnsafeRead bs i_ + return (word48FromUpperLower a b) + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_Word48 n_ as bs) i_ w + = do + let upper = word48UpperWord16 w + lower = word48LowerWord32 w + MGVector.basicUnsafeWrite as i_ upper + MGVector.basicUnsafeWrite bs i_ lower + {-# INLINE basicClear #-} + basicClear (MV_Word48 n_ as bs) + = do + MGVector.basicClear as + MGVector.basicClear bs + {-# INLINE basicSet #-} + basicSet (MV_Word48 n_ as bs) w + = do + let upper = word48UpperWord16 w + lower = word48LowerWord32 w + MGVector.basicSet as upper + MGVector.basicSet bs lower + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 as2 bs2) + = do + MGVector.basicUnsafeCopy as1 as2 + MGVector.basicUnsafeCopy bs1 bs2 + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MV_Word48 n_1 as1 bs1) (MV_Word48 n_2 as2 bs2) + = do + MGVector.basicUnsafeMove as1 as2 + MGVector.basicUnsafeMove bs1 bs2 + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow (MV_Word48 n_ as bs) m_ + = do + as' <- MGVector.basicUnsafeGrow as m_ + bs' <- MGVector.basicUnsafeGrow bs m_ + return $ MV_Word48 (m_+n_) as' bs' + +instance GVector.Vector UVector.Vector Word48 where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MV_Word48 n_ as bs) + = do + as' <- GVector.basicUnsafeFreeze as + bs' <- GVector.basicUnsafeFreeze bs + return $ V_Word48 n_ as' bs' + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (V_Word48 n_ as bs) + = do + as' <- GVector.basicUnsafeThaw as + bs' <- GVector.basicUnsafeThaw bs + return $ MV_Word48 n_ as' bs' + {-# INLINE basicLength #-} + basicLength (V_Word48 n_ as bs) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (V_Word48 n_ as bs) + = V_Word48 m_ (GVector.basicUnsafeSlice i_ m_ as) + (GVector.basicUnsafeSlice i_ m_ bs) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_Word48 n_ as bs) i_ + = do + a <- GVector.basicUnsafeIndexM as i_ + b <- GVector.basicUnsafeIndexM bs i_ + return (word48FromUpperLower a b) + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_Word48 n_1 as1 bs1) (V_Word48 n_2 as2 bs2) + = do + GVector.basicUnsafeCopy as1 as2 + GVector.basicUnsafeCopy bs1 bs2 + {-# INLINE elemseq #-} + elemseq _ = seq + + diff --git a/src/Net/IPv6/Text.hs b/src/Net/IPv6/Text.hs --- a/src/Net/IPv6/Text.hs +++ b/src/Net/IPv6/Text.hs @@ -16,7 +16,7 @@ parser :: Atto.Parser IPv6 parser = do s <- start - case toIPv6 (traceShowId s) of + case toIPv6 s of Nothing -> fail "Wrong number of octets in IPv6 address" Just ip -> return ip where diff --git a/src/Net/Internal.hs b/src/Net/Internal.hs --- a/src/Net/Internal.hs +++ b/src/Net/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} module Net.Internal where @@ -10,6 +11,9 @@ import Data.ByteString (ByteString) import Data.Text.Lazy.Builder.Int (decimal) import Control.Monad +import Text.Printf (printf) +import Data.Char (chr,ord) +import Data.Word.Synthetic (Word48) import qualified Data.Text as Text import qualified Data.Text.Lazy as LText import qualified Data.Attoparsec.Text as AT @@ -22,6 +26,12 @@ import qualified Data.Text.Read as TextRead import qualified Data.Text.Lazy.Builder.Int as TBuilder +-- | Taken from @Data.ByteString.Internal@. The same warnings +-- apply here. +c2w :: Char -> Word8 +c2w = fromIntegral . ord +{-# INLINE c2w #-} + eitherToAesonParser :: Either String a -> Aeson.Parser a eitherToAesonParser x = case x of Left err -> fail err @@ -95,11 +105,27 @@ -- to do more of the math upfront and allocate less space. toTextPreAllocated :: Word32 -> Text toTextPreAllocated w = - let w1 = fromIntegral $ 255 .&. shiftR w 24 - w2 = fromIntegral $ 255 .&. shiftR w 16 - w3 = fromIntegral $ 255 .&. shiftR w 8 - w4 = fromIntegral $ 255 .&. w - dot = 46 + let w1 = 255 .&. unsafeShiftR (fromIntegral w) 24 + w2 = 255 .&. unsafeShiftR (fromIntegral w) 16 + w3 = 255 .&. unsafeShiftR (fromIntegral w) 8 + w4 = 255 .&. fromIntegral w + in toTextPreallocatedPartTwo w1 w2 w3 w4 + +toTextPreallocatedPartTwo :: Word -> Word -> Word -> Word -> Text +toTextPreallocatedPartTwo w1 w2 w3 w4 = +#ifdef ghcjs_HOST_OS + let dotStr = "." + in Text.pack $ concat + [ show w1 + , "." + , show w2 + , "." + , show w3 + , "." + , show w4 + ] +#else + let dot = 46 (arr,len) = runST $ do marr <- TArray.new 15 i1 <- putAndCount 0 w1 marr @@ -117,9 +143,10 @@ i4 <- putAndCount n3' w4 marr theArr <- TArray.unsafeFreeze marr return (theArr,i4 + n3') - in Text arr 0 len + in Text arr 0 len +#endif -putAndCount :: Int -> Word8 -> TArray.MArray s -> ST s Int +putAndCount :: Int -> Word -> TArray.MArray s -> ST s Int putAndCount pos w marr | w < 10 = TArray.unsafeWrite marr pos (i2w w) >> return 1 | w < 100 = write2 pos w >> return 2 @@ -135,24 +162,63 @@ TArray.unsafeWrite marr (off + 1) $ get3 (j + 1) TArray.unsafeWrite marr (off + 2) $ get3 (j + 2) get2 = fromIntegral . ByteString.unsafeIndex twoDigits - get3 = fromIntegral . ByteString.unsafeIndex threeDigits + get3 = fromIntegral . ByteString.unsafeIndex threeDigitsWord8 -putMac :: ByteString -> Int -> Int -> TArray.MArray s -> ST s () -putMac hexPairs pos w marr = do - let i = w + w +putMac :: ByteString -> Int -> Word64 -> TArray.MArray s -> ST s () +putMac hexPairs pos w' marr = do + let w = fromIntegral w' + i = w + w TArray.unsafeWrite marr pos $ fromIntegral $ ByteString.unsafeIndex hexPairs i TArray.unsafeWrite marr (pos + 1) $ fromIntegral $ ByteString.unsafeIndex hexPairs (i + 1) {-# INLINE putMac #-} -macToTextPreAllocated :: Word8 -> Bool -> Word16 -> Word32 -> Text -macToTextPreAllocated separator' isUpperCase wa wb = - let w1 = fromIntegral $ 255 .&. unsafeShiftR wa 8 - w2 = fromIntegral $ 255 .&. wa - w3 = fromIntegral $ 255 .&. unsafeShiftR wb 24 - w4 = fromIntegral $ 255 .&. unsafeShiftR wb 16 - w5 = fromIntegral $ 255 .&. unsafeShiftR wb 8 - w6 = fromIntegral $ 255 .&. wb - hexPairs = if isUpperCase then twoHexDigits else twoHexDigitsLower +word48AsOctets :: Word48 -> (Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> a) -> a +word48AsOctets w f = + let w1 = fromIntegral $ unsafeShiftR w 40 + w2 = fromIntegral $ unsafeShiftR w 32 + w3 = fromIntegral $ unsafeShiftR w 24 + w4 = fromIntegral $ unsafeShiftR w 16 + w5 = fromIntegral $ unsafeShiftR w 8 + w6 = fromIntegral w + in f w1 w2 w3 w4 w5 w6 +{-# INLINE word48AsOctets #-} + +macToTextDefault :: Word48 -> Text +macToTextDefault = macToTextPreAllocated 58 False + +macToTextPreAllocated :: Word8 -> Bool -> Word48 -> Text +macToTextPreAllocated separator' isUpperCase w = + let w1 = 255 .&. unsafeShiftR (fromIntegral w) 40 + w2 = 255 .&. unsafeShiftR (fromIntegral w) 32 + w3 = 255 .&. unsafeShiftR (fromIntegral w) 24 + w4 = 255 .&. unsafeShiftR (fromIntegral w) 16 + w5 = 255 .&. unsafeShiftR (fromIntegral w) 8 + w6 = 255 .&. fromIntegral w + in macToTextPartTwo separator' isUpperCase w1 w2 w3 w4 w5 w6 +{-# INLINE macToTextPreAllocated #-} + +macToTextPartTwo :: Word8 -> Bool -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Text +macToTextPartTwo separator' isUpperCase w1 w2 w3 w4 w5 w6 = +#ifdef ghcjs_HOST_OS + Text.pack $ concat + [ toHex w1 + , separatorStr + , toHex w2 + , separatorStr + , toHex w3 + , separatorStr + , toHex w4 + , separatorStr + , toHex w5 + , separatorStr + , toHex w6 + ] + where + toHex :: Word64 -> String + toHex = if isUpperCase then printf "%02X" else printf "%02x" + separatorStr = [chr (fromEnum separator')] +#else + let hexPairs = if isUpperCase then twoHexDigits else twoHexDigitsLower separator = fromIntegral separator' :: Word16 arr = runST $ do marr <- TArray.new 17 @@ -169,8 +235,10 @@ putMac hexPairs 15 w6 marr TArray.unsafeFreeze marr in Text arr 0 17 -{-# INLINE macToTextPreAllocated #-} +#endif +{-# INLINE macToTextPartTwo #-} + zero :: Word16 zero = 48 {-# INLINE zero #-} @@ -335,7 +403,7 @@ -- r1,r2,r3,r4,r5,r6 :: Word32 -- r1 = fromOctets' 0 0 0 0 -macTextParser :: Maybe Char -> (Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> a) -> AT.Parser a +macTextParser :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> AT.Parser a macTextParser separator f = f <$> (AT.hexadecimal >>= limitSize) <* parseSeparator @@ -357,91 +425,41 @@ then fail "All octets in a mac address must be between 00 and FF" else return i -macToText :: Word16 -> Word32 -> Text -macToText a b = LText.toStrict (TBuilder.toLazyText (macToTextBuilder a b)) - -macToTextBuilder :: Word16 -> Word32 -> TBuilder.Builder -macToTextBuilder a b = - TBuilder.hexadecimal (255 .&. shiftR a 8 ) - <> colon - <> TBuilder.hexadecimal (255 .&. a ) - <> colon - <> TBuilder.hexadecimal (255 .&. shiftR b 24 ) - <> colon - <> TBuilder.hexadecimal (255 .&. shiftR b 16 ) - <> colon - <> TBuilder.hexadecimal (255 .&. shiftR b 8 ) - <> colon - <> TBuilder.hexadecimal (255 .&. b) - where colon = TBuilder.singleton ':' +-- Unchecked invariant: each of these Word64s must be smaller +-- than 256. +unsafeWord48FromOctets :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word48 +unsafeWord48FromOctets a b c d e f = + fromIntegral + $ unsafeShiftL a 40 + .|. unsafeShiftL b 32 + .|. unsafeShiftL c 24 + .|. unsafeShiftL d 16 + .|. unsafeShiftL e 8 + .|. f +{-# INLINE unsafeWord48FromOctets #-} -macFromText :: Maybe Char -> (Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> a) -> Text -> Maybe a +macFromText :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> Text -> Maybe a macFromText separator f = rightToMaybe . macFromText' separator f {-# INLINE macFromText #-} -macFromText' :: Maybe Char -> (Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> a) -> Text -> Either String a +macFromText' :: Maybe Char -> (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> a) -> Text -> Either String a macFromText' separator f = AT.parseOnly (macTextParser separator f <* AT.endOfInput) {-# INLINE macFromText' #-} twoDigits :: ByteString -twoDigits = BC8.pack - "0001020304050607080910111213141516171819\ - \2021222324252627282930313233343536373839\ - \4041424344454647484950515253545556575859\ - \6061626364656667686970717273747576777879\ - \8081828384858687888990919293949596979899" +twoDigits = foldMap (BC8.pack . printf "%02d") $ enumFromTo (0 :: Int) 99 +{-# NOINLINE twoDigits #-} -threeDigits :: ByteString -threeDigits = - ByteString.replicate 300 0 <> BC8.pack - "100101102103104105106107108109110111112\ - \113114115116117118119120121122123124125\ - \126127128129130131132133134135136137138\ - \139140141142143144145146147148149150151\ - \152153154155156157158159160161162163164\ - \165166167168169170171172173174175176177\ - \178179180181182183184185186187188189190\ - \191192193194195196197198199200201202203\ - \204205206207208209210211212213214215216\ - \217218219220221222223224225226227228229\ - \230231232233234235236237238239240241242\ - \243244245246247248249250251252253254255" +threeDigitsWord8 :: ByteString +threeDigitsWord8 = foldMap (BC8.pack . printf "%03d") $ enumFromTo (0 :: Int) 255 +{-# NOINLINE threeDigitsWord8 #-} twoHexDigits :: ByteString -twoHexDigits = BC8.pack - "000102030405060708090A0B0C0D0E0F\ - \101112131415161718191A1B1C1D1E1F\ - \202122232425262728292A2B2C2D2E2F\ - \303132333435363738393A3B3C3D3E3F\ - \404142434445464748494A4B4C4D4E4F\ - \505152535455565758595A5B5C5D5E5F\ - \606162636465666768696A6B6C6D6E6F\ - \707172737475767778797A7B7C7D7E7F\ - \808182838485868788898A8B8C8D8E8F\ - \909192939495969798999A9B9C9D9E9F\ - \A0A1A2A3A4A5A6A7A8A9AAABACADAEAF\ - \B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF\ - \C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF\ - \D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF\ - \E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF\ - \F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF" +twoHexDigits = foldMap (BC8.pack . printf "%02X") $ enumFromTo (0 :: Int) 255 +{-# NOINLINE twoHexDigits #-} twoHexDigitsLower :: ByteString -twoHexDigitsLower = BC8.pack - "000102030405060708090a0b0c0d0e0f\ - \101112131415161718191a1b1c1d1e1f\ - \202122232425262728292a2b2c2d2e2f\ - \303132333435363738393a3b3c3d3e3f\ - \404142434445464748494a4b4c4d4e4f\ - \505152535455565758595a5b5c5d5e5f\ - \606162636465666768696a6b6c6d6e6f\ - \707172737475767778797a7b7c7d7e7f\ - \808182838485868788898a8b8c8d8e8f\ - \909192939495969798999a9b9c9d9e9f\ - \a0a1a2a3a4a5a6a7a8a9aaabacadaeaf\ - \b0b1b2b3b4b5b6b7b8b9babbbcbdbebf\ - \c0c1c2c3c4c5c6c7c8c9cacbcccdcecf\ - \d0d1d2d3d4d5d6d7d8d9dadbdcdddedf\ - \e0e1e2e3e4e5e6e7e8e9eaebecedeeef\ - \f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff" +twoHexDigitsLower = foldMap (BC8.pack . printf "%02x") $ enumFromTo (0 :: Int) 255 +{-# NOINLINE twoHexDigitsLower #-} + diff --git a/src/Net/Mac.hs b/src/Net/Mac.hs --- a/src/Net/Mac.hs +++ b/src/Net/Mac.hs @@ -3,34 +3,27 @@ module Net.Mac ( fromOctets - , fromOctetsNoCast + , toOctets ) where import Net.Types (Mac(..)) -import Data.Text (Text) -import Data.Hashable (Hashable) -import GHC.Generics (Generic) import Data.Word -import Data.Aeson (ToJSON(..),FromJSON(..)) -import qualified Data.Attoparsec.Text as AT -import qualified Data.Attoparsec.ByteString.Char8 as AB -import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement) -import Net.Internal (attoparsecParseJSON,rightToMaybe) -import qualified Data.Text.Lazy.Builder as TBuilder -import Data.Text.Lazy.Builder.Int (hexadecimal) -import Data.Monoid ((<>)) -import qualified Data.Aeson as Aeson -import qualified Data.Text.Lazy as LText +import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement,unsafeShiftR) +import qualified Net.Internal as Internal fromOctets :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Mac -fromOctets a b c d e f = fromOctetsNoCast +fromOctets a b c d e f = Mac $ Internal.unsafeWord48FromOctets (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d) (fromIntegral e) (fromIntegral f) - -fromOctetsNoCast :: Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> Mac -fromOctetsNoCast a b c d e f = Mac - ( shiftL a 8 .|. b ) - ( shiftL c 24 .|. shiftL d 16 .|. shiftL e 8 .|. f ) -{-# INLINE fromOctetsNoCast #-} +{-# INLINE fromOctets #-} +toOctets :: Mac -> (Word8,Word8,Word8,Word8,Word8,Word8) +toOctets (Mac w) = + ( fromIntegral $ unsafeShiftR w 40 + , fromIntegral $ unsafeShiftR w 32 + , fromIntegral $ unsafeShiftR w 24 + , fromIntegral $ unsafeShiftR w 16 + , fromIntegral $ unsafeShiftR w 8 + , fromIntegral w + ) diff --git a/src/Net/Mac/ByteString/Char8.hs b/src/Net/Mac/ByteString/Char8.hs --- a/src/Net/Mac/ByteString/Char8.hs +++ b/src/Net/Mac/ByteString/Char8.hs @@ -1,36 +1,44 @@ module Net.Mac.ByteString.Char8 ( encode + , encodeWith , decode + , decodeWith + , decodeLenient , builder , parser , parserWith + , parserLenient ) where -import Net.Types (Mac(..),MacEncoding(..),MacDecoding(..)) +import Net.Types (Mac(..),MacCodec(..),MacGrouping(..)) import Net.Mac (fromOctets) import Data.ByteString (ByteString) import Data.Attoparsec.ByteString.Char8 (Parser) import Data.ByteString.Lazy.Builder (Builder) -import Net.Internal (rightToMaybe) +import Net.Internal (rightToMaybe,c2w) import Data.Text.Encoding (encodeUtf8, decodeUtf8') import Data.Word (Word8) -import Data.Bits (unsafeShiftL) +import Data.Word.Synthetic (Word12) +import Data.Bits (unsafeShiftL,unsafeShiftR) import Control.Monad +import Data.Monoid +import qualified Data.ByteString.Builder.Fixed as FB import qualified Data.ByteString.Builder as Builder import qualified Data.Attoparsec.ByteString as ABW import qualified Data.Attoparsec.ByteString.Char8 as AB -import qualified Net.Mac.Text as MacText --- | This is a mediocre implementation that should --- be rewritten. encode :: Mac -> ByteString -encode = encodeUtf8 . MacText.encode +encode = encodeWith defCodec --- | This is a mediocre implementation that should --- be rewritten. decode :: ByteString -> Maybe Mac -decode = MacText.decode <=< rightToMaybe . decodeUtf8' +decode = decodeWith defCodec +decodeWith :: MacCodec -> ByteString -> Maybe Mac +decodeWith codec bs = rightToMaybe (AB.parseOnly (parserWith codec <* AB.endOfInput) bs) + +decodeLenient :: ByteString -> Maybe Mac +decodeLenient bs = rightToMaybe (AB.parseOnly (parserLenient <* AB.endOfInput) bs) + -- | Make a bytestring builder from a 'Mac' address -- using a colon as the separator. builder :: Mac -> Builder @@ -39,41 +47,208 @@ -- | Parser for a 'Mac' address using with a colon as the -- separator (i.e. @FA:43:B2:C0:0F:99@). parser :: Parser Mac -parser = parserWith defDecoding +parser = parserWith defCodec --- | Parser for a 'Mac' address using to the provided --- settings. -parserWith :: MacDecoding -> Parser Mac -parserWith (MacDecoding separator) = fromOctets +-- | Parser for a 'Mac' address using the provided settings. +parserWith :: MacCodec -> Parser Mac +parserWith (MacCodec g _) = case g of + MacGroupingPairs s -> parserPairs (c2w s) + MacGroupingTriples s -> parserTriples (c2w s) + MacGroupingQuadruples s -> parserQuadruples (c2w s) + MacGroupingNoSeparator -> parserNoSeparator + +parserLenient :: Parser Mac +parserLenient = do + a1 <- parseOneHex + a2 <- parseOneHexLenient + a3 <- parseOneHexLenient + a4 <- parseOneHexLenient + a5 <- parseOneHexLenient + a6 <- parseOneHexLenient + a7 <- parseOneHexLenient + a8 <- parseOneHexLenient + a9 <- parseOneHexLenient + a10 <- parseOneHexLenient + a11 <- parseOneHexLenient + a12 <- parseOneHexLenient + return $ fromOctets + (unsafeShiftL a1 4 + a2) + (unsafeShiftL a3 4 + a4) + (unsafeShiftL a5 4 + a6) + (unsafeShiftL a7 4 + a8) + (unsafeShiftL a9 4 + a10) + (unsafeShiftL a11 4 + a12) + + +parserNoSeparator :: Parser Mac +parserNoSeparator = fromOctets <$> parseTwoHex - <* parseSeparator <*> parseTwoHex - <* parseSeparator <*> parseTwoHex - <* parseSeparator <*> parseTwoHex - <* parseSeparator <*> parseTwoHex - <* parseSeparator <*> parseTwoHex - where - parseSeparator = case separator of - Just c -> ABW.word8 c - Nothing -> return 60 -- character is unused +parserPairs :: Word8 -> Parser Mac +parserPairs s = fromOctets + <$> parseTwoHex <* ABW.word8 s + <*> parseTwoHex <* ABW.word8 s + <*> parseTwoHex <* ABW.word8 s + <*> parseTwoHex <* ABW.word8 s + <*> parseTwoHex <* ABW.word8 s + <*> parseTwoHex + +parserTriples :: Word8 -> Parser Mac +parserTriples s = do + a1 <- parseOneHex + a2 <- parseOneHex + a3 <- parseOneHex + _ <- ABW.word8 s + a4 <- parseOneHex + a5 <- parseOneHex + a6 <- parseOneHex + _ <- ABW.word8 s + a7 <- parseOneHex + a8 <- parseOneHex + a9 <- parseOneHex + _ <- ABW.word8 s + a10 <- parseOneHex + a11 <- parseOneHex + a12 <- parseOneHex + return $ fromOctets + (unsafeShiftL a1 4 + a2) + (unsafeShiftL a3 4 + a4) + (unsafeShiftL a5 4 + a6) + (unsafeShiftL a7 4 + a8) + (unsafeShiftL a9 4 + a10) + (unsafeShiftL a11 4 + a12) + +parserQuadruples :: Word8 -> Parser Mac +parserQuadruples s = fromOctets + <$> parseTwoHex <*> parseTwoHex <* ABW.word8 s + <*> parseTwoHex <*> parseTwoHex <* ABW.word8 s + <*> parseTwoHex <*> parseTwoHex + +parseOneHex :: Parser Word8 +parseOneHex = ABW.anyWord8 >>= parseWord8Hex + +-- | Parse a single hexidecimal character. This will skip +-- at most one character to do this. +parseOneHexLenient :: Parser Word8 +parseOneHexLenient = do + a <- ABW.anyWord8 + flip tryParseWord8Hex a $ do + b <- ABW.anyWord8 + tryParseWord8Hex (fail "invalid hexadecimal character") b + parseTwoHex :: Parser Word8 parseTwoHex = do a <- ABW.anyWord8 >>= parseWord8Hex b <- ABW.anyWord8 >>= parseWord8Hex return (unsafeShiftL a 4 + b) -parseWord8Hex :: Word8 -> Parser Word8 -parseWord8Hex w - | w >= 48 && w <= 57 = return (w - 48) - | w >= 65 && w <= 70 = return (w - 55) +-- | Kind of a confusing type signature. The Word8 that stands +-- alone represented an ascii-encoded value. The others actually +-- describes the numbers that would be decoded from this value. +tryParseWord8Hex :: Parser Word8 -> Word8 -> Parser Word8 +tryParseWord8Hex a w + | w >= 48 && w <= 57 = return (w - 48) + | w >= 65 && w <= 70 = return (w - 55) | w >= 97 && w <= 102 = return (w - 87) - | otherwise = fail "invalid hexadecimal character" + | otherwise = a -defDecoding :: MacDecoding -defDecoding = MacDecoding (Just 58) +parseWord8Hex :: Word8 -> Parser Word8 +parseWord8Hex = tryParseWord8Hex (fail "invalid hexadecimal character") + +defCodec :: MacCodec +defCodec = MacCodec (MacGroupingPairs ':') False + +encodeWith :: MacCodec -> Mac -> ByteString +encodeWith (MacCodec g u) m = case g of + MacGroupingNoSeparator -> case u of + True -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedUpper) m + False -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedLower) m + MacGroupingPairs c -> case u of + True -> FB.run (fixedBuilderPairs FB.word8HexFixedUpper) (Pair (c2w c) m) + False -> FB.run (fixedBuilderPairs FB.word8HexFixedLower) (Pair (c2w c) m) + -- withCasedBuilder u $ \bw8 -> FB.run (fixedBuilderPairs bw8) (Pair c m) + MacGroupingTriples c -> case u of + True -> FB.run (fixedBuilderTriples FB.word12HexFixedUpper) (Pair (c2w c) m) + False -> FB.run (fixedBuilderTriples FB.word12HexFixedLower) (Pair (c2w c) m) + MacGroupingQuadruples c -> case u of + True -> FB.run (fixedBuilderQuadruples FB.word8HexFixedUpper) (Pair (c2w c) m) + False -> FB.run (fixedBuilderQuadruples FB.word8HexFixedLower) (Pair (c2w c) m) + +withCasedBuilder :: Bool -> (FB.Builder Word8 -> a) -> a +withCasedBuilder x f = case x of + True -> f FB.word8HexFixedUpper + False -> f FB.word8HexFixedLower +{-# INLINE withCasedBuilder #-} + +withCasedBuilderTriple :: Bool -> (FB.Builder Word12 -> a) -> a +withCasedBuilderTriple x f = case x of + True -> f FB.word12HexFixedUpper + False -> f FB.word12HexFixedLower +{-# INLINE withCasedBuilderTriple #-} + +data Pair = Pair + { pairSep :: {-# UNPACK #-} !Word8 + , pairMac :: {-# UNPACK #-} !Mac + } + +fixedBuilderTriples :: FB.Builder Word12 -> FB.Builder Pair +fixedBuilderTriples tripBuilder = + FB.contramapBuilder (word12At 36 . pairMac) tripBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word12At 24 . pairMac) tripBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word12At 12 . pairMac) tripBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word12At 0 . pairMac) tripBuilder +{-# INLINE fixedBuilderTriples #-} + +fixedBuilderQuadruples :: FB.Builder Word8 -> FB.Builder Pair +fixedBuilderQuadruples pairBuilder = + FB.contramapBuilder (word8At 40 . pairMac) pairBuilder + <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder + <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder + <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder +{-# INLINE fixedBuilderQuadruples #-} + +fixedBuilderPairs :: FB.Builder Word8 -> FB.Builder Pair +fixedBuilderPairs pairBuilder = + FB.contramapBuilder (word8At 40 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.word8 + <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder +{-# INLINE fixedBuilderPairs #-} + +fixedBuilderNoSeparator :: FB.Builder Word8 -> FB.Builder Mac +fixedBuilderNoSeparator hexBuilder = + FB.contramapBuilder (word8At 40) hexBuilder + <> FB.contramapBuilder (word8At 32) hexBuilder + <> FB.contramapBuilder (word8At 24) hexBuilder + <> FB.contramapBuilder (word8At 16) hexBuilder + <> FB.contramapBuilder (word8At 8) hexBuilder + <> FB.contramapBuilder (word8At 0) hexBuilder +{-# INLINE fixedBuilderNoSeparator #-} + +word8At :: Int -> Mac -> Word8 +word8At i (Mac w) = fromIntegral (unsafeShiftR w i) +{-# INLINE word8At #-} + +word12At :: Int -> Mac -> Word12 +word12At i (Mac w) = fromIntegral (unsafeShiftR w i) +{-# INLINE word12At #-} diff --git a/src/Net/Mac/Text.hs b/src/Net/Mac/Text.hs --- a/src/Net/Mac/Text.hs +++ b/src/Net/Mac/Text.hs @@ -10,50 +10,212 @@ , parserWith ) where -import Net.Types (Mac(..),MacEncoding(..),MacDecoding(..)) -import Net.Mac (fromOctetsNoCast) +import Net.Types (Mac(..),MacCodec(..),MacGrouping(..)) +import Net.Mac (fromOctets) +-- import Net.Mac (fromOctetsNoCast) import Data.Text (Text) import Data.Word (Word8) +import Data.Word.Synthetic (Word12) import Data.Char (chr) +import Data.Attoparsec.Text (Parser) +import Net.Internal (rightToMaybe,c2w) +import Data.Bits (unsafeShiftL,unsafeShiftR) +import Data.Monoid import qualified Net.Internal as Internal import qualified Data.Attoparsec.Text as AT import qualified Data.Text.Lazy.Builder as TBuilder +import qualified Data.Text.Builder.Fixed as FB encode :: Mac -> Text -encode (Mac a b) = Internal.macToTextPreAllocated 58 False a b +encode = encodeWith defCodec -- Internal.macToTextDefault w -decodeEitherWith :: MacDecoding -> Text -> Either String Mac -decodeEitherWith (MacDecoding separator) = - Internal.macFromText' (fmap w8ToChar separator) fromOctetsNoCast +encodeWith :: MacCodec -> Mac -> Text +encodeWith (MacCodec g u) m = case g of + MacGroupingNoSeparator -> case u of + True -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedUpper) m + False -> FB.run (fixedBuilderNoSeparator FB.word8HexFixedLower) m + MacGroupingPairs c -> case u of + True -> FB.run (fixedBuilderPairs FB.word8HexFixedUpper) (Pair c m) + False -> FB.run (fixedBuilderPairs FB.word8HexFixedLower) (Pair c m) + -- withCasedBuilder u $ \bw8 -> FB.run (fixedBuilderPairs bw8) (Pair c m) + MacGroupingTriples c -> case u of + True -> FB.run (fixedBuilderTriples FB.word12HexFixedUpper) (Pair c m) + False -> FB.run (fixedBuilderTriples FB.word12HexFixedLower) (Pair c m) + MacGroupingQuadruples c -> case u of + True -> FB.run (fixedBuilderQuadruples FB.word8HexFixedUpper) (Pair c m) + False -> FB.run (fixedBuilderQuadruples FB.word8HexFixedLower) (Pair c m) +withCasedBuilder :: Bool -> (FB.Builder Word8 -> a) -> a +withCasedBuilder x f = case x of + True -> f FB.word8HexFixedUpper + False -> f FB.word8HexFixedLower +{-# INLINE withCasedBuilder #-} + + +decodeEitherWith :: MacCodec -> Text -> Either String Mac +decodeEitherWith codec t = AT.parseOnly (parserWith codec <* AT.endOfInput) t + decodeEither :: Text -> Either String Mac -decodeEither = decodeEitherWith defDecoding +decodeEither = decodeEitherWith defCodec decode :: Text -> Maybe Mac -decode = decodeWith defDecoding - -decodeWith :: MacDecoding -> Text -> Maybe Mac -decodeWith d = Internal.rightToMaybe . decodeEitherWith d +decode = decodeWith defCodec --- decodeWith :: +decodeWith :: MacCodec -> Text -> Maybe Mac +decodeWith codec t = rightToMaybe (AT.parseOnly (parserWith codec <* AT.endOfInput) t) builder :: Mac -> TBuilder.Builder -builder (Mac a b) = Internal.macToTextBuilder a b +builder = TBuilder.fromText . encode parser :: AT.Parser Mac -parser = parserWith defDecoding +parser = parserWith defCodec -parserWith :: MacDecoding -> AT.Parser Mac -parserWith (MacDecoding separator) = - Internal.macTextParser (fmap w8ToChar separator) fromOctetsNoCast +parserWith :: MacCodec -> AT.Parser Mac +parserWith (MacCodec g _) = case g of + MacGroupingQuadruples c -> parserQuadruples c + MacGroupingTriples c -> parserTriples c + MacGroupingPairs c -> parserPairs c + MacGroupingNoSeparator -> parserNoSeparator -encodeWith :: MacEncoding -> Mac -> Text -encodeWith (MacEncoding separator isUpperCase) (Mac a b) = - Internal.macToTextPreAllocated separator isUpperCase a b -defDecoding :: MacDecoding -defDecoding = MacDecoding (Just 58) +defCodec :: MacCodec +defCodec = MacCodec (MacGroupingPairs ':') False w8ToChar :: Word8 -> Char w8ToChar = chr . fromIntegral +parserQuadruples :: Char -> Parser Mac +parserQuadruples s = fromOctets + <$> parseTwoHex <*> parseTwoHex <* AT.char s + <*> parseTwoHex <*> parseTwoHex <* AT.char s + <*> parseTwoHex <*> parseTwoHex + +parserPairs :: Char -> Parser Mac +parserPairs s = fromOctets + <$> parseTwoHex <* AT.char s + <*> parseTwoHex <* AT.char s + <*> parseTwoHex <* AT.char s + <*> parseTwoHex <* AT.char s + <*> parseTwoHex <* AT.char s + <*> parseTwoHex + +parserTriples :: Char -> Parser Mac +parserTriples s = do + a1 <- parseOneHex + a2 <- parseOneHex + a3 <- parseOneHex + _ <- AT.char s + a4 <- parseOneHex + a5 <- parseOneHex + a6 <- parseOneHex + _ <- AT.char s + a7 <- parseOneHex + a8 <- parseOneHex + a9 <- parseOneHex + _ <- AT.char s + a10 <- parseOneHex + a11 <- parseOneHex + a12 <- parseOneHex + return $ fromOctets + (unsafeShiftL a1 4 + a2) + (unsafeShiftL a3 4 + a4) + (unsafeShiftL a5 4 + a6) + (unsafeShiftL a7 4 + a8) + (unsafeShiftL a9 4 + a10) + (unsafeShiftL a11 4 + a12) + +parserNoSeparator :: Parser Mac +parserNoSeparator = fromOctets + <$> parseTwoHex + <*> parseTwoHex + <*> parseTwoHex + <*> parseTwoHex + <*> parseTwoHex + <*> parseTwoHex + +parseTwoHex :: Parser Word8 +parseTwoHex = do + a <- AT.anyChar >>= parseCharHex + b <- AT.anyChar >>= parseCharHex + return (unsafeShiftL a 4 + b) + +tryParseCharHex :: Parser Word8 -> Char -> Parser Word8 +tryParseCharHex a c + | w >= 48 && w <= 57 = return (w - 48) + | w >= 65 && w <= 70 = return (w - 55) + | w >= 97 && w <= 102 = return (w - 87) + | otherwise = a + where w = c2w c + +parseOneHex :: Parser Word8 +parseOneHex = AT.anyChar >>= parseCharHex + +parseCharHex :: Char -> Parser Word8 +parseCharHex = tryParseCharHex (fail "invalid hexadecimal character") + +withCasedBuilderTriple :: Bool -> (FB.Builder Word12 -> a) -> a +withCasedBuilderTriple x f = case x of + True -> f FB.word12HexFixedUpper + False -> f FB.word12HexFixedLower +{-# INLINE withCasedBuilderTriple #-} + +data Pair = Pair + { pairSep :: {-# UNPACK #-} !Char + , pairMac :: {-# UNPACK #-} !Mac + } + +fixedBuilderTriples :: FB.Builder Word12 -> FB.Builder Pair +fixedBuilderTriples tripBuilder = + FB.contramapBuilder (word12At 36 . pairMac) tripBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word12At 24 . pairMac) tripBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word12At 12 . pairMac) tripBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word12At 0 . pairMac) tripBuilder +{-# INLINE fixedBuilderTriples #-} + +fixedBuilderNoSeparator :: FB.Builder Word8 -> FB.Builder Mac +fixedBuilderNoSeparator hexBuilder = + FB.contramapBuilder (word8At 40) hexBuilder + <> FB.contramapBuilder (word8At 32) hexBuilder + <> FB.contramapBuilder (word8At 24) hexBuilder + <> FB.contramapBuilder (word8At 16) hexBuilder + <> FB.contramapBuilder (word8At 8) hexBuilder + <> FB.contramapBuilder (word8At 0) hexBuilder +{-# INLINE fixedBuilderNoSeparator #-} + +fixedBuilderQuadruples :: FB.Builder Word8 -> FB.Builder Pair +fixedBuilderQuadruples pairBuilder = + FB.contramapBuilder (word8At 40 . pairMac) pairBuilder + <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder + <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder + <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder +{-# INLINE fixedBuilderQuadruples #-} + +fixedBuilderPairs :: FB.Builder Word8 -> FB.Builder Pair +fixedBuilderPairs pairBuilder = + FB.contramapBuilder (word8At 40 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word8At 32 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word8At 24 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word8At 16 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word8At 8 . pairMac) pairBuilder + <> FB.contramapBuilder pairSep FB.charBmp + <> FB.contramapBuilder (word8At 0 . pairMac) pairBuilder +{-# INLINE fixedBuilderPairs #-} + +word8At :: Int -> Mac -> Word8 +word8At i (Mac w) = fromIntegral (unsafeShiftR w i) +{-# INLINE word8At #-} + +word12At :: Int -> Mac -> Word12 +word12At i (Mac w) = fromIntegral (unsafeShiftR w i) +{-# INLINE word12At #-} diff --git a/src/Net/Types.hs b/src/Net/Types.hs --- a/src/Net/Types.hs +++ b/src/Net/Types.hs @@ -13,8 +13,8 @@ , IP(..) , IPv4Range(..) , Mac(..) - , MacEncoding(..) - , MacDecoding(..) + , MacCodec(..) + , MacGrouping(..) ) where import qualified Net.Internal as Internal @@ -29,8 +29,9 @@ import qualified Data.Vector.Generic.Mutable as MGVector import qualified Data.Vector.Unboxed.Mutable as MUVector import qualified Data.Vector.Primitive.Mutable as MPVector +import Data.Word.Synthetic (Word48) import Data.Primitive.Types (Prim) -import Data.Bits (Bits,FiniteBits,(.|.),shiftL) +import Data.Bits (Bits,FiniteBits,(.|.),unsafeShiftL) import Data.Coerce (coerce) import Control.Monad import Data.Word @@ -65,34 +66,44 @@ } deriving (Eq,Ord,Show,Read,Generic) -- | A 48-bit MAC address. -data Mac = Mac - { macA :: {-# UNPACK #-} !Word16 - , macB :: {-# UNPACK #-} !Word32 - } +newtype Mac = Mac { getMac :: Word48 } deriving (Eq,Ord,Show,Read,Generic) -data MacEncoding = MacEncoding - { macEncodingSeparator :: {-# UNPACK #-} !Word8 -- ^ ASCII value of the separator - , macEncodingUpperCase :: {-# UNPACK #-} !Bool +-- data MacEncoding = MacEncoding +-- { macEncodingSeparator :: {-# UNPACK #-} !Word8 -- ^ ASCII value of the separator +-- , macEncodingUpperCase :: {-# UNPACK #-} !Bool +-- } deriving (Eq,Ord,Show,Read,Generic) + +data MacCodec = MacCodec + { macCodecGrouping :: !MacGrouping + , macCodecUpperCase :: !Bool } deriving (Eq,Ord,Show,Read,Generic) -newtype MacDecoding = MacDecoding - { macDecodingSeparator :: Maybe Word8 - } +-- | The format expected by the mac address parser. The 'Word8' taken +-- by some of these constructors is the ascii value of the character +-- to be used as the separator. This is typically a colon, a hyphen, or +-- a space character. All decoding functions are case insensitive. +data MacGrouping + = MacGroupingPairs !Char -- ^ Two-character groups, @FA:2B:40:09:8C:11@ + | MacGroupingTriples !Char -- ^ Three-character groups, @24B-F0A-025-829@ + | MacGroupingQuadruples !Char -- ^ Four-character groups, @A220.0745.CAC7@ + | MacGroupingNoSeparator -- ^ No separator, @24AF4B5B0780@ + deriving (Eq,Ord,Show,Read,Generic) instance Hashable Mac instance ToJSON Mac where - toJSON (Mac a b) = Aeson.String (Internal.macToText a b) + toJSON (Mac w) = Aeson.String (Internal.macToTextDefault w) instance FromJSON Mac where parseJSON = Internal.attoparsecParseJSON (Internal.macTextParser (Just ':') macFromOctets' <* AT.endOfInput) -macFromOctets' :: Word16 -> Word16 -> Word32 -> Word32 -> Word32 -> Word32 -> Mac -macFromOctets' a b c d e f = Mac - ( shiftL a 8 .|. b ) - ( shiftL c 24 .|. shiftL d 16 .|. shiftL e 8 .|. f ) +-- Unchecked invariant: each of these Word64s must be smaller +-- than 256. +macFromOctets' :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Mac +macFromOctets' a b c d e f = + Mac (Internal.unsafeWord48FromOctets a b c d e f) {-# INLINE macFromOctets' #-} instance Hashable IPv4Range @@ -275,109 +286,8 @@ . GVector.elemseq (undefined :: UVector.Vector b) b -data instance MUVector.MVector s Mac - = MV_Mac {-# UNPACK #-} !Int !(MUVector.MVector s Word16) - !(MUVector.MVector s Word32) -data instance UVector.Vector Mac - = V_Mac {-# UNPACK #-} !Int !(UVector.Vector Word16) - !(UVector.Vector Word32) -instance UVector.Unbox Mac -instance MGVector.MVector MUVector.MVector Mac where - {-# INLINE basicLength #-} - basicLength (MV_Mac n_ as bs) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (MV_Mac n_ as bs) - = MV_Mac m_ (MGVector.basicUnsafeSlice i_ m_ as) - (MGVector.basicUnsafeSlice i_ m_ bs) - {-# INLINE basicOverlaps #-} - basicOverlaps (MV_Mac n_1 as1 bs1) (MV_Mac n_2 as2 bs2) - = MGVector.basicOverlaps as1 as2 - || MGVector.basicOverlaps bs1 bs2 - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n_ - = do - as <- MGVector.basicUnsafeNew n_ - bs <- MGVector.basicUnsafeNew n_ - return $ MV_Mac n_ as bs - {-# INLINE basicInitialize #-} - basicInitialize (MV_Mac _ as bs) - = do - MGVector.basicInitialize as - MGVector.basicInitialize bs - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n_ (Mac a b) - = do - as <- MGVector.basicUnsafeReplicate n_ a - bs <- MGVector.basicUnsafeReplicate n_ b - return $ MV_Mac n_ as bs - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MV_Mac n_ as bs) i_ - = do - a <- MGVector.basicUnsafeRead as i_ - b <- MGVector.basicUnsafeRead bs i_ - return (Mac a b) - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MV_Mac n_ as bs) i_ (Mac a b) - = do - MGVector.basicUnsafeWrite as i_ a - MGVector.basicUnsafeWrite bs i_ b - {-# INLINE basicClear #-} - basicClear (MV_Mac n_ as bs) - = do - MGVector.basicClear as - MGVector.basicClear bs - {-# INLINE basicSet #-} - basicSet (MV_Mac n_ as bs) (Mac a b) - = do - MGVector.basicSet as a - MGVector.basicSet bs b - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_Mac n_1 as1 bs1) (MV_Mac n_2 as2 bs2) - = do - MGVector.basicUnsafeCopy as1 as2 - MGVector.basicUnsafeCopy bs1 bs2 - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MV_Mac n_1 as1 bs1) (MV_Mac n_2 as2 bs2) - = do - MGVector.basicUnsafeMove as1 as2 - MGVector.basicUnsafeMove bs1 bs2 - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow (MV_Mac n_ as bs) m_ - = do - as' <- MGVector.basicUnsafeGrow as m_ - bs' <- MGVector.basicUnsafeGrow bs m_ - return $ MV_Mac (m_+n_) as' bs' -instance GVector.Vector UVector.Vector Mac where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MV_Mac n_ as bs) - = do - as' <- GVector.basicUnsafeFreeze as - bs' <- GVector.basicUnsafeFreeze bs - return $ V_Mac n_ as' bs' - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (V_Mac n_ as bs) - = do - as' <- GVector.basicUnsafeThaw as - bs' <- GVector.basicUnsafeThaw bs - return $ MV_Mac n_ as' bs' - {-# INLINE basicLength #-} - basicLength (V_Mac n_ as bs) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (V_Mac n_ as bs) - = V_Mac m_ (GVector.basicUnsafeSlice i_ m_ as) - (GVector.basicUnsafeSlice i_ m_ bs) - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (V_Mac n_ as bs) i_ - = do - a <- GVector.basicUnsafeIndexM as i_ - b <- GVector.basicUnsafeIndexM bs i_ - return (Mac a b) - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_Mac n_1 as1 bs1) (V_Mac n_2 as2 bs2) - = do - GVector.basicUnsafeCopy as1 as2 - GVector.basicUnsafeCopy bs1 bs2 - {-# INLINE elemseq #-} - elemseq _ (Mac a b) - = GVector.elemseq (undefined :: UVector.Vector a) a - . GVector.elemseq (undefined :: UVector.Vector b) b +newtype instance MUVector.MVector s Mac + = MV_Mac (MUVector.MVector s Word48) + +newtype instance UVector.Vector Mac + = V_Mac (UVector.Vector Word48) diff --git a/test/ArbitraryInstances.hs b/test/ArbitraryInstances.hs --- a/test/ArbitraryInstances.hs +++ b/test/ArbitraryInstances.hs @@ -5,10 +5,13 @@ -- Orphan instances that are needed to make QuickCheck work. -import Net.Types (IPv4(..),IPv4Range(..),Mac(..)) -import Test.QuickCheck (Arbitrary(..)) +import Net.Types (IPv4(..),IPv4Range(..),Mac(..),MacGrouping(..),MacCodec(..)) +import Test.QuickCheck (Arbitrary(..),oneof,Gen,elements) +import Data.Word +import Data.Word.Synthetic deriving instance Arbitrary IPv4 +deriving instance Arbitrary Mac -- This instance can generate masks that exceed the recommended -- length of 32. @@ -16,7 +19,20 @@ arbitrary = fmap fromTuple arbitrary where fromTuple (a,b) = IPv4Range a b -instance Arbitrary Mac where - arbitrary = fmap fromTuple arbitrary - where fromTuple (a,b) = Mac a b +instance Arbitrary Word48 where + arbitrary = fromIntegral <$> (arbitrary :: Gen Word64) + +instance Arbitrary MacCodec where + arbitrary = MacCodec <$> arbitrary <*> arbitrary + +instance Arbitrary MacGrouping where + arbitrary = oneof + [ MacGroupingPairs <$> arbitraryMacSeparator + , MacGroupingTriples <$> arbitraryMacSeparator + , MacGroupingQuadruples <$> arbitraryMacSeparator + , pure MacGroupingNoSeparator + ] + +arbitraryMacSeparator :: Gen Char +arbitraryMacSeparator = elements [':','-','.','_'] diff --git a/test/Bench.hs b/test/Bench.hs --- a/test/Bench.hs +++ b/test/Bench.hs @@ -1,7 +1,7 @@ module Main (main) where import Criterion.Main -import Net.Types (IPv4(..)) +import Net.Types (IPv4(..),MacGrouping(..),MacCodec(..)) import Data.Bits ((.&.),(.|.),shiftR,shiftL,complement) import Data.Monoid ((<>)) import Data.Text.Lazy.Builder.Int (decimal) @@ -9,14 +9,17 @@ import Data.Word import Data.ByteString (ByteString) import Control.Monad.ST -import qualified Data.Text as Text -import qualified Data.ByteString.Char8 as BC8 -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Unsafe as ByteString -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.Builder as TBuilder -import qualified Data.Text.Array as TArray -import qualified Net.IPv4.Text as IPv4_Text +import qualified Data.Text as Text +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Unsafe as ByteString +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.Builder as TBuilder +import qualified Data.Text.Array as TArray +import qualified Net.IPv4.Text as IPv4_Text +import qualified Net.Mac.Text as MacText +import qualified Net.Mac.ByteString.Char8 as MacByteString +import qualified Net.Mac as Mac import qualified Naive import qualified IPv4Text1 @@ -24,6 +27,7 @@ import qualified IPv4ByteString1 import qualified IPv4DecodeText1 import qualified IPv4DecodeText2 +import qualified IPv4TextVariableBuilder import qualified Net.IPv4.ByteString.Char8 as NIPBS @@ -31,11 +35,27 @@ main = do let ipAddr = IPv4 1000000009 ipText = Text.pack "192.168.5.99" + mac = Mac.fromOctets 0xFA 0xBB 0x43 0xA1 0x22 0x09 defaultMain - [ bgroup "IPv4 to Text" + [ bgroup "Mac to Text" + [ bench "Current Implementation, pairs" $ whnf MacText.encode mac + , bench "Current Implementation, no separator" + $ whnf (MacText.encodeWith (MacCodec MacGroupingNoSeparator True)) mac + , bench "Current Implementation, quads" + $ whnf (MacText.encodeWith (MacCodec (MacGroupingQuadruples '-') True)) mac + , bench "Current Implementation, triples" + $ whnf (MacText.encodeWith (MacCodec (MacGroupingQuadruples '.') False)) mac + ] + , bgroup "Mac to ByteString" + [ bench "Current Implementation, pairs" $ whnf MacByteString.encode mac + , bench "Current Implementation, no separator" + $ whnf (MacByteString.encodeWith (MacCodec MacGroupingNoSeparator True)) mac + ] + , bgroup "IPv4 to Text" [ bench "Naive" $ whnf Naive.encodeText ipAddr , bench "Text Builder" $ whnf IPv4Text2.encode ipAddr , bench "Preallocated" $ whnf IPv4Text1.encode ipAddr + , bench "Variable Builder" $ whnf IPv4TextVariableBuilder.encode ipAddr ] , bgroup "IPv4 from Text" [ bench "Naive" $ whnf Naive.decodeText ipText diff --git a/test/IPv4TextVariableBuilder.hs b/test/IPv4TextVariableBuilder.hs new file mode 100644 --- /dev/null +++ b/test/IPv4TextVariableBuilder.hs @@ -0,0 +1,30 @@ +module IPv4TextVariableBuilder where + +import Net.Types (IPv4(..)) +import Data.Text (Text) +import Data.Monoid +import Data.Word +import Data.Bits +import qualified Net.IPv4 as IPv4 +import qualified Data.Text as Text +import qualified Data.Text.Builder.Variable as VB + +encode :: IPv4 -> Text +encode = VB.run variableBuilder + +variableBuilder :: VB.Builder IPv4 +variableBuilder = + VB.contramap (word8At 24) VB.word8 + <> VB.staticCharBmp '.' + <> VB.contramap (word8At 16) VB.word8 + <> VB.staticCharBmp '.' + <> VB.contramap (word8At 8) VB.word8 + <> VB.staticCharBmp '.' + <> VB.contramap (word8At 0) VB.word8 + +word8At :: Int -> IPv4 -> Word8 +word8At i (IPv4 w) = fromIntegral (unsafeShiftR w i) +{-# INLINE word8At #-} + + + diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -8,10 +8,12 @@ import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion,(@?=)) import Numeric (showHex) +import Test.QuickCheck.Property (failed,succeeded,Result(..)) import Data.Word import Net.Types (IPv4(..),IPv4Range(..),Mac(..),IPv6(..)) import qualified Data.Text as Text +import qualified Data.ByteString.Char8 as BC8 import qualified Net.IPv4 as IPv4 import qualified Net.IPv6 as IPv6 import qualified Net.IPv4.Range as IPv4Range @@ -20,6 +22,7 @@ import qualified Net.IPv4.ByteString.Char8 as IPv4ByteString import qualified Net.Mac as Mac import qualified Net.Mac.Text as MacText +import qualified Net.Mac.ByteString.Char8 as MacByteString import qualified Data.Attoparsec.Text as AT @@ -28,6 +31,7 @@ import qualified IPv4Text1 import qualified IPv4Text2 import qualified IPv4ByteString1 +import qualified IPv4TextVariableBuilder main :: IO () main = defaultMain tests @@ -42,9 +46,14 @@ ] ++ testDecodeFailures , testGroup "Currently used MAC Text encode/decode" [ testProperty "Isomorphism" - $ propEncodeDecodeIso MacText.encode MacText.decode + $ propEncodeDecodeIsoSettings MacText.encodeWith MacText.decodeWith , testCase "Encode a MAC Address" testMacEncode ] + , testGroup "Currently used MAC ByteString encode/decode" + [ testProperty "Isomorphism" + $ propEncodeDecodeIsoSettings MacByteString.encodeWith MacByteString.decodeWith + , testCase "Lenient Decoding" testLenientMacByteStringParser + ] , testGroup "Naive IPv4 encode/decode" [ testProperty "Isomorphism" $ propEncodeDecodeIso Naive.encodeText Naive.decodeText @@ -53,6 +62,10 @@ [ testProperty "Identical to Naive" $ propMatching IPv4Text2.encode Naive.encodeText ] + , testGroup "Variable Text Builder IPv4 Text encode/decode" + [ testProperty "Identical to Naive" + $ propMatching IPv4TextVariableBuilder.encode Naive.encodeText + ] , testGroup "Raw byte array IPv4 Text encode/decode" [ testProperty "Identical to Naive" $ propMatching IPv4Text1.encode Naive.encodeText @@ -81,6 +94,20 @@ propEncodeDecodeIso :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool propEncodeDecodeIso f g a = g (f a) == Just a +propEncodeDecodeIsoSettings :: (Eq a,Show a,Show b,Show e) + => (e -> a -> b) -> (e -> b -> Maybe a) -> e -> a -> Result +propEncodeDecodeIsoSettings f g e a = + let fa = f e a + gfa = g e fa + in if gfa == Just a + then succeeded + else failure $ concat + [ "env: ", show e, "\n" + , "x: ", show a, "\n" + , "f(x): ", show fa, "\n" + , "g(f(x)): ", show gfa, "\n" + ] + propMatching :: Eq b => (a -> b) -> (a -> b) -> a -> Bool propMatching f g a = f a == g a @@ -101,6 +128,17 @@ testIPv4Decode = IPv4Text.decode (Text.pack "124.222.255.0") @?= Just (IPv4.fromOctets 124 222 255 0) +testLenientMacByteStringParser :: Assertion +testLenientMacByteStringParser = do + go 0xAB 0x12 0x0F 0x1C 0x88 0x79 + "AB:12:0F:1C:88:79" + go 0xAB 0x12 0x0F 0x0C 0xAA 0x76 + "AB1-20F-0CA-A76" + where + go a b c d e f str = + Just (HexMac (Mac.fromOctets a b c d e f)) + @?= fmap HexMac (MacByteString.decodeLenient (BC8.pack str)) + testIPv6Parser :: Assertion testIPv6Parser = do -- Basic test @@ -150,6 +188,26 @@ testMacEncode :: Assertion testMacEncode = MacText.encode (Mac.fromOctets 0xFF 0x00 0xAB 0x12 0x99 0x0F) @?= Text.pack "ff:00:ab:12:99:0f" + +failure :: String -> Result +failure msg = failed + { reason = msg + , theException = Nothing + } + +newtype HexMac = HexMac { getHexMac :: Mac } + deriving (Eq) + +instance Show HexMac where + showsPrec _ (HexMac v) = + let (a,b,c,d,e,f) = Mac.toOctets v + in showHex a . showChar ':' + . showHex b . showChar ':' + . showHex c . showChar ':' + . showHex d . showChar ':' + . showHex e . showChar ':' + . showHex f + newtype HexIPv6 = HexIPv6 { getHexIPv6 :: IPv6 } deriving (Eq)