module Net.Mac.ByteString.Char8
( encode
, encodeWith
, decode
, decodeWith
, decodeLenient
, builder
, parser
, parserWith
, parserLenient
) where
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,c2w)
import Data.Text.Encoding (encodeUtf8, decodeUtf8')
import Data.Word (Word8)
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
encode :: Mac -> ByteString
encode = encodeWith defCodec
decode :: ByteString -> Maybe Mac
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)
builder :: Mac -> Builder
builder = Builder.byteString . encode
parser :: Parser Mac
parser = parserWith defCodec
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
<*> parseTwoHex
<*> parseTwoHex
<*> parseTwoHex
<*> parseTwoHex
<*> parseTwoHex
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
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)
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 = a
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)
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
withCasedBuilderTriple :: Bool -> (FB.Builder Word12 -> a) -> a
withCasedBuilderTriple x f = case x of
True -> f FB.word12HexFixedUpper
False -> f FB.word12HexFixedLower
data Pair = Pair
{ pairSep :: !Word8
, pairMac :: !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
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
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
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
word8At :: Int -> Mac -> Word8
word8At i (Mac w) = fromIntegral (unsafeShiftR w i)
word12At :: Int -> Mac -> Word12
word12At i (Mac w) = fromIntegral (unsafeShiftR w i)