diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for metro-transport-crypto + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Lupino (c) 2020 + +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 Lupino 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# metro-transport-crypto + +Crypto transport for metro diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/metro-transport-crypto.cabal b/metro-transport-crypto.cabal new file mode 100644 --- /dev/null +++ b/metro-transport-crypto.cabal @@ -0,0 +1,63 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: daac6f846feccd072db89c9c2401975c729e9d8762a278f2d768636f475d6ec5 + +name: metro-transport-crypto +version: 0.1.0.0 +synopsis: Crypto transport for metro +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/Lupino/metro#readme +bug-reports: https://github.com/Lupino/metro/issues +author: Lupino +maintainer: lmjubuntu@gmail.com +copyright: MIT +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/Lupino/metro + +library + exposed-modules: + Metro.TP.Crypto + other-modules: + Paths_metro_transport_crypto + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , binary + , bytestring + , cryptonite + , metro + , text + , unliftio + default-language: Haskell2010 + +test-suite metro-transport-crypto-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_metro_transport_crypto + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , base >=4.7 && <5 + , bytestring + , cryptonite + , metro + , metro-transport-crypto + , quickcheck-instances + default-language: Haskell2010 diff --git a/src/Metro/TP/Crypto.hs b/src/Metro/TP/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Metro/TP/Crypto.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Metro.TP.Crypto + ( Crypto + , crypto + , crypto_ + , CryptoMethod (..) + , methodEcb + , methodCbc + , methodCfb + , methodCtr + + , makeCrypto + ) where + +import Control.Monad (when) +import Crypto.Cipher.Types (BlockCipher (..), Cipher (..), IV (..), + KeySizeSpecifier (..), ivAdd, nullIV) +import Crypto.Error (CryptoFailable (..)) +import Data.Binary (Binary (..), decode, encode) +import Data.Binary.Get (getByteString, getWord32be) +import Data.Binary.Put (putByteString, putWord32be) +import Data.ByteString (ByteString, empty) +import qualified Data.ByteString as B (append, length, replicate, take) +import Data.ByteString.Lazy (fromStrict, toStrict) +import qualified Data.ByteString.Lazy as LB (cycle, fromStrict, take, toStrict) +import qualified Data.Text as T (pack) +import Data.Text.Encoding (encodeUtf8) +import Metro.Class (Transport (..)) +import Metro.Utils (recvEnough) +import UnliftIO + +newtype BlockLength = BlockLength Int + deriving (Show, Eq) + +instance Binary BlockLength where + get = BlockLength . fromIntegral <$> getWord32be + put (BlockLength l) = putWord32be $ fromIntegral l + +data Block = Block + { msgSize :: !Int + , encData :: !ByteString + } + deriving (Show, Eq) + +instance Binary Block where + get = do + pktSize <- fromIntegral <$> getWord32be + msgSize <- fromIntegral <$> getWord32be + encData <- getByteString $ pktSize - 4 + return Block {..} + put Block {..} = do + putWord32be $ fromIntegral $ B.length encData + 4 + putWord32be $ fromIntegral msgSize + putByteString encData + +makeBlock :: Int -> ByteString -> Block +makeBlock bSize msg = Block size msg0 + where size = B.length msg + fixedSize = ceiling (fromIntegral size / fromIntegral bSize * 1.0) * bSize + msg0 = if size < fixedSize then msg `B.append` B.replicate (fixedSize - size) 0 + else msg + +getMsg :: Block -> ByteString +getMsg Block {..} = B.take msgSize encData + +prepareBlock + :: BlockCipher cipher + => (cipher -> IV cipher -> ByteString -> ByteString) + -> cipher -> IV cipher -> Block -> Block +prepareBlock f c iv b = b { encData = f c iv (encData b) } + +data CryptoMethod cipher = CryptoMethod + { encrypt :: cipher -> IV cipher -> ByteString -> ByteString + , decrypt :: cipher -> IV cipher -> ByteString -> ByteString + , needIV :: Bool + } + +data Crypto cipher tp = Crypto + { readBuffer :: TVar ByteString + , cryptoMethod :: CryptoMethod cipher + , readIV :: TVar (IV cipher) + , writeIV :: TVar (IV cipher) + , cipher :: cipher + , tp :: tp + } + +instance (Transport tp, BlockCipher cipher) => Transport (Crypto cipher tp) where + data TransportConfig (Crypto cipher tp) = + CryptoConfig (CryptoMethod cipher) cipher (IV cipher) (TransportConfig tp) + newTransport (CryptoConfig cryptoMethod cipher iv config) = do + readBuffer <- newTVarIO empty + tp <- newTransport config + readIV <- newTVarIO iv + writeIV <- newTVarIO iv + return Crypto {..} + recvData (Crypto buf method ivr _ cipher tp) _ = do + hbs <- recvEnough buf tp 4 + iv <- readTVarIO ivr + case decode (fromStrict hbs) of + BlockLength len -> do + bs <- getMsg + . prepareBlock (decrypt method) cipher iv + . decode + . fromStrict + . (hbs <>) <$> recvEnough buf tp len + + when (needIV method) $ + atomically $ writeTVar ivr (ivAdd iv (B.length bs)) + + return bs + sendData (Crypto _ method _ ivw cipher tp) bs = do + iv <- readTVarIO ivw + + when (needIV method) $ + atomically $ writeTVar ivw (ivAdd iv (B.length bs)) + + sendData tp + . toStrict + . encode + . prepareBlock (encrypt method) cipher iv + $ makeBlock (blockSize cipher) bs + closeTransport (Crypto _ _ _ _ _ tp) = closeTransport tp + +crypto + :: BlockCipher cipher + => CryptoMethod cipher + -> cipher + -> TransportConfig tp + -> TransportConfig (Crypto cipher tp) +crypto method cipher = crypto_ method cipher nullIV + +crypto_ + :: BlockCipher cipher + => CryptoMethod cipher + -> cipher + -> IV cipher + -> TransportConfig tp + -> TransportConfig (Crypto cipher tp) +crypto_ = CryptoConfig + +methodEcb :: BlockCipher cipher => CryptoMethod cipher +methodEcb = CryptoMethod (ignoreIV ecbEncrypt) (ignoreIV ecbDecrypt) False + where ignoreIV f c _ = f c + +methodCbc :: BlockCipher cipher => CryptoMethod cipher +methodCbc = CryptoMethod cbcEncrypt cbcDecrypt True + +methodCfb :: BlockCipher cipher => CryptoMethod cipher +methodCfb = CryptoMethod cfbEncrypt cfbDecrypt True + +methodCtr :: BlockCipher cipher => CryptoMethod cipher +methodCtr = CryptoMethod ctrCombine ctrCombine True + +getCryptoMethod :: BlockCipher cipher => cipher -> String -> Maybe (CryptoMethod cipher) +getCryptoMethod _ "CBC" = Just methodCbc +getCryptoMethod _ "cbc" = Just methodCbc +getCryptoMethod _ "CFB" = Just methodCfb +getCryptoMethod _ "cfb" = Just methodCfb +getCryptoMethod _ "ECB" = Just methodEcb +getCryptoMethod _ "ecb" = Just methodEcb +getCryptoMethod _ "CTR" = Just methodCtr +getCryptoMethod _ "ctr" = Just methodCtr +getCryptoMethod _ _ = Nothing + +makeCrypto + :: forall cipher tp. (BlockCipher cipher, Cipher cipher) + => cipher -> String -> String -> TransportConfig tp -> TransportConfig (Crypto cipher tp) +makeCrypto cipher method key c = + case getCryptoMethod cipher method of + Nothing -> error "crypto method not support" + Just m -> + case cipherInit key0 of + CryptoFailed e -> error $ "Cipher init failed " ++ show e + CryptoPassed (newCipher :: cipher) -> + crypto m newCipher c + + where size = getKeySize $ cipherKeySize cipher + key0 = + LB.toStrict + . LB.take (fromIntegral size) + . LB.cycle + . LB.fromStrict + . encodeUtf8 + $ T.pack key + + +getKeySize :: KeySizeSpecifier -> Int +getKeySize (KeySizeRange _ x) = x +getKeySize (KeySizeEnum xs) = maximum xs +getKeySize (KeySizeFixed x) = x diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,83 @@ +import Control.Monad (unless) +import Crypto.Cipher.AES +import Crypto.Cipher.Blowfish +import Crypto.Cipher.Camellia +import Crypto.Cipher.CAST5 +import Crypto.Cipher.DES +import Crypto.Cipher.TripleDES +import Crypto.Cipher.Twofish +import Crypto.Cipher.Types (BlockCipher (..), + Cipher (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B (length, null) +import Metro.Class (Transport (..)) +import Metro.TP.BS (makePipe) +import Metro.TP.Crypto +import Test.QuickCheck +import Test.QuickCheck.Instances.ByteString () +import Test.QuickCheck.Monadic + +mkTP + :: (Transport tp, Cipher cipher, BlockCipher cipher) + => cipher -> String -> String -> TransportConfig tp -> IO (Crypto cipher tp) +mkTP cipher method key tpc = + newTransport $ makeCrypto cipher method key tpc + +testPipe + :: (Transport tp, Cipher cipher, BlockCipher cipher) + => Crypto cipher tp -> Crypto cipher tp -> ByteString -> IO Bool +testPipe pipeL pipeR bs = + if B.null bs then return True + else do + sendData pipeL bs + bs0 <- recvData pipeR $ B.length bs + return $ bs == bs0 + +testCrypto + :: (Cipher cipher, BlockCipher cipher) + => cipher -> String -> [ByteString] -> String -> Property +testCrypto cipher method bss key = monadicIO $ + unless (null key) $ do + (pipeLC, pipeRC) <- run makePipe + + pipeL <- run $ mkTP cipher method key pipeLC + pipeR <- run $ mkTP cipher method key pipeRC + + r <- and <$> mapM (run . testPipe pipeL pipeR) bss + assert r + +testCrypto1 + :: (Cipher cipher, BlockCipher cipher) + => cipher -> String -> IO () +testCrypto1 cipher method = + quickCheck $ withMaxSuccess 10 (testCrypto cipher method) + +methods :: [String] +methods = [ "CBC", "cbc", "CFB", "cfb", "ECB", "ecb", "CTR", "ctr" ] + +main :: IO () +main = do + mapM_ (testCrypto1 (undefined :: AES128)) methods + mapM_ (testCrypto1 (undefined :: AES192)) methods + mapM_ (testCrypto1 (undefined :: AES256)) methods + + mapM_ (testCrypto1 (undefined :: Blowfish)) methods + mapM_ (testCrypto1 (undefined :: Blowfish64)) methods + mapM_ (testCrypto1 (undefined :: Blowfish128)) methods + mapM_ (testCrypto1 (undefined :: Blowfish256)) methods + mapM_ (testCrypto1 (undefined :: Blowfish448)) methods + + mapM_ (testCrypto1 (undefined :: CAST5)) methods + + mapM_ (testCrypto1 (undefined :: Camellia128)) methods + + mapM_ (testCrypto1 (undefined :: DES)) methods + + mapM_ (testCrypto1 (undefined :: DES_EEE3)) methods + mapM_ (testCrypto1 (undefined :: DES_EDE3)) methods + mapM_ (testCrypto1 (undefined :: DES_EEE2)) methods + mapM_ (testCrypto1 (undefined :: DES_EDE2)) methods + + mapM_ (testCrypto1 (undefined :: Twofish128)) methods + mapM_ (testCrypto1 (undefined :: Twofish192)) methods + mapM_ (testCrypto1 (undefined :: Twofish256)) methods