Internal.hs

{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Copyright   : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Simon Meier <iridcode@gmail.com>
-- Stability   : unstable, private
-- Portability : GHC
--
-- *Warning:* this module is internal. If you find that you need it please
-- contact the maintainers and explain what you are trying to do and discuss
-- what you would need in the public API. It is important that you do this as
-- the module may not be exposed at all in future releases.
--
-- The maintainers are glad to accept patches for further
-- standard encodings of standard Haskell values.
--
-- If you need to write your own builder primitives, then be aware that you are
-- writing code with /all saftey belts off/; i.e.,
-- *this is the code that might make your application vulnerable to buffer-overflow attacks!*
-- The "Data.ByteString.Builder.Prim.Tests" module provides you with
-- utilities for testing your encodings thoroughly.
--
module Data.ByteString.Builder.Prim.Internal (
  -- * Fixed-size builder primitives
    Size
  , FixedPrim
  , fixedEncoding
  , size
  , runF

  , emptyF
  , contramapF
  , pairF
  -- , liftIOF

  , storableToF

  -- * Bounded-size builder primitives
  , BoundedPrim
  , boundedEncoding
  , sizeBound
  , runB

  , emptyB
  , contramapB
  , pairB
  , eitherB
  , condB

  -- , liftIOB

  , toB
  , liftFixedToBounded

  -- , withSizeFB
  -- , withSizeBB

  -- * Shared operators
  , (>$<)
  , (>*<)

  ) where

import Foreign
import Prelude hiding (maxBound)

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 611
-- ghc-6.10 and older do not support {-# INLINE CONLIKE #-}
#define CONLIKE
#endif

------------------------------------------------------------------------------
-- Supporting infrastructure
------------------------------------------------------------------------------

-- | Contravariant functors as in the @contravariant@ package.
class Contravariant f where
    contramap :: (b -> a) -> f a -> f b

infixl 4 >$<

-- | A fmap-like operator for builder primitives, both bounded and fixed size.
--
-- Builder primitives are contravariant so it's like the normal fmap, but
-- backwards (look at the type). (If it helps to remember, the operator symbol
-- is like (<$>) but backwards.)
--
-- We can use it for example to prepend and/or append fixed values to an
-- primitive.
--
-- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'"
-- >  where
-- >    fixed3 = char7 >*< char7 >*< char7
--
-- Note that the rather verbose syntax for composition stems from the
-- requirement to be able to compute the size / size bound at compile time.
--
(>$<) :: Contravariant f => (b -> a) -> f a -> f b
(>$<) = contramap


instance Contravariant FixedPrim where
    contramap = contramapF

instance Contravariant BoundedPrim where
    contramap = contramapB


-- | Type-constructors supporting lifting of type-products.
class Monoidal f where
    pair :: f a -> f b -> f (a, b)

instance Monoidal FixedPrim where
    pair = pairF

instance Monoidal BoundedPrim where
    pair = pairB

infixr 5 >*<

-- | A pairing/concatenation operator for builder primitives, both bounded and
-- fixed size.
--
-- For example,
--
-- > toLazyByteString (primFixed (char7 >*< char7) ('x','y')) = "xy"
--
-- We can combine multiple primitives using '>*<' multiple times.
--
-- > toLazyByteString (primFixed (char7 >*< char7 >*< char7) ('x',('y','z'))) = "xyz"
--
(>*<) :: Monoidal f => f a -> f b -> f (a, b)
(>*<) = pair


-- | The type used for sizes and sizeBounds of sizes.
type Size = Int


------------------------------------------------------------------------------
-- Fixed-size builder primitives
------------------------------------------------------------------------------

-- | A builder primitive that always results in a sequence of bytes of a
-- pre-determined, fixed size.
data FixedPrim a = FE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ())

fixedEncoding :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedEncoding = FE

-- | The size of the sequences of bytes generated by this 'FixedPrim'.
{-# INLINE CONLIKE size #-}
size :: FixedPrim a -> Int
size (FE l _) = l

{-# INLINE CONLIKE runF #-}
runF :: FixedPrim a -> a -> Ptr Word8 -> IO ()
runF (FE _ io) = io

-- | The 'FixedPrim' that always results in the zero-length sequence.
{-# INLINE CONLIKE emptyF #-}
emptyF :: FixedPrim a
emptyF = FE 0 (\_ _ -> return ())

-- | Encode a pair by encoding its first component and then its second component.
{-# INLINE CONLIKE pairF #-}
pairF :: FixedPrim a -> FixedPrim b -> FixedPrim (a, b)
pairF (FE l1 io1) (FE l2 io2) =
    FE (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1))

-- | Change a primitives such that it first applies a function to the value
-- to be encoded.
--
-- Note that primitives are 'Contrafunctors'
-- <http://hackage.haskell.org/package/contravariant>. Hence, the following
-- laws hold.
--
-- >contramapF id = id
-- >contramapF f . contramapF g = contramapF (g . f)
{-# INLINE CONLIKE contramapF #-}
contramapF :: (b -> a) -> FixedPrim a -> FixedPrim b
contramapF f (FE l io) = FE l (\x op -> io (f x) op)

-- | Convert a 'FixedPrim' to a 'BoundedPrim'.
{-# INLINE CONLIKE toB #-}
toB :: FixedPrim a -> BoundedPrim a
toB (FE l io) = BE l (\x op -> io x op >> (return $! op `plusPtr` l))

-- | Lift a 'FixedPrim' to a 'BoundedPrim'.
{-# INLINE CONLIKE liftFixedToBounded #-}
liftFixedToBounded :: FixedPrim a -> BoundedPrim a
liftFixedToBounded = toB

{-# INLINE CONLIKE storableToF #-}
storableToF :: forall a. Storable a => FixedPrim a
storableToF = FE (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x)

{-
{-# INLINE CONLIKE liftIOF #-}
liftIOF :: FixedPrim a -> FixedPrim (IO a)
liftIOF (FE l io) = FE l (\xWrapped op -> do x <- xWrapped; io x op)
-}

------------------------------------------------------------------------------
-- Bounded-size builder primitives
------------------------------------------------------------------------------

-- | A builder primitive that always results in sequence of bytes that is no longer
-- than a pre-determined bound.
data BoundedPrim a = BE {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8))

-- | The bound on the size of sequences of bytes generated by this 'BoundedPrim'.
{-# INLINE CONLIKE sizeBound #-}
sizeBound :: BoundedPrim a -> Int
sizeBound (BE b _) = b

boundedEncoding :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
boundedEncoding = BE

{-# INLINE CONLIKE runB #-}
runB :: BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
runB (BE _ io) = io

-- | Change a 'BoundedPrim' such that it first applies a function to the
-- value to be encoded.
--
-- Note that 'BoundedPrim's are 'Contrafunctors'
-- <http://hackage.haskell.org/package/contravariant>. Hence, the following
-- laws hold.
--
-- >contramapB id = id
-- >contramapB f . contramapB g = contramapB (g . f)
{-# INLINE CONLIKE contramapB #-}
contramapB :: (b -> a) -> BoundedPrim a -> BoundedPrim b
contramapB f (BE b io) = BE b (\x op -> io (f x) op)

-- | The 'BoundedPrim' that always results in the zero-length sequence.
{-# INLINE CONLIKE emptyB #-}
emptyB :: BoundedPrim a
emptyB = BE 0 (\_ op -> return op)

-- | Encode a pair by encoding its first component and then its second component.
{-# INLINE CONLIKE pairB #-}
pairB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b)
pairB (BE b1 io1) (BE b2 io2) =
    BE (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 x2)

-- | Encode an 'Either' value using the first 'BoundedPrim' for 'Left'
-- values and the second 'BoundedPrim' for 'Right' values.
--
-- Note that the functions 'eitherB', 'pairB', and 'contramapB' (written below
-- using '>$<') suffice to construct 'BoundedPrim's for all non-recursive
-- algebraic datatypes. For example,
--
-- @
--maybeB :: BoundedPrim () -> BoundedPrim a -> BoundedPrim (Maybe a)
--maybeB nothing just = 'maybe' (Left ()) Right '>$<' eitherB nothing just
-- @
{-# INLINE CONLIKE eitherB #-}
eitherB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (Either a b)
eitherB (BE b1 io1) (BE b2 io2) =
    BE (max b1 b2)
        (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 op)

-- | Conditionally select a 'BoundedPrim'.
-- For example, we can implement the ASCII primitive that drops characters with
-- Unicode codepoints above 127 as follows.
--
-- @
--charASCIIDrop = 'condB' (< '\128') ('fromF' 'char7') 'emptyB'
-- @
{-# INLINE CONLIKE condB #-}
condB :: (a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB p be1 be2 =
    contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2)


{-
{-# INLINE withSizeFB #-}
withSizeFB :: (Word -> FixedPrim Word) -> BoundedPrim a -> BoundedPrim a
withSizeFB feSize (BE b io) =
    BE (lSize + b)
       (\x op0 -> do let !op1 = op0 `plusPtr` lSize
                     op2 <- io x op1
                     ioSize (fromIntegral $ op2 `minusPtr` op1) op0
                     return op2)
  where
    FE lSize ioSize = feSize (fromIntegral b)


{-# INLINE withSizeBB #-}
withSizeBB :: BoundedPrim Word -> BoundedPrim a -> BoundedPrim a
withSizeBB (BE bSize ioSize) (BE b io) =
    BE (bSize + 2*b)
       (\x op0 -> do let !opTmp = op0 `plusPtr` (bSize + b)
                     opTmp' <- io x opTmp
                     let !s = opTmp' `minusPtr` opTmp
                     op1 <- ioSize (fromIntegral s) op0
                     copyBytes op1 opTmp s
                     return $! op1 `plusPtr` s)

{-# INLINE CONLIKE liftIOB #-}
liftIOB :: BoundedPrim a -> BoundedPrim (IO a)
liftIOB (BE l io) = BE l (\xWrapped op -> do x <- xWrapped; io x op)
-}

------------------------------------------------------------------------------
-- Builder primitives from 'ByteString's.
------------------------------------------------------------------------------

{-
-- | A 'FixedPrim' that always results in the same byte sequence given as a
-- strict 'S.ByteString'. We can use this primitive to insert fixed ...
{-# INLINE CONLIKE constByteStringF #-}
constByteStringF :: S.ByteString -> FixedPrim ()
constByteStringF bs =
    FE len io
  where
    (S.PS fp off len) = bs
    io _ op = do
        copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) len
        touchForeignPtr fp

-- | Encode a fixed-length prefix of a strict 'S.ByteString' as-is. We can use
-- this function to
{-# INLINE byteStringPrefixB #-}
byteStringTakeB :: Int  -- ^ Length of the prefix. It should be smaller than
                        -- 100 bytes, as otherwise
                -> BoundedPrim S.ByteString
byteStringTakeB n0 =
    BE n io
  where
    n = max 0 n0 -- sanitize

    io (S.PS fp off len) op = do
        let !s = min len n
        copyBytes op (unsafeForeignPtrToPtr fp `plusPtr` off) s
        touchForeignPtr fp
        return $! op `plusPtr` s
-}

{-

httpChunkedTransfer :: Builder -> Builder
httpChunkedTransfer =
    encodeChunked 32 (word64HexFixedBound '0')
                     ((\_ -> ('\r',('\n',('\r','\n')))) >$< char8x4)
  where
    char8x4 = toB (char8 >*< char8 >*< char8 >*< char8)



chunked :: Builder -> Builder
chunked = encodeChunked 16 word64VarFixedBound emptyB

-}