diff --git a/Crypto/Token.hs b/Crypto/Token.hs --- a/Crypto/Token.hs +++ b/Crypto/Token.hs @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/crypto-token.cabal b/crypto-token.cabal --- a/crypto-token.cabal +++ b/crypto-token.cabal @@ -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 -maintainer: Kazu Yamamoto -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 +author: Kazu Yamamoto +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TokenSpec.hs b/test/TokenSpec.hs new file mode 100644 --- /dev/null +++ b/test/TokenSpec.hs @@ -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