Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial code.

  • Loading branch information...
commit 4cc61209bc07935cceba99485120a2db06898d6a 1 parent e996137
@meteficha meteficha authored
View
2  .gitignore
@@ -0,0 +1,2 @@
+/dist
+*~
View
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2012, Felipe Lessa
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Felipe Lessa nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
35 crypto-conduit.cabal
@@ -0,0 +1,35 @@
+Cabal-version: >=1.2
+Name: crypto-conduit
+Version: 0.1
+Synopsis: Conduit interface for cryptographic operations (from crypto-api).
+Homepage: https://github.com/meteficha/crypto-conduit
+License: BSD3
+License-file: LICENSE
+Author: Felipe Lessa <felipe.lessa@gmail.com>
+Maintainer: Felipe Lessa <felipe.lessa@gmail.com>
+Category: Cryptography
+Build-type: Simple
+
+Description:
+ This package contains everything that you need to use a
+ cryptographic package that supports the @crypto-api@ package
+ using conduits from the @conduit@ package.
+
+Extra-source-files:
+ README
+
+Source-repository head
+ Type: git
+ Location: git://github.com/meteficha/crypto-conduit.git
+
+Library
+ Hs-Source-Dirs: src
+ Exposed-modules:
+ Crypto.Conduit
+ Build-depends:
+ base >= 3 && < 5,
+ bytestring >= 0.9 && < 0.10,
+ cereal >= 0.3 && < 0.4,
+ crypto-api >= 0.8 && < 0.9,
+ conduit >= 0.0 && < 0.1
+ GHC-options: -Wall
View
411 src/Crypto/Conduit.hs
@@ -0,0 +1,411 @@
+{-# LANGUAGE BangPatterns #-}
+-- | This module contains wrappers for cryptographic functions
+-- using the @conduit@ package. Currently there is support for
+-- hashes, HMACs and many modes of block ciphers (but not
+-- everything @crypto-api@ supports has a counterpart here).
+-- All functions on this package work in constant memory.
+module Crypto.Conduit
+ ( -- * Cryptographic hash functions
+ sinkHash
+
+ -- * Hash-based message authentication code (HMAC)
+ , sinkHmac
+
+ -- * Block ciphers
+ -- ** Electronic codebook mode (ECB)
+ , conduitEncryptEcb
+ , conduitDecryptEcb
+ -- ** Cipher-block chaining mode (CBC)
+ , conduitEncryptCbc
+ , conduitDecryptCbc
+ -- ** Cipher feedback mode (CFB)
+ , conduitEncryptCfb
+ , conduitDecryptCfb
+ -- ** Output feedback mode (OFB)
+ , conduitEncryptOfb
+ , conduitDecryptOfb
+ -- ** Counter mode (CTR)
+ , conduitEncryptCtr
+ , conduitDecryptCtr
+ , sourceCtr
+ -- ** Cipher-block chaining message authentication code (CBC-MAC)
+ , sinkCbcMac
+
+ -- * Helpers
+ , blocked
+ , BlockMode(..)
+ , Block(..)
+ ) where
+
+-- from base
+import Control.Applicative ((<$>))
+import Control.Arrow (first)
+import Data.Bits (xor)
+
+-- from bytestring
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+
+-- from cereal
+import qualified Data.Serialize as S
+
+-- from crypto-api
+import Crypto.Classes ((.::.))
+import qualified Crypto.Classes as C
+import qualified Crypto.HMAC as C
+import qualified Crypto.Modes as C
+--import qualified Crypto.Padding as C
+--import qualified Crypto.Random as C
+import qualified Crypto.Types as C
+
+-- from conduit
+import Data.Conduit
+
+
+-- | Helper to get our return type.
+getType :: Monad m => sink input m output -> output
+getType = undefined
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Sink' that hashes a stream of 'B.ByteString'@s@ and
+-- creates a digest @d@.
+sinkHash :: (Resource m, C.Hash ctx d) => Sink B.ByteString m d
+sinkHash = blocked AnyMultiple blockSize =$ sink
+ where
+ sink = sinkState C.initialCtx
+ push
+ (const $ fail "sinkHash")
+
+ push ctx (Full bs) =
+ let !ctx' = C.updateCtx ctx bs
+ in return (ctx', Processing)
+ push ctx (LastOne bs) =
+ let !ret = C.finalize ctx bs
+ in return (error "sinkHash", Done Nothing ret)
+
+ blockSize = (C.blockLength .::. getType sink) `div` 8
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Sink' that computes the HMAC of a stream of
+-- 'B.ByteString'@s@ and creates a digest @d@.
+sinkHmac :: (Resource m, C.Hash ctx d) => C.MacKey -> Sink B.ByteString m d
+sinkHmac (C.MacKey key) = blocked AnyMultiple blockSize =$ sink
+ where
+ --------- Taken and modified from Crypto.HMAC:
+ key' =
+ case B.length key `compare` blockSize of
+ GT -> B.append
+ (S.encode $ C.hashFunc' d key)
+ (B.replicate (blockSize - outputSize) 0x00)
+ EQ -> key
+ LT -> B.append key (B.replicate (blockSize - B.length key) 0x00)
+ ko = B.map (`xor` 0x5c) key'
+ ki = B.map (`xor` 0x36) key'
+ ---------
+
+ sink = sinkState (C.updateCtx C.initialCtx ki)
+ push
+ (const $ fail "sinkHmac")
+
+ push ctx (Full bs) =
+ let !ctx' = C.updateCtx ctx bs
+ in return (ctx', Processing)
+ push ctx (LastOne bs) =
+ let !inner = C.finalize ctx bs `asTypeOf` d
+ !outer = C.hash $ L.fromChunks [ko, S.encode inner]
+ in return (error "sinkHmac", Done Nothing outer)
+
+ d = getType sink
+ blockSize = (C.blockLength .::. d) `div` 8
+ outputSize = (C.outputLength .::. d) `div` 8
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Conduit' that encrypts a stream of 'B.ByteString'@s@
+-- using ECB mode. Expects the input length to be a multiple of
+-- the block size of the cipher and fails otherwise. (Note that
+-- ECB has many undesirable cryptographic properties, please
+-- avoid it if you don't know what you're doing.)
+conduitEncryptEcb :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> Conduit B.ByteString m B.ByteString
+conduitEncryptEcb k =
+ blockCipherConduit k
+ AnyMultiple
+ ()
+ (\_ input -> ((), C.encryptBlock k input))
+ (\_ _ -> fail "conduitEncryptEcb: input has an incomplete final block.")
+
+
+-- | A 'Conduit' that decrypts a stream of 'B.ByteString'@s@
+-- using ECB mode. Expects the input length to be a multiple of
+-- the block size of the cipher and fails otherwise.
+conduitDecryptEcb :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> Conduit B.ByteString m B.ByteString
+conduitDecryptEcb k =
+ blockCipherConduit k
+ AnyMultiple
+ ()
+ (\_ input -> ((), C.decryptBlock k input))
+ (\_ _ -> fail "conduitDecryptEcb: input has an incomplete final block.")
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Conduit' that encrypts a stream of 'B.ByteString'@s@
+-- using CBC mode. Expects the input length to be a multiple of
+-- the block size of the cipher and fails otherwise.
+conduitEncryptCbc :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Conduit B.ByteString m B.ByteString
+conduitEncryptCbc k iv =
+ blockCipherConduit k
+ StrictBlockSize
+ (S.encode iv)
+ (\iv' input -> let output = C.encryptBlock k (iv' `zwp` input)
+ in (output, output))
+ (\_ _ -> fail "conduitEncryptCbc: input has an incomplete final block.")
+
+
+-- | A 'Conduit' that decrypts a stream of 'B.ByteString'@s@
+-- using CBC mode. Expects the input length to be a multiple of
+-- the block size of the cipher and fails otherwise.
+conduitDecryptCbc :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Conduit B.ByteString m B.ByteString
+conduitDecryptCbc k iv =
+ blockCipherConduit k
+ StrictBlockSize
+ (S.encode iv)
+ (\iv' input -> let inter = C.decryptBlock k input
+ in (inter, iv' `zwp` inter))
+ (\_ _ -> fail "conduitDecryptCbc: input has an incomplete final block.")
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Conduit' that encrypts a stream of 'B.ByteString'@s@
+-- using CFB mode. Expects the input length to be a multiple of
+-- the block size of the cipher and fails otherwise.
+conduitEncryptCfb :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Conduit B.ByteString m B.ByteString
+conduitEncryptCfb k iv =
+ blockCipherConduit k
+ StrictBlockSize
+ (S.encode iv)
+ (\iv' input -> let output = C.encryptBlock k iv' `zwp` input
+ in (output, output))
+ (\_ _ -> fail "conduitEncryptCfb: input has an incomplete final block.")
+
+
+-- | A 'Conduit' that decrypts a stream of 'B.ByteString'@s@
+-- using CFB mode. Expects the input length to be a multiple of
+-- the block size of the cipher and fails otherwise.
+conduitDecryptCfb :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Conduit B.ByteString m B.ByteString
+conduitDecryptCfb k iv =
+ blockCipherConduit k
+ StrictBlockSize
+ (S.encode iv)
+ (\iv' input -> let output = C.encryptBlock k iv' `zwp` input
+ in (input, output))
+ (\_ _ -> fail "conduitDecryptCfb: input has an incomplete final block.")
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Conduit' that encrypts a stream of 'B.ByteString'@s@
+-- using OFB mode. Expects the input length to be a multiple of
+-- the block size of the cipher and fails otherwise.
+conduitEncryptOfb :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Conduit B.ByteString m B.ByteString
+conduitEncryptOfb k iv =
+ blockCipherConduit k
+ StrictBlockSize
+ (S.encode iv)
+ (\iv' input -> let inter = C.encryptBlock k iv'
+ in (inter, inter `zwp` input))
+ (\_ _ -> fail "conduitEncryptOfb: input has an incomplete final block.")
+
+
+-- | Synonym for 'conduitEncryptOfb', since for OFB mode both
+-- encryption and decryption are the same.
+conduitDecryptOfb :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Conduit B.ByteString m B.ByteString
+conduitDecryptOfb = conduitEncryptOfb
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Conduit' that encrypts a stream of 'B.ByteString'@s@
+-- using CTR mode. The input may have any length, even
+-- non-multiples of the block size.
+conduitEncryptCtr :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Conduit B.ByteString m B.ByteString
+conduitEncryptCtr k iv =
+ blockCipherConduit k
+ StrictBlockSize
+ iv
+ (\iv' input -> let !iv'' = C.incIV iv'
+ output = C.encryptBlock k (S.encode iv') `zwp` input
+ in (iv'', output))
+ (\iv' input -> let output = C.encryptBlock k (S.encode iv') `zwp` input
+ in return output)
+
+
+-- | Synonym for 'conduitEncryptCtr', since for CTR mode both
+-- encryption and decryption are the same.
+conduitDecryptCtr :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Conduit B.ByteString m B.ByteString
+conduitDecryptCtr = conduitEncryptCtr
+
+
+-- | An infinite stream of bytes generated by a block cipher on
+-- CTR mode.
+sourceCtr :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> C.IV k -- ^ Initialization vector.
+ -> Source m B.ByteString
+sourceCtr k iv = sourceState iv pull
+ where
+ pull iv' =
+ let !iv'' = C.incIV iv'
+ block = C.encryptBlock k $ S.encode iv'
+ in return (iv'', Open block)
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Sink' that computes the CBC-MAC of a stream of
+-- 'B.ByteString'@s@ and creates a digest @d@. Expects the input
+-- length to be a multiple of the block size of the cipher and
+-- fails otherwise. (Note that CBC-MAC is not secure for
+-- variable-length messages.)
+sinkCbcMac :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key.
+ -> Sink B.ByteString m B.ByteString
+sinkCbcMac k = blocked StrictBlockSize blockSize =$ sink
+ where
+ sink = sinkState (B.replicate blockSize 0) push close
+
+ push iv (Full input) =
+ let !iv' = C.encryptBlock k (iv `zwp` input)
+ in return (iv', Processing)
+ push iv (LastOne input)
+ | B.null input = return (error "sinkCbcMac", Done Nothing iv)
+ | otherwise = fail "sinkCbcMac: input has an incomplete final block."
+
+ close _ = fail "sinkCbcMac"
+
+ blockSize = (C.blockSize .::. k) `div` 8
+
+
+----------------------------------------------------------------------
+
+
+-- | A 'Conduit' that takes arbitrary 'B.ByteString'@s@ and
+-- outputs 'Block'@s@. Each 'Full' block will have a length that
+-- is multiple of the given block size (either exactly the block
+-- size or a multiple of at least 1x the block size, depending on
+-- the 'BlockMode'). All 'Block'@s@ beside the last one will be
+-- 'Full'. The last block will always be 'LastOne' with less
+-- bytes than the block size, possibly zero.
+blocked :: Resource m =>
+ BlockMode
+ -> C.ByteLength -- ^ Block size
+ -> Conduit B.ByteString m Block
+blocked mode blockSize = conduitState B.empty push close
+ where
+ block = case mode of
+ StrictBlockSize -> blockStrict []
+ AnyMultiple -> blockAny
+ where
+ blockStrict acc bs
+ | B.length bs < blockSize = (reverse acc, bs)
+ | otherwise = blockStrict (Full this : acc) rest
+ where (this, rest) = B.splitAt blockSize bs
+
+ blockAny bs = first ((:[]) . Full) $ B.splitAt (n * blockSize) bs
+ where n = B.length bs `div` blockSize
+
+ append bs1 bs2
+ | B.null bs1 = bs2
+ | otherwise = B.append bs1 bs2
+
+ push acc = return . mk . block . append acc
+ where
+ mk (blks, rest) = (rest, Producing blks)
+
+ close = return . (:[]) . LastOne
+
+
+-- | How 'Block's should be returned, either with strictly the
+-- block size or with a multiple of at least 1x the block size.
+data BlockMode = StrictBlockSize | AnyMultiple
+
+
+-- | A block returned by 'blocked'.
+data Block = Full B.ByteString | LastOne B.ByteString
+
+
+-- | Constructs a 'Conduit' for a 'BlockCipher'.
+blockCipherConduit :: (Resource m, C.BlockCipher k) =>
+ k -- ^ Cipher key (not used, just for getting block size).
+ -> BlockMode
+ -> s -- ^ Initial state.
+ -> (s -> B.ByteString -> (s, B.ByteString)) -- ^ Encrypt block.
+ -> (s -> B.ByteString -> ResourceT m B.ByteString) -- ^ Final encryption.
+ -> Conduit B.ByteString m B.ByteString
+blockCipherConduit key mode initialState apply final = blocked mode blockSize =$= conduit
+ where
+ blockSize = (C.blockSize .::. key) `div` 8
+
+ conduit = conduitState initialState push close
+
+ push state (Full input) =
+ let (!state', !output) = apply state input
+ in return (state', Producing [output])
+ push state (LastOne input) = mk <$> final state input
+ where mk output = (error "blockCipherConduit", Finished Nothing [output])
+
+ close _ = fail "blockCipherConduit"
+
+
+-- | zipWith xor + pack
+--
+-- As a result of rewrite rules, this should automatically be
+-- optimized (at compile time) to use the bytestring libraries
+-- 'zipWith'' function.
+--
+-- Taken from crypto-api.
+zwp :: B.ByteString -> B.ByteString -> B.ByteString
+zwp a = B.pack . B.zipWith xor a
+{-# INLINEABLE zwp #-}
Please sign in to comment.
Something went wrong with that request. Please try again.