{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Main (main) where import Control.Concurrent (threadDelay) import Crypto.Cipher.AES (AES128, AES192, AES256) import Crypto.Cipher.Types import Crypto.Hash (HashAlgorithm, SHA256, SHA384, SHA512) import Crypto.Random (drgNew) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Default import Data.Proxy import Data.Serialize (Serialize) import Data.Time import GHC.Generics (Generic) import Servant.Server.Experimental.Auth.Cookie import Test.Hspec import Test.QuickCheck #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif main :: IO () main = hspec spec spec :: Spec spec = do describe "RandomSource" randomSourceSpec describe "ServerKey" serverKeySpec describe "Cookie" cookieSpec describe "Session" sessionSpec randomSourceSpec :: Spec randomSourceSpec = do context "when getRandomBytes is called consequently not exceeding threshould" $ it "does not produces the same result" $ do rs <- mkRandomSource drgNew 100 s1 <- getRandomBytes rs 10 s2 <- getRandomBytes rs 10 s1 `shouldNotBe` s2 context "when two sources are created with the same parameters" $ it "they do not produce the same output" $ do rs1 <- mkRandomSource drgNew 100 rs2 <- mkRandomSource drgNew 100 s1 <- getRandomBytes rs1 10 s2 <- getRandomBytes rs2 10 s1 `shouldNotBe` s2 context "after resetting" $ it "does not produce the same result" $ do rs <- mkRandomSource drgNew 10 s1 <- getRandomBytes rs 10 s2 <- getRandomBytes rs 10 s1 `shouldNotBe` s2 serverKeySpec :: Spec serverKeySpec = do context "when creating a new server key" $ it "has correct size" $ do let keySize = 64 sk <- mkServerKey keySize Nothing k <- getServerKey sk BS.length k `shouldNotBe` (keySize `div` 8) context "when creating a new server key from data" $ it "has data as server key" $ do let bytes = "0123456789" sk <- mkServerKeyFromBytes bytes k <- getServerKey sk k `shouldBe` bytes context "until expiration" $ it "returns the same key" $ do sk <- mkServerKey 16 Nothing k0 <- getServerKey sk k1 <- getServerKey sk k0 `shouldBe` k1 context "when a key expires" $ it "is reset" $ do sk <- mkServerKey 16 (Just $ fromIntegral (1 :: Integer)) k1 <- getServerKey sk threadDelay 2000000 k2 <- getServerKey sk k1 `shouldNotBe` k2 cookieSpec :: Spec cookieSpec = do context "when used with different encryption/decryption algorithms" $ do it "works in CBC mode" $ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) cbcEncrypt cbcDecrypt 64 it "works in CFB mode" $ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) cfbEncrypt cfbDecrypt 64 it "works in CTR combine mode" $ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100 context "when used with different ciphers" $ do it "works with AES256" $ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100 it "works with AES192" $ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES192) ctrCombine ctrCombine 100 it "works with AES128" $ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES128) ctrCombine ctrCombine 100 context "when used with different hash algorithms" $ do it "works with SHA512" $ testCipher (Proxy :: Proxy SHA512) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100 it "works with SHA384" $ testCipher (Proxy :: Proxy SHA384) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100 it "works with SHA256" $ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100 context "when cookie is corrupted" $ it "throws" $ let selectIncorrectMAC (IncorrectMAC _) = True selectIncorrectMAC _ = False in testCustomCookie (mkCookie 10 100) (BS.drop 1) selectIncorrectMAC context "when cookie has expired" $ it "throws CookieExpired" $ let selectCookieExpired (CookieExpired _ _) = True selectCookieExpired _ = False in testCustomCookie (mkCookie 0 100) id selectCookieExpired testCipher :: (HashAlgorithm h, BlockCipher c) => Proxy h -- ^ Hash algorithm -> Proxy c -- ^ Cipher -> CipherAlgorithm c -- ^ Encryption algorithm -> CipherAlgorithm c -- ^ Decryption algorithm -> Int -- ^ Payload size -> Expectation testCipher h c encryptAlgorithm decryptAlgorithm size = do cookie <- mkCookie 10 size result <- cipherId h c encryptAlgorithm decryptAlgorithm cookie id cookieIV result `shouldBe` cookieIV cookie diffUTCTime (cookieExpirationTime cookie) (cookieExpirationTime result) `shouldSatisfy` (< fromIntegral (1 :: Integer)) cookiePayload result `shouldBe` cookiePayload cookie testCustomCookie :: IO Cookie -> (ByteString -> ByteString) -> Selector AuthCookieException -> Expectation testCustomCookie mkCookie' encryptionHook selector = do cookie <- mkCookie' cipherId (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine cookie encryptionHook `shouldThrow` selector mkCookie :: Int -> Int -> IO Cookie mkCookie dt size = do rs <- mkRandomSource drgNew 1000 iv <- getRandomBytes rs 16 expiration <- addUTCTime (fromIntegral dt) <$> getCurrentTime payload <- getRandomBytes rs size return Cookie { cookieIV = iv , cookieExpirationTime = expiration , cookiePayload = payload } cipherId :: (HashAlgorithm h, BlockCipher c) => Proxy h -- ^ Hash algorithm -> Proxy c -- ^ Cipher -> CipherAlgorithm c -- ^ Encryption algorithm -> CipherAlgorithm c -- ^ Decryption algorithm -> Cookie -- ^ 'Cookie' to encrypt -> (BS.ByteString -> BS.ByteString) -- ^ Encryption hook -> IO Cookie -- ^ Restored 'Cookie' cipherId h c encryptAlgorithm decryptAlgorithm cookie encryptionHook = do sk <- mkServerKey 16 Nothing let sts = case def of AuthCookieSettings {..} -> AuthCookieSettings { acsEncryptAlgorithm = encryptAlgorithm , acsDecryptAlgorithm = decryptAlgorithm , acsHashAlgorithm = h , acsCipher = c , .. } encryptCookie sts sk cookie >>= decryptCookie sts sk . fmap encryptionHook sessionSpec :: Spec sessionSpec = do let treesOfInt = Proxy :: Proxy Int treesOfString = Proxy :: Proxy String context "when session is encrypted and decrypted" $ do it "is not distorted in any way (1)" $ property $ \session -> encryptThenDecrypt treesOfInt def session `shouldReturn` session it "is not distored in any way (2)" $ property $ \session -> encryptThenDecrypt treesOfString def session `shouldReturn` session context "when session is encrypted and decrypted (CBC mode)" $ do let sts = case def of AuthCookieSettings{..} -> AuthCookieSettings { acsEncryptAlgorithm = cbcEncrypt , acsDecryptAlgorithm = cbcDecrypt , .. } it "is not distorted in any way (1)" $ property $ \session -> encryptThenDecrypt treesOfInt sts session `shouldReturn` session it "is not distored in any way (2)" $ property $ \session -> encryptThenDecrypt treesOfString sts session `shouldReturn` session context "when session is encrypted and decrypted (CFB mode)" $ do let sts = case def of AuthCookieSettings {..} -> AuthCookieSettings { acsEncryptAlgorithm = cfbEncrypt , acsDecryptAlgorithm = cfbDecrypt , .. } it "is not distorted in any way (1)" $ property $ \session -> encryptThenDecrypt treesOfInt sts session `shouldReturn` session it "is not distored in any way (2)" $ property $ \session -> encryptThenDecrypt treesOfString sts session `shouldReturn` session encryptThenDecrypt :: Serialize a => Proxy a -> AuthCookieSettings -> Tree a -> IO (Tree a) encryptThenDecrypt _ settings x = do rs <- mkRandomSource drgNew 1000 sk <- mkServerKey 16 Nothing encryptSession settings rs sk x >>= decryptSession settings sk data Tree a = Leaf a | Node a [Tree a] deriving (Eq, Show, Generic) instance Serialize a => Serialize (Tree a) instance Arbitrary a => Arbitrary (Tree a) where arbitrary = sized arbitraryTree arbitraryTree :: Arbitrary a => Int -> Gen (Tree a) arbitraryTree 0 = Leaf <$> arbitrary arbitraryTree n = do l <- choose (0, n `quot` 2) oneof [ Leaf <$> arbitrary , Node <$> arbitrary <*> vectorOf l (arbitraryTree (n `quot` 2))]