crypto-token 0.0.2 → 0.1.0

raw patch · 5 files changed

+227/−148 lines, 5 filesdep +bytestringdep +crypto-tokendep +hspecsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, crypto-token, hspec, network-byte-order

API changes (from Hackage documentation)

Files

• Crypto/Token.hs +153/−125
• Setup.hs +1/−0
• crypto-token.cabal +44/−23
• test/Spec.hs +1/−0
• test/TokenSpec.hs +28/−0

@@ -3,89 +3,102 @@ {-# LANGUAGE ScopedTypeVariables #-}  -- | Encrypted tokens/tickets to keep state in the client side.---   For security reasons, 'Storable' data types MUST be fixed-size---   when stored (i.e. serialized into the memory). module Crypto.Token (-  -- * Configuration-    Config(..)-  , defaultConfig-  -- * Token manager-  , TokenManager-  , spawnTokenManager-  , killTokenManager-  -- * Encryption and decryption-  , encryptToken-  , decryptToken-  ) where+    -- * Configuration+    Config,+    interval,+    tokenLifetime,+    defaultConfig, +    -- * Token manager+    TokenManager,+    spawnTokenManager,+    killTokenManager,++    -- * Encryption and decryption+    encryptToken,+    decryptToken,+) where+ import Control.Concurrent import Crypto.Cipher.AES (AES256)-import Crypto.Cipher.Types (AuthTag(..), AEADMode(..))+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 Data.ByteArray (ByteArray, Bytes) 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.Int (Int64)-import Data.Word (Word16, Word64)+import Data.Word import Foreign.Ptr import Foreign.Storable+import Network.ByteOrder  ---------------------------------------------------------------- +type Index = Word16+type Counter = Word64+ -- | Configuration for token manager.-data Config = Config {-  -- | The interval to generate a new secret and remove the oldest one in minutes.-    interval   :: Int-  -- | Maximum size of secret entries. Minimum is 256 and maximum is 32767.-  , maxEntries :: Int-  }+data Config = Config+    { 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.+    }+    deriving (Eq, Show) --- | Default configuration to update secrets in 30 minutes and keep them for 10 days.+-- | Default configuration to update secrets in 30 minutes (1,800 seconds) and token liefetime is 1 day (86,400 seconds)+--+-- >>> defaultConfig+-- Config {interval = 1800, maxEntries = 86400} defaultConfig :: Config-defaultConfig = Config {-    interval = 30-  , maxEntries = 480-  }+defaultConfig =+    Config+        { interval = 1800+        , tokenLifetime = 86400+        }  ----------------------------------------------------------------  -- fixme: mask+ -- | The abstract data type for token manager.-data TokenManager = TokenManager {-    secrets :: IOArray Int Secret-  , currentIndex :: I.IORef Int-  , headerMask :: Header-  , threadId :: ThreadId-  }+data TokenManager = TokenManager+    { headerMask :: Header+    , getEncryptSecret :: IO (Secret, Index)+    , getDecryptSecret :: Index -> IO Secret+    , threadId :: ThreadId+    }  -- | Spawning a token manager. spawnTokenManager :: Config -> IO TokenManager spawnTokenManager Config{..} = do     emp <- emptySecret-    let lim = (max 256 (min maxEntries 32767)) - 1-    arr <- newArray (0, lim) emp-    update arr 0+    let lim = fromIntegral (tokenLifetime `div` interval)+    arr <- newArray (0, lim - 1) emp+    ent <- generateSecret+    writeArray arr 0 ent     ref <- I.newIORef 0     tid <- forkIO $ loop arr ref     msk <- newHeaderMask-    return $ TokenManager arr ref msk tid+    return $ TokenManager msk (readCurrentSecret arr ref) (readSecret arr) tid   where-    update :: IOArray Int Secret -> Int -> IO ()-    update arr idx = do-        ent <- generateSecret-        writeArray arr idx ent     loop arr ref = do-        threadDelay (interval * 60 * 1000000)+        threadDelay (interval * 1000000)+        update arr ref+        loop arr ref+    update :: IOArray Index Secret -> I.IORef Index -> IO ()+    update arr ref = do         idx0 <- I.readIORef ref         (_, n) <- getBounds arr         let idx = (idx0 + 1) `mod` (n + 1)-        update arr idx+        sec <- generateSecret+        writeArray arr idx sec         I.writeIORef ref idx-        loop arr ref  -- | Killing a token manager. killTokenManager :: TokenManager -> IO ()@@ -93,32 +106,40 @@  ---------------------------------------------------------------- -getSecret :: TokenManager -> Int -> IO Secret-getSecret TokenManager{..} idx0 = do+readSecret :: IOArray Index Secret -> Index -> IO Secret+readSecret secrets idx0 = do     (_, n) <- getBounds secrets     let idx = idx0 `mod` (n + 1)     readArray secrets idx +readCurrentSecret :: IOArray Index Secret -> I.IORef Index -> IO (Secret, Index)+readCurrentSecret arr ref = do+    idx <- I.readIORef ref+    sec <- readSecret arr idx+    return (sec, idx)+ ---------------------------------------------------------------- -data Secret = Secret {-    secretIV      :: Bytes-  , secretKey     :: Bytes-  , secretCounter :: I.IORef Int64-  }+data Secret = Secret+    { secretIV :: ByteString+    , secretKey :: ByteString+    , secretCounter :: I.IORef Counter+    }  emptySecret :: IO Secret-emptySecret = Secret BA.empty BA.empty <$> I.newIORef 0+emptySecret = Secret BS.empty BS.empty <$> I.newIORef 0  generateSecret :: IO Secret-generateSecret = Secret <$> genIV-                        <*> genKey-                        <*> I.newIORef 0+generateSecret =+    Secret+        <$> genIV+        <*> genKey+        <*> I.newIORef 0 -genKey :: IO Bytes+genKey :: IO ByteString genKey = getRandomBytes keyLength -genIV :: IO Bytes+genIV :: IO ByteString genIV = getRandomBytes ivLength  ----------------------------------------------------------------@@ -140,119 +161,126 @@  ---------------------------------------------------------------- -data Header = Header {-    headerIndex   :: Word16-  , headerCounter :: Word64-  }+data Header = Header+    { headerIndex :: Index+    , headerCounter :: Counter+    } -instance Storable Header where-    sizeOf _    = indexLength + counterLength-    alignment _ = indexLength -- fixme-    peek p = do-        i <- peek $ castPtr p-        c <- peek (castPtr p `plusPtr` indexLength)-        return $ Header i c-    poke p (Header i c) = do-        poke (castPtr p) i-        poke (castPtr p `plusPtr` indexLength) c+encodeHeader :: Header -> IO ByteString+encodeHeader Header{..} = withWriteBuffer (indexLength + counterLength) $ \wbuf -> do+    write16 wbuf headerIndex+    write64 wbuf headerCounter +decodeHeader :: ByteString -> IO Header+decodeHeader bs = withReadBuffer bs $ \rbuf ->+    Header <$> read16 rbuf <*> read64 rbuf+ newHeaderMask :: IO Header newHeaderMask = do-    bin <- getRandomBytes (indexLength + counterLength) :: IO Bytes-    BA.withByteArray bin peek+    bin <- getRandomBytes (indexLength + counterLength) :: IO ByteString+    decodeHeader bin  ----------------------------------------------------------------  xorHeader :: Header -> Header -> Header-xorHeader x y = Header {-    headerIndex = headerIndex x `xor` headerIndex y-  , headerCounter = headerCounter x `xor` headerCounter y-  }+xorHeader x y =+    Header+        { headerIndex = headerIndex x `xor` headerIndex y+        , headerCounter = headerCounter x `xor` headerCounter y+        } -addHeader :: ByteArray ba => TokenManager -> Int -> Int64 -> ba -> IO ba+addHeader :: TokenManager -> Index -> Counter -> ByteString -> IO ByteString addHeader TokenManager{..} idx counter cipher = do-    let hdr = Header (fromIntegral idx) (fromIntegral counter)+    let hdr = Header idx counter         mskhdr = headerMask `xorHeader` hdr-    hdrbin <- BA.create (sizeOf mskhdr) $ \ptr -> poke ptr mskhdr-    return (hdrbin `BA.append` cipher)+    hdrbin <- encodeHeader mskhdr+    return (hdrbin `BS.append` cipher) -delHeader :: ByteArray ba => TokenManager -> ba -> IO (Maybe (Int, Int64, ba))+delHeader+    :: TokenManager -> ByteString -> IO (Maybe (Index, Counter, ByteString)) delHeader TokenManager{..} token-  | BA.length token < minlen = return Nothing-  | otherwise = do-        let (hdrbin, cipher) = BA.splitAt minlen token-        mskhdr <- BA.withByteArray hdrbin peek+    | BS.length token < minlen = return Nothing+    | otherwise = do+        let (hdrbin, cipher) = BS.splitAt minlen token+        mskhdr <- decodeHeader hdrbin         let hdr = headerMask `xorHeader` mskhdr-            idx = fromIntegral $ headerIndex hdr-            counter = fromIntegral $ headerCounter hdr+            idx = headerIndex hdr+            counter = headerCounter hdr         return $ Just (idx, counter, cipher)   where     minlen = indexLength + counterLength  -- | Encrypting a target value to get a token.-encryptToken :: (Storable a, ByteArray ba)-             => TokenManager -> a -> IO ba+encryptToken+    :: TokenManager+    -> ByteString+    -> IO ByteString encryptToken mgr x = do-    idx <- I.readIORef $ currentIndex mgr-    secret <- getSecret mgr idx+    (secret, idx) <- getEncryptSecret mgr     (counter, cipher) <- encrypt secret x     addHeader mgr idx counter cipher -encrypt :: (Storable a, ByteArray ba)-        => Secret -> a -> IO (Int64, ba)-encrypt secret x = do-    counter <- I.atomicModifyIORef' (secretCounter secret) (\i -> (i+1, i))-    plain <- BA.create (sizeOf x) $ \ptr -> poke ptr x+encrypt+    :: Secret+    -> ByteString+    -> 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     return (counter, cipher)  -- | Decrypting a token to get a target value.-decryptToken :: (Storable a, ByteArray ba)-             => TokenManager -> ba -> IO (Maybe a)+decryptToken+    :: TokenManager+    -> ByteString+    -> IO (Maybe ByteString) decryptToken mgr token = do     mx <- delHeader mgr token     case mx of-      Nothing -> return Nothing-      Just (idx, counter, cipher) -> do-          secret <- getSecret mgr idx-          decrypt secret counter cipher+        Nothing -> return Nothing+        Just (idx, counter, cipher) -> do+            secret <- getDecryptSecret mgr idx+            decrypt secret counter cipher -decrypt :: forall a ba . (Storable a, ByteArray ba)-        => Secret -> Int64 -> ba -> IO (Maybe a)+decrypt+    :: Secret+    -> Counter+    -> ByteString+    -> IO (Maybe ByteString) decrypt secret counter cipher = do     nonce <- makeNonce counter $ secretIV secret-    let mplain = aes256gcmDecrypt cipher (secretKey secret) nonce-        expect = sizeOf (undefined :: a)-    case mplain of-      Just plain-        | BA.length plain == expect -> Just <$> BA.withByteArray plain peek-      _                             -> return Nothing-+    return $ aes256gcmDecrypt cipher (secretKey secret) nonce -makeNonce :: forall ba . ByteArray ba => Int64 -> ba -> IO ba+makeNonce :: Counter -> ByteString -> IO ByteString makeNonce counter iv = do-    cv <- BA.create ivLength $ \ptr -> poke ptr counter-    return $ iv `BA.xor` (cv :: ba)+    cv <- BS.create ivLength $ \ptr -> poke (castPtr ptr) counter+    return $ iv `BA.xor` cv  ---------------------------------------------------------------- -constantAdditionalData :: Bytes-constantAdditionalData = BA.empty+constantAdditionalData :: ByteString+constantAdditionalData = BS.empty -aes256gcmEncrypt :: ByteArray ba-                 => ba -> Bytes -> Bytes -> ba-aes256gcmEncrypt plain key nonce = cipher `BA.append` BA.convert tag+aes256gcmEncrypt+    :: ByteString+    -> ByteString+    -> ByteString+    -> ByteString+aes256gcmEncrypt plain key nonce = cipher `BS.append` (BA.convert tag)   where     conn = throwCryptoError (C.cipherInit key) :: AES256     aeadIni = throwCryptoError $ C.aeadInit AEAD_GCM conn nonce     (AuthTag tag, cipher) = C.aeadSimpleEncrypt aeadIni constantAdditionalData plain tagLength -aes256gcmDecrypt :: ByteArray ba-                 => ba -> Bytes -> Bytes -> Maybe ba+aes256gcmDecrypt+    :: ByteString+    -> ByteString+    -> ByteString+    -> Maybe ByteString aes256gcmDecrypt ctexttag key nonce = do-    aes  <- maybeCryptoError $ C.cipherInit key :: Maybe AES256+    aes <- maybeCryptoError $ C.cipherInit key :: Maybe AES256     aead <- maybeCryptoError $ C.aeadInit AEAD_GCM aes nonce-    let (ctext, tag) = BA.splitAt (BA.length ctexttag - tagLength) ctexttag+    let (ctext, tag) = BS.splitAt (BS.length ctexttag - tagLength) ctexttag         authtag = AuthTag $ BA.convert tag     C.aeadSimpleDecrypt aead constantAdditionalData ctext authtag

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

@@ -1,26 +1,47 @@-name:                crypto-token-version:             0.0.2-synopsis:            crypto tokens-description:         Encrypted tokens/tickets to keep state in the client side.-license:             BSD3-license-file:        LICENSE-author:              Kazu Yamamoto <kazu@iij.ad.jp>-maintainer:          Kazu Yamamoto <kazu@iij.ad.jp>-category:            Cryptography, Network-cabal-version:       >= 1.10-build-type:          Simple+cabal-version: >=1.10+name:          crypto-token+version:       0.1.0+license:       BSD3+license-file:  LICENSE+maintainer:    Kazu Yamamoto <kazu@iij.ad.jp>+author:        Kazu Yamamoto <kazu@iij.ad.jp>+synopsis:      crypto tokens+description:   Encrypted tokens/tickets to keep state in the client side.+category:      Cryptography, Network+build-type:    Simple +source-repository head+    type:     git+    location: git://github.com/kazu-yamamoto/crypto-token+ library-  default-language:    Haskell2010-  ghc-options:         -Wall-  exposed-modules:     Crypto.Token-  build-depends:       base >= 4.9 && < 5-                     , array-                     , crypton-                     , memory-  if impl(ghc >= 8)-    default-extensions:  Strict StrictData+    exposed-modules:  Crypto.Token+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4.9 && <5,+        array,+        bytestring,+        crypton,+        memory,+        network-byte-order -source-repository head-  type:                 git-  location:             git://github.com/kazu-yamamoto/crypto-token+    if impl(ghc >=8)+        default-extensions: Strict StrictData++test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    build-tool-depends: hspec-discover:hspec-discover+    hs-source-dirs:     test+    other-modules:+        TokenSpec++    default-language:   Haskell2010+    default-extensions: Strict StrictData+    ghc-options:        -Wall -threaded -rtsopts+    build-depends:+        base >=4.9 && <5,+        bytestring,+        crypto-token,+        hspec

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module TokenSpec where++import Control.Concurrent+import Crypto.Token+import Test.Hspec++----------------------------------------------------------------++spec :: Spec+spec = do+    describe "crypto token" $ do+        it "encrypt & decrypt ByteString" $ do+            mgr <- spawnTokenManager $ defaultConfig{interval = 1, tokenLifetime = 3}+            tf <- encryptToken mgr "Foo"+            threadDelay 1100000+            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+            decryptToken mgr tf `shouldReturn` Nothing+            decryptToken mgr tb `shouldReturn` Just "Bar"+            threadDelay 1100000+            decryptToken mgr tf `shouldReturn` Nothing+            decryptToken mgr tb `shouldReturn` Nothing