metro-transport-crypto (empty) → 0.1.0.0

raw patch · 7 files changed

+379/−0 lines, 7 filesdep +QuickCheckdep +basedep +binarysetup-changed

Dependencies added: QuickCheck, base, binary, bytestring, cryptonite, metro, metro-transport-crypto, quickcheck-instances, text, unliftio

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +3/−0
Setup.hs +2/−0
metro-transport-crypto.cabal +63/−0
src/Metro/TP/Crypto.hs +195/−0
test/Spec.hs +83/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for metro-transport-crypto++## Unreleased changes

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,3 @@+# metro-transport-crypto++Crypto transport for metro

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ metro-transport-crypto.cabal view

@@ -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 <https://github.com/Lupino/metro/tree/master/metro-transport-crypto#readme>+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

+ src/Metro/TP/Crypto.hs view

@@ -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

+ test/Spec.hs view

@@ -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