diff --git a/binary-strict.cabal b/binary-strict.cabal
--- a/binary-strict.cabal
+++ b/binary-strict.cabal
@@ -1,5 +1,5 @@
 name:            binary-strict
-version:         0.3.0
+version:         0.3.1
 license:         BSD3
 license-file:    LICENSE
 author:          Lennart Kolmodin <kolmodin@dtek.chalmers.se>
@@ -9,7 +9,9 @@
                  package. It's pretty much just a copy and paste job from the
                  original source code. The binary team are currently unsure
                  about their future plans w.r.t. strictness, so this is just a
-                 stop gap measure.
+                 stop gap measure. See
+		 http://www.haskell.org/haskellwiki/DealingWithBinaryData for
+		 documentation.
 synopsis:        Binary deserialisation using strict ByteStrings
 category:        Data, Parsing
 build-depends:   base, containers, array, bytestring>=0.9
@@ -18,9 +20,11 @@
 exposed-modules: Data.Binary.Strict.Get,
                  Data.Binary.Strict.IncrementalGet,
                  Data.Binary.Strict.BitGet,
+                 Data.Binary.Strict.BitPut
                  Data.Binary.Strict.Util
                  Data.Binary.Strict.ByteSet
                  Data.Binary.Strict.Class
+other-modules:   Data.Binary.Strict.BitUtil
 extensions:      CPP, FlexibleContexts
 hs-source-dirs:  src
 extra-source-files: tests/BitGetTest.hs, src/Data/Binary/Strict/Common.h
diff --git a/src/Data/Binary/Strict/BitGet.hs b/src/Data/Binary/Strict/BitGet.hs
--- a/src/Data/Binary/Strict/BitGet.hs
+++ b/src/Data/Binary/Strict/BitGet.hs
@@ -60,7 +60,8 @@
 #include "Common.h"
 
 import qualified Data.ByteString as B
-import qualified Data.ByteString.Internal as B
+import qualified Data.ByteString.Internal as BI
+import Data.Binary.Strict.BitUtil
 import Foreign
 import Data.Bits
 
@@ -95,58 +96,6 @@
 put :: S -> BitGet ()
 put s = BitGet (const (Right (), s))
 
--- | This is used for masking the last byte of a ByteString so that extra
---   bits don't leak in
-topNBits :: Int -> Word8
-topNBits 0 = 0
-topNBits 1 = 0x80
-topNBits 2 = 0xc0
-topNBits 3 = 0xe0
-topNBits 4 = 0xf0
-topNBits 5 = 0xf8
-topNBits 6 = 0xfc
-topNBits 7 = 0xfe
-topNBits x = error ("topNBits undefined for " ++ show x)
-
-bottomNBits :: Int -> Word8
-bottomNBits 0 = 0
-bottomNBits 1 = 0x01
-bottomNBits 2 = 0x03
-bottomNBits 3 = 0x07
-bottomNBits 4 = 0x0f
-bottomNBits 5 = 0x1f
-bottomNBits 6 = 0x3f
-bottomNBits 7 = 0x7f
-bottomNBits x = error ("bottomNBits undefined for " ++ show x)
-
--- | Truncate a ByteString to a given number of bits (counting from the left)
---   by masking out extra bits in the last byte
-leftTruncateBits :: Int -> B.ByteString -> B.ByteString
-leftTruncateBits n = B.take ((n + 7) `div` 8) . snd . B.mapAccumL f n where
-  f bits w | bits >= 8 = (bits - 8, w)
-           | bits == 0 = (0, 0)
-           | otherwise = (0, w .&. topNBits bits)
-
--- | Truncate a ByteString to a given number of bits (counting from the right)
---   by masking out extra bits in the first byte
-rightTruncateBits :: Int -> B.ByteString -> B.ByteString
-rightTruncateBits n bs = B.drop (B.length bs - ((n + 7) `div` 8)) $ snd $ B.mapAccumR f n bs where
-  f bits w | bits >= 8 = (bits - 8, w)
-           | bits == 0 = (0, 0)
-           | otherwise = (0, w .&. bottomNBits bits)
-
--- | Shift the whole ByteString some number of bits left where 0 <= @n@ < 8
-leftShift :: Int -> B.ByteString -> B.ByteString
-leftShift 0 = id
-leftShift n = snd . B.mapAccumR f 0 where
-  f acc b = (b `shiftR` (8 - n), (b `shiftL` n) .|. acc)
-
--- | Shift the whole ByteString some number of bits right where 0 <= @n@ < 8
-rightShift :: Int -> B.ByteString -> B.ByteString
-rightShift 0 = id
-rightShift n = snd . B.mapAccumL f 0 where
-  f acc b = (b .&. (bottomNBits n), (b `shiftR` n) .|. (acc `shiftL` (8 - n)))
-
 -- | Same as the standard splitAt, but in this version both parts share a byte
 --   so that splitting [1,2,3,4] at 2 results in ([1,2], [2, 3, 4]).
 splitAtWithDupByte :: Int -> B.ByteString -> (B.ByteString, B.ByteString)
@@ -196,8 +145,8 @@
 
 getPtr :: Storable a => Int -> BitGet a
 getPtr n = do
-    (fp, o, _) <- readN BRight (n * 8) B.toForeignPtr
-    return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
+    (fp, o, _) <- readN BRight (n * 8) BI.toForeignPtr
+    return . BI.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
 {-# INLINE getPtr #-}
 
 -- | Get a single bit from the input
@@ -266,3 +215,4 @@
 shiftl_w32 = shiftL
 shiftl_w64 = shiftL
 #endif
+
diff --git a/src/Data/Binary/Strict/BitPut.hs b/src/Data/Binary/Strict/BitPut.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Binary/Strict/BitPut.hs
@@ -0,0 +1,109 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Binary.Strict.BitPut
+-- Copyright   : Dominic Steinitz
+-- License     : BSD3-style (see LICENSE)
+--
+-- Maintainer  : Dominic Steinitz <dominic.steinitz@blueyonder.co.uk>
+-- Stability   : experimental
+--
+-- This is the writer dual to BitGet. It allows one to append bits in a monad
+-- and get a strict ByteString as a result. Bits are appended from the MSB of
+-- the first byte towards the LSB of the last byte.
+--
+-- This is best suited to small bit-fields because it accumulates bytes using
+-- snoc, so large results will cause a lot of copying. It would be possible
+-- to switch to using something similar to the Builder monad if need arises.
+-- However, since most protocols only have small bit fields, this should
+-- suffice for many cases.
+-----------------------------------------------------------------------------
+module Data.Binary.Strict.BitPut
+  ( BitPut
+  , runBitPut
+  , putBit
+  , putNBits
+  , putBits
+  , putLeftByteString
+  ) where
+
+import Control.Monad
+import Data.Word (Word8)
+import Data.Bits (shiftL, shiftR, (.&.), (.|.), bitSize, Bits)
+import qualified Data.ByteString as B
+
+import Data.Binary.Strict.BitUtil
+
+-- | The state of the BitPut.
+--   The current offset is in [0..7]. The current byte is packed from MSB, downwards
+data S = S {-# UNPACK #-} !B.ByteString  -- ^ output
+           {-# UNPACK #-} !Word8  -- ^ bit offset in current byte
+           {-# UNPACK #-} !Word8  -- ^ current byte
+           deriving (Show)
+
+newtype BitPut' a = BitPut' { unPut :: S -> (a,S) }
+type BitPut = BitPut' ()
+
+instance Functor BitPut' where
+   fmap f m = BitPut' (\s -> let (a,s') = unPut m s in (f a,s'))
+
+instance Monad BitPut' where
+   return a = BitPut' (\s -> (a,s))
+   m >>= k = BitPut' (\s -> let (a,s')  = unPut m s in unPut (k a) s')
+
+get :: BitPut' S
+get = BitPut' (\s -> (s,s))
+
+put :: S -> BitPut
+put s = BitPut' (const ((), s))
+
+-- | Append a single bit
+putBit :: Bool -> BitPut
+putBit bit = do
+  S bytes boff curr <- get
+  let v = if bit then 1 else 0
+      newCurr = curr .|. (shiftL (fromIntegral v) (fromIntegral (7 - boff)))
+      newBoff = boff + 1
+  if newBoff == 8
+     then put (S (bytes `B.snoc` (curr .|. v)) 0 0)
+     else put (S bytes newBoff newCurr)
+
+-- | Append the bottom n bits of the given bits value. In the case that more
+--   bits are requested than the value provides, this acts as if the value
+--   has as unlimited number of leading 0 bits.
+putNBits :: (Integral a, Bits a) => Int -> a -> BitPut
+putNBits n v
+  | n == 0 = return ()
+  | otherwise = do
+      S bytes boff curr <- get
+      let space = 8 - boff
+      if n < fromIntegral space
+         then do
+           let boff'   = boff + fromIntegral n
+               shifted = (fromIntegral v .&. bottomNBits n) `shiftL` (8 - (fromIntegral boff + n))
+               curr'  = curr .|. shifted
+           put $ S bytes boff' curr'
+         else do
+           let bits = v `shiftR` remainingBits
+               remainingBits = n - fromIntegral space
+               mask = bottomNBits $ fromIntegral space
+               bytes' = bytes `B.snoc` (curr .|. (mask .&. fromIntegral bits))
+           put $ S bytes' 0 0
+           putNBits remainingBits v
+
+-- | Append a value. Note that this function is undefined for instances of Bits
+--   which have no fixed bitsize (like Integer)
+putBits :: (Integral a, Bits a) => a -> BitPut
+putBits v = putNBits (bitSize v) v
+
+-- | Append the first n bits of a left aligned ByteString.
+putLeftByteString :: Int -> B.ByteString -> BitPut
+putLeftByteString bits bs
+  | bits < 8 = putNBits bits $ B.head bs
+  | otherwise = putBits (B.head bs) >> putLeftByteString (bits - 8) (B.tail bs)
+
+runBitPut :: BitPut -> B.ByteString
+runBitPut m = r where
+   (_, (S bytes boff curr)) = unPut m (S B.empty 0 0)
+   r = if boff > 0
+          then bytes `B.snoc` (topNBits (fromIntegral boff) .&. curr)
+          else bytes
diff --git a/src/Data/Binary/Strict/BitUtil.hs b/src/Data/Binary/Strict/BitUtil.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Binary/Strict/BitUtil.hs
@@ -0,0 +1,67 @@
+module Data.Binary.Strict.BitUtil
+  ( topNBits
+  , bottomNBits
+  , leftShift
+  , rightShift
+  , leftTruncateBits
+  , rightTruncateBits
+  ) where
+
+import Data.Word (Word8)
+import qualified Data.ByteString as B
+import Data.Bits (shiftL, shiftR, (.|.), (.&.))
+
+-- | This is used for masking the last byte of a ByteString so that extra
+--   bits don't leak in
+topNBits :: Int -> Word8
+topNBits 0 = 0
+topNBits 1 = 0x80
+topNBits 2 = 0xc0
+topNBits 3 = 0xe0
+topNBits 4 = 0xf0
+topNBits 5 = 0xf8
+topNBits 6 = 0xfc
+topNBits 7 = 0xfe
+topNBits 8 = 0xff
+topNBits x = error ("topNBits undefined for " ++ show x)
+
+-- | Return a Word8 with the bottom n bits set
+bottomNBits :: Int -> Word8
+bottomNBits 0 = 0
+bottomNBits 1 = 0x01
+bottomNBits 2 = 0x03
+bottomNBits 3 = 0x07
+bottomNBits 4 = 0x0f
+bottomNBits 5 = 0x1f
+bottomNBits 6 = 0x3f
+bottomNBits 7 = 0x7f
+bottomNBits 8 = 0xff
+bottomNBits x = error ("bottomNBits undefined for " ++ show x)
+
+-- | Shift the whole ByteString some number of bits left where 0 <= @n@ < 8
+leftShift :: Int -> B.ByteString -> B.ByteString
+leftShift 0 = id
+leftShift n = snd . B.mapAccumR f 0 where
+  f acc b = (b `shiftR` (8 - n), (b `shiftL` n) .|. acc)
+
+-- | Shift the whole ByteString some number of bits right where 0 <= @n@ < 8
+rightShift :: Int -> B.ByteString -> B.ByteString
+rightShift 0 = id
+rightShift n = snd . B.mapAccumL f 0 where
+  f acc b = (b .&. (bottomNBits n), (b `shiftR` n) .|. (acc `shiftL` (8 - n)))
+
+-- | Truncate a ByteString to a given number of bits (counting from the left)
+--   by masking out extra bits in the last byte
+leftTruncateBits :: Int -> B.ByteString -> B.ByteString
+leftTruncateBits n = B.take ((n + 7) `div` 8) . snd . B.mapAccumL f n where
+  f bits w | bits >= 8 = (bits - 8, w)
+           | bits == 0 = (0, 0)
+           | otherwise = (0, w .&. topNBits bits)
+
+-- | Truncate a ByteString to a given number of bits (counting from the right)
+--   by masking out extra bits in the first byte
+rightTruncateBits :: Int -> B.ByteString -> B.ByteString
+rightTruncateBits n bs = B.drop (B.length bs - ((n + 7) `div` 8)) $ snd $ B.mapAccumR f n bs where
+  f bits w | bits >= 8 = (bits - 8, w)
+           | bits == 0 = (0, 0)
+           | otherwise = (0, w .&. bottomNBits bits)