crypto-token 0.2.0 → 0.2.1
raw patch · 4 files changed
+168/−80 lines, 4 filesdep ~arraydep ~basedep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: array, base, bytestring, network-byte-order, ram
API changes (from Hackage documentation)
Files
- ChangeLog.md +20/−0
- Crypto/Token.hs +90/−59
- crypto-token.cabal +11/−11
- test/TokenSpec.hs +47/−10
+ ChangeLog.md view
@@ -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.
Crypto/Token.hs view
@@ -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 ----------------------------------------------------------------
crypto-token.cabal view
@@ -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 <kazu@iij.ad.jp>@@ -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
test/TokenSpec.hs view
@@ -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"