diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,20 @@ +# ChangeLog for crypto-token + +## 0.2.1 + +* `tokenLifetime` is exact. A token carries its issue time and is refused + once older than `tokenLifetime`; before, it could expire up to one + `interval` early. +* A `tokenLifetime` shorter than `interval`, or spanning 65536 intervals or + more, no longer makes every token operation divide by zero. + `spawnTokenManager` throws an `IOError` for a non-positive `interval`. +* The AES-GCM nonce is 96 bits, the length GCM is designed for, rather + than 64. +* The token header is encrypted rather than masked, so tokens no longer + reveal how their counters relate. +* The rotation thread survives a failed rotation, and its wait no longer + overflows a 32-bit `Int`. +* Tokens are 14 bytes longer: an 8-byte issue time and a 16-byte header + instead of 10. Tokens never outlive the process that made them, so no + token from an earlier version is affected. +* The lower bound on base moves to 4.11, where `GHC.Clock` is. diff --git a/Crypto/Token.hs b/Crypto/Token.hs --- a/Crypto/Token.hs +++ b/Crypto/Token.hs @@ -22,20 +22,19 @@ ) where import Control.Concurrent +import qualified Control.Exception as E +import Control.Monad (when) import Crypto.Cipher.AES (AES256) import Crypto.Cipher.Types (AEADMode (..), AuthTag (..)) import qualified Crypto.Cipher.Types as C import Crypto.Error (maybeCryptoError, throwCryptoError) import Crypto.Random (getRandomBytes) import Data.Array.IO -import Data.Bits (xor) import qualified Data.ByteArray as BA import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS import qualified Data.IORef as I import Data.Word -import Foreign.Ptr -import Foreign.Storable +import GHC.Clock (getMonotonicTimeNSec) import GHC.Conc.Sync (labelThread) import Network.ByteOrder @@ -49,7 +48,8 @@ { interval :: Int -- ^ The interval to generate a new secret and remove the oldest one in seconds. , tokenLifetime :: Int - -- ^ The token lifetime, that is, tokens can be decrypted in this period. + -- ^ The token lifetime in seconds, that is, tokens can be decrypted in this period. + -- It is cut short if it spans more than 65535 intervals. , threadName :: String } deriving (Eq, Show) @@ -57,7 +57,7 @@ -- | Default configuration to update secrets in 30 minutes (1,800 seconds) and token lifetime is 2 hours (7,200 seconds) -- -- >>> defaultConfig --- Config {interval = 1800, tokenLifetime = 7200} +-- Config {interval = 1800, tokenLifetime = 7200, threadName = "Crypto token manager"} defaultConfig :: Config defaultConfig = Config @@ -68,60 +68,81 @@ ---------------------------------------------------------------- --- fixme: mask - -- | The abstract data type for token manager. data TokenManager = TokenManager - { headerMask :: Header + { headerKey :: AES256 , getEncryptSecret :: IO (Secret, Index) , getDecryptSecret :: Index -> IO Secret , threadId :: ThreadId + , lifetimeNSec :: Word64 } -- | Spawning a token manager. +-- This throws an 'IOError' if 'interval' is not positive. spawnTokenManager :: Config -> IO TokenManager spawnTokenManager Config{..} = do + when (interval <= 0) $ + E.throwIO $ + userError "Crypto.Token: interval must be positive" + -- the secret a token was made with must outlive the token itself, + -- and an index travels as Word16, so there are at most 65536 slots + let lifetime = max 0 tokenLifetime + slots = min 65536 $ (lifetime + interval - 1) `div` interval + 1 emp <- emptySecret - let lim = fromIntegral (tokenLifetime `div` interval) - arr <- newArray (0, lim - 1) emp + arr <- newArray (0, slots - 1) emp ent <- generateSecret writeArray arr 0 ent ref <- I.newIORef 0 tid <- forkIO $ loop arr ref labelThread tid threadName - msk <- newHeaderMask - return $ TokenManager msk (readCurrentSecret arr ref) (readSecret arr) tid + hkey <- newHeaderKey + return $ + TokenManager hkey (readCurrentSecret arr ref) (readSecret arr) tid $ + fromIntegral lifetime * 1000000000 where loop arr ref = do - threadDelay (interval * 1000000) - update arr ref + delaySeconds interval + -- a failed rotation is retried at the next interval + update arr ref `E.catch` ignoreSync loop arr ref - update :: IOArray Index Secret -> I.IORef Index -> IO () + ignoreSync :: E.SomeException -> IO () + ignoreSync e = case E.fromException e of + Just (E.SomeAsyncException _) -> E.throwIO e + Nothing -> return () + update :: IOArray Int Secret -> I.IORef Int -> IO () update arr ref = do idx0 <- I.readIORef ref - (_, n) <- getBounds arr - let idx = (idx0 + 1) `mod` (n + 1) + n <- rangeSize <$> getBounds arr + let idx = (idx0 + 1) `mod` n sec <- generateSecret writeArray arr idx sec I.writeIORef ref idx +-- threadDelay's microseconds overflow a 32-bit Int after 35 minutes. +delaySeconds :: Int -> IO () +delaySeconds n + | n <= 0 = return () + | otherwise = do + let m = min n 1000 + threadDelay (m * 1000000) + delaySeconds (n - m) + -- | Killing a token manager. killTokenManager :: TokenManager -> IO () killTokenManager TokenManager{..} = killThread threadId ---------------------------------------------------------------- -readSecret :: IOArray Index Secret -> Index -> IO Secret +readSecret :: IOArray Int Secret -> Index -> IO Secret readSecret secrets idx0 = do - (_, n) <- getBounds secrets - let idx = idx0 `mod` (n + 1) - readArray secrets idx + n <- rangeSize <$> getBounds secrets + readArray secrets $ fromIntegral idx0 `mod` n -readCurrentSecret :: IOArray Index Secret -> I.IORef Index -> IO (Secret, Index) +readCurrentSecret :: IOArray Int Secret -> I.IORef Int -> IO (Secret, Index) readCurrentSecret arr ref = do idx <- I.readIORef ref - sec <- readSecret arr idx - return (sec, idx) + sec <- readArray arr idx + return (sec, fromIntegral idx) ---------------------------------------------------------------- @@ -149,8 +170,9 @@ ---------------------------------------------------------------- +-- 96 bits, the nonce length GCM is designed for ivLength :: Int -ivLength = 8 +ivLength = 12 keyLength :: Int keyLength = 32 @@ -164,6 +186,10 @@ tagLength :: Int tagLength = 16 +-- one AES block: index, counter and zero padding +headerLength :: Int +headerLength = 16 + ---------------------------------------------------------------- data Header = Header @@ -180,40 +206,34 @@ decodeHeader bs = withReadBuffer bs $ \rbuf -> Header <$> read16 rbuf <*> read64 rbuf -newHeaderMask :: IO Header -newHeaderMask = do - bin <- getRandomBytes (indexLength + counterLength) :: IO ByteString - decodeHeader bin +newHeaderKey :: IO AES256 +newHeaderKey = do + key <- getRandomBytes keyLength :: IO ByteString + return $ throwCryptoError $ C.cipherInit key ---------------------------------------------------------------- -xorHeader :: Header -> Header -> Header -xorHeader x y = - Header - { headerIndex = headerIndex x `xor` headerIndex y - , headerCounter = headerCounter x `xor` headerCounter y - } - +-- The header is encrypted so that tokens do not reveal how they relate. addHeader :: TokenManager -> Index -> Counter -> ByteString -> IO ByteString addHeader TokenManager{..} idx counter cipher = do - let hdr = Header idx counter - mskhdr = headerMask `xorHeader` hdr - hdrbin <- encodeHeader mskhdr - return (hdrbin `BS.append` cipher) + hdrbin <- encodeHeader $ Header idx counter + let padding = BS.replicate (headerLength - BS.length hdrbin) 0 + blk = C.ecbEncrypt headerKey (hdrbin `BS.append` padding) + return (blk `BS.append` cipher) delHeader :: TokenManager -> ByteString -> IO (Maybe (Index, Counter, ByteString)) delHeader TokenManager{..} token - | BS.length token < minlen = return Nothing + | BS.length token < headerLength = return Nothing | otherwise = do - let (hdrbin, cipher) = BS.splitAt minlen token - mskhdr <- decodeHeader hdrbin - let hdr = headerMask `xorHeader` mskhdr - idx = headerIndex hdr - counter = headerCounter hdr - return $ Just (idx, counter, cipher) - where - minlen = indexLength + counterLength + let (blk, cipher) = BS.splitAt headerLength token + (hdrbin, padding) = + BS.splitAt (indexLength + counterLength) $ C.ecbDecrypt headerKey blk + if BS.any (/= 0) padding + then return Nothing + else do + Header{..} <- decodeHeader hdrbin + return $ Just (headerIndex, headerCounter, cipher) -- | Encrypting a target value to get a token. encryptToken @@ -222,7 +242,8 @@ -> IO ByteString encryptToken mgr x = do (secret, idx) <- getEncryptSecret mgr - (counter, cipher) <- encrypt secret x + now <- getMonotonicTimeNSec + (counter, cipher) <- encrypt secret (bytestring64 now `BS.append` x) addHeader mgr idx counter cipher encrypt @@ -231,8 +252,8 @@ -> IO (Counter, ByteString) encrypt secret plain = do counter <- I.atomicModifyIORef' (secretCounter secret) (\i -> (i + 1, i)) - nonce <- makeNonce counter $ secretIV secret - let cipher = aes256gcmEncrypt plain (secretKey secret) nonce + let nonce = makeNonce counter $ secretIV secret + cipher = aes256gcmEncrypt plain (secretKey secret) nonce return (counter, cipher) -- | Decrypting a token to get a target value. @@ -246,7 +267,17 @@ Nothing -> return Nothing Just (idx, counter, cipher) -> do secret <- getDecryptSecret mgr idx - decrypt secret counter cipher + mplain <- decrypt secret counter cipher + now <- getMonotonicTimeNSec + return $ mplain >>= checkLifetime now + where + checkLifetime now plain + | BS.length plain < 8 = Nothing + | issued <= now && now - issued <= lifetimeNSec mgr = Just x + | otherwise = Nothing + where + (hdr, x) = BS.splitAt 8 plain + issued = word64 hdr decrypt :: Secret @@ -254,13 +285,13 @@ -> ByteString -> IO (Maybe ByteString) decrypt secret counter cipher = do - nonce <- makeNonce counter $ secretIV secret + let nonce = makeNonce counter $ secretIV secret return $ aes256gcmDecrypt cipher (secretKey secret) nonce -makeNonce :: Counter -> ByteString -> IO ByteString -makeNonce counter iv = do - cv <- BS.create ivLength $ \ptr -> poke (castPtr ptr) counter - return $ iv `BA.xor` cv +makeNonce :: Counter -> ByteString -> ByteString +makeNonce counter iv = iv `BA.xor` cv + where + cv = BS.replicate (ivLength - counterLength) 0 `BS.append` bytestring64 counter ---------------------------------------------------------------- diff --git a/crypto-token.cabal b/crypto-token.cabal --- a/crypto-token.cabal +++ b/crypto-token.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: crypto-token -version: 0.2.0 +version: 0.2.1 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -9,6 +9,7 @@ description: Encrypted tokens/tickets to keep state in the client side. category: Cryptography, Network build-type: Simple +extra-source-files: ChangeLog.md source-repository head type: git @@ -19,15 +20,14 @@ default-language: Haskell2010 ghc-options: -Wall build-depends: - base >=4.9 && <5, - array, - bytestring, - crypton >=1.1.0 && <1.2, - network-byte-order, - ram + base >=4.11 && <5, + array >=0.5 && <0.6, + bytestring >=0.10 && <0.13, + crypton >=1.1.0 && <2.3, + network-byte-order >=0.1.6 && <0.2, + ram >=0.19 && <0.23 - if impl(ghc >=8) - default-extensions: Strict StrictData + default-extensions: Strict StrictData test-suite spec type: exitcode-stdio-1.0 @@ -41,7 +41,7 @@ default-extensions: Strict StrictData ghc-options: -Wall -threaded -rtsopts build-depends: - base >=4.9 && <5, - bytestring, + base >=4.11 && <5, + bytestring >=0.10 && <0.13, crypto-token, hspec diff --git a/test/TokenSpec.hs b/test/TokenSpec.hs --- a/test/TokenSpec.hs +++ b/test/TokenSpec.hs @@ -1,9 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module TokenSpec where import Control.Concurrent +import qualified Control.Exception as E import Crypto.Token +import Data.Bits (xor) +import qualified Data.ByteString as BS import Test.Hspec ---------------------------------------------------------------- @@ -11,18 +15,51 @@ spec :: Spec spec = do describe "crypto token" $ do - it "encrypt & decrypt ByteString" $ do - mgr <- spawnTokenManager $ defaultConfig{interval = 1, tokenLifetime = 3} + it "encrypt & decrypt ByteString" $ + roundTrip defaultConfig + it "lives as long as its lifetime, across rotations" $ do + mgr <- spawnTokenManager $ defaultConfig{interval = 1, tokenLifetime = 2} + threadDelay 900000 + -- made just before a rotation tf <- encryptToken mgr "Foo" - threadDelay 1100000 + threadDelay 1200000 decryptToken mgr tf `shouldReturn` Just "Foo" tb <- encryptToken mgr "Bar" - threadDelay 1100000 - decryptToken mgr tf `shouldReturn` Just "Foo" - decryptToken mgr tb `shouldReturn` Just "Bar" - threadDelay 1100000 + threadDelay 1300000 decryptToken mgr tf `shouldReturn` Nothing decryptToken mgr tb `shouldReturn` Just "Bar" - threadDelay 1100000 - decryptToken mgr tf `shouldReturn` Nothing - decryptToken mgr tb `shouldReturn` Nothing + killTokenManager mgr + + it "refuses a tampered token" $ do + mgr <- spawnTokenManager defaultConfig + t <- encryptToken mgr "Foo" + let flip1 i = BS.take i t <> BS.singleton (BS.index t i `xor` 1) <> BS.drop (i + 1) t + -- in the header, the payload and the tag + mapM_ + (\i -> decryptToken mgr (flip1 i) `shouldReturn` Nothing) + [0, 20, BS.length t - 1] + decryptToken mgr (BS.take 15 t) `shouldReturn` Nothing + killTokenManager mgr + it "gives unrelated headers to consecutive tokens" $ do + mgr <- spawnTokenManager defaultConfig + t1 <- encryptToken mgr "Foo" + t2 <- encryptToken mgr "Foo" + -- with a fixed mask only the counter's low byte would differ + length (filter id $ BS.zipWith (/=) (BS.take 16 t1) (BS.take 16 t2)) + `shouldSatisfy` (> 4) + killTokenManager mgr + + describe "configuration" $ do + it "survives a lifetime shorter than the interval" $ + roundTrip defaultConfig{interval = 10, tokenLifetime = 1} + it "survives more intervals than an index can name" $ + roundTrip defaultConfig{interval = 1, tokenLifetime = 100000} + it "refuses a non-positive interval" $ + spawnTokenManager defaultConfig{interval = 0} + `shouldThrow` (\(_ :: E.IOException) -> True) + +roundTrip :: Config -> IO () +roundTrip conf = + E.bracket (spawnTokenManager conf) killTokenManager $ \mgr -> do + t <- encryptToken mgr "Foo" + decryptToken mgr t `shouldReturn` Just "Foo"