{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Encrypted tokens/tickets to keep state in the client side.
module Crypto.Token (
    -- * Configuration
    Config,
    defaultConfig,
    interval,
    tokenLifetime,
    threadName,

    -- * Token manager
    TokenManager,
    spawnTokenManager,
    killTokenManager,

    -- * Encryption and decryption
    encryptToken,
    decryptToken,
) 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 qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.IORef as I
import Data.Word
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Conc.Sync (labelThread)
import Network.ByteOrder

----------------------------------------------------------------

type Index = Word16
type Counter = Word64

-- | Configuration for token manager.
data Config = Config
    { Config -> BufferSize
interval :: Int
    -- ^ The interval to generate a new secret and remove the oldest one in seconds.
    , Config -> BufferSize
tokenLifetime :: Int
    -- ^ 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.
    , Config -> String
threadName :: String
    }
    deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq, BufferSize -> Config -> ShowS
[Config] -> ShowS
Config -> String
(BufferSize -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(BufferSize -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: BufferSize -> Config -> ShowS
showsPrec :: BufferSize -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)

-- | 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, threadName = "Crypto token manager"}
defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
    Config
        { interval :: BufferSize
interval = BufferSize
1800
        , tokenLifetime :: BufferSize
tokenLifetime = BufferSize
7200
        , threadName :: String
threadName = String
"Crypto token manager"
        }

----------------------------------------------------------------

-- | The abstract data type for token manager.
data TokenManager = TokenManager
    { TokenManager -> AES256
headerKey :: AES256
    , TokenManager -> IO (Secret, Index)
getEncryptSecret :: IO (Secret, Index)
    , TokenManager -> Index -> IO Secret
getDecryptSecret :: Index -> IO Secret
    , TokenManager -> ThreadId
threadId :: ThreadId
    , TokenManager -> Counter
lifetimeNSec :: Word64
    }

-- | Spawning a token manager.
--   This throws an 'IOError' if 'interval' is not positive.
spawnTokenManager :: Config -> IO TokenManager
spawnTokenManager :: Config -> IO TokenManager
spawnTokenManager Config{BufferSize
String
interval :: Config -> BufferSize
tokenLifetime :: Config -> BufferSize
threadName :: Config -> String
interval :: BufferSize
tokenLifetime :: BufferSize
threadName :: String
..} = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
interval BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
<= BufferSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IOError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IOError
userError String
"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 :: BufferSize
lifetime = BufferSize -> BufferSize -> BufferSize
forall a. Ord a => a -> a -> a
max BufferSize
0 BufferSize
tokenLifetime
        slots :: BufferSize
slots = BufferSize -> BufferSize -> BufferSize
forall a. Ord a => a -> a -> a
min BufferSize
65536 (BufferSize -> BufferSize) -> BufferSize -> BufferSize
forall a b. (a -> b) -> a -> b
$ (BufferSize
lifetime BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
interval BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
- BufferSize
1) BufferSize -> BufferSize -> BufferSize
forall a. Integral a => a -> a -> a
`div` BufferSize
interval BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
1
    emp <- IO Secret
emptySecret
    arr <- newArray (0, slots - 1) emp
    ent <- generateSecret
    writeArray arr 0 ent
    ref <- I.newIORef 0
    tid <- forkIO $ loop arr ref
    labelThread tid threadName
    hkey <- newHeaderKey
    return $
        TokenManager hkey (readCurrentSecret arr ref) (readSecret arr) tid $
            fromIntegral lifetime * 1000000000
  where
    loop :: IOArray BufferSize Secret -> IORef BufferSize -> IO b
loop IOArray BufferSize Secret
arr IORef BufferSize
ref = do
        BufferSize -> IO ()
delaySeconds BufferSize
interval
        -- a failed rotation is retried at the next interval
        IOArray BufferSize Secret -> IORef BufferSize -> IO ()
update IOArray BufferSize Secret
arr IORef BufferSize
ref IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
ignoreSync
        IOArray BufferSize Secret -> IORef BufferSize -> IO b
loop IOArray BufferSize Secret
arr IORef BufferSize
ref
    ignoreSync :: E.SomeException -> IO ()
    ignoreSync :: SomeException -> IO ()
ignoreSync SomeException
e = case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e of
        Just (E.SomeAsyncException e
_) -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO SomeException
e
        Maybe SomeAsyncException
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    update :: IOArray Int Secret -> I.IORef Int -> IO ()
    update :: IOArray BufferSize Secret -> IORef BufferSize -> IO ()
update IOArray BufferSize Secret
arr IORef BufferSize
ref = do
        idx0 <- IORef BufferSize -> IO BufferSize
forall a. IORef a -> IO a
I.readIORef IORef BufferSize
ref
        n <- rangeSize <$> getBounds arr
        let idx = (BufferSize
idx0 BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
1) BufferSize -> BufferSize -> BufferSize
forall a. Integral a => a -> a -> a
`mod` BufferSize
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 :: BufferSize -> IO ()
delaySeconds BufferSize
n
    | BufferSize
n BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
<= BufferSize
0 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = do
        let m :: BufferSize
m = BufferSize -> BufferSize -> BufferSize
forall a. Ord a => a -> a -> a
min BufferSize
n BufferSize
1000
        BufferSize -> IO ()
threadDelay (BufferSize
m BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
* BufferSize
1000000)
        BufferSize -> IO ()
delaySeconds (BufferSize
n BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
- BufferSize
m)

-- | Killing a token manager.
killTokenManager :: TokenManager -> IO ()
killTokenManager :: TokenManager -> IO ()
killTokenManager TokenManager{IO (Secret, Index)
Counter
AES256
ThreadId
Index -> IO Secret
headerKey :: TokenManager -> AES256
getEncryptSecret :: TokenManager -> IO (Secret, Index)
getDecryptSecret :: TokenManager -> Index -> IO Secret
threadId :: TokenManager -> ThreadId
lifetimeNSec :: TokenManager -> Counter
headerKey :: AES256
getEncryptSecret :: IO (Secret, Index)
getDecryptSecret :: Index -> IO Secret
threadId :: ThreadId
lifetimeNSec :: Counter
..} = ThreadId -> IO ()
killThread ThreadId
threadId

----------------------------------------------------------------

readSecret :: IOArray Int Secret -> Index -> IO Secret
readSecret :: IOArray BufferSize Secret -> Index -> IO Secret
readSecret IOArray BufferSize Secret
secrets Index
idx0 = do
    n <- (BufferSize, BufferSize) -> BufferSize
forall a. Ix a => (a, a) -> BufferSize
rangeSize ((BufferSize, BufferSize) -> BufferSize)
-> IO (BufferSize, BufferSize) -> IO BufferSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOArray BufferSize Secret -> IO (BufferSize, BufferSize)
forall i. Ix i => IOArray i Secret -> IO (i, i)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds IOArray BufferSize Secret
secrets
    readArray secrets $ fromIntegral idx0 `mod` n

readCurrentSecret :: IOArray Int Secret -> I.IORef Int -> IO (Secret, Index)
readCurrentSecret :: IOArray BufferSize Secret -> IORef BufferSize -> IO (Secret, Index)
readCurrentSecret IOArray BufferSize Secret
arr IORef BufferSize
ref = do
    idx <- IORef BufferSize -> IO BufferSize
forall a. IORef a -> IO a
I.readIORef IORef BufferSize
ref
    sec <- readArray arr idx
    return (sec, fromIntegral idx)

----------------------------------------------------------------

data Secret = Secret
    { Secret -> ByteString
secretIV :: ByteString
    , Secret -> ByteString
secretKey :: ByteString
    , Secret -> IORef Counter
secretCounter :: I.IORef Counter
    }

emptySecret :: IO Secret
emptySecret :: IO Secret
emptySecret = ByteString -> ByteString -> IORef Counter -> Secret
Secret ByteString
BS.empty ByteString
BS.empty (IORef Counter -> Secret) -> IO (IORef Counter) -> IO Secret
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Counter -> IO (IORef Counter)
forall a. a -> IO (IORef a)
I.newIORef Counter
0

generateSecret :: IO Secret
generateSecret :: IO Secret
generateSecret =
    ByteString -> ByteString -> IORef Counter -> Secret
Secret
        (ByteString -> ByteString -> IORef Counter -> Secret)
-> IO ByteString -> IO (ByteString -> IORef Counter -> Secret)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
genIV
        IO (ByteString -> IORef Counter -> Secret)
-> IO ByteString -> IO (IORef Counter -> Secret)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO ByteString
genKey
        IO (IORef Counter -> Secret) -> IO (IORef Counter) -> IO Secret
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Counter -> IO (IORef Counter)
forall a. a -> IO (IORef a)
I.newIORef Counter
0

genKey :: IO ByteString
genKey :: IO ByteString
genKey = BufferSize -> IO ByteString
forall byteArray. ByteArray byteArray => BufferSize -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
BufferSize -> m byteArray
getRandomBytes BufferSize
keyLength

genIV :: IO ByteString
genIV :: IO ByteString
genIV = BufferSize -> IO ByteString
forall byteArray. ByteArray byteArray => BufferSize -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
BufferSize -> m byteArray
getRandomBytes BufferSize
ivLength

----------------------------------------------------------------

-- 96 bits, the nonce length GCM is designed for
ivLength :: Int
ivLength :: BufferSize
ivLength = BufferSize
12

keyLength :: Int
keyLength :: BufferSize
keyLength = BufferSize
32

indexLength :: Int
indexLength :: BufferSize
indexLength = BufferSize
2

counterLength :: Int
counterLength :: BufferSize
counterLength = BufferSize
8

tagLength :: Int
tagLength :: BufferSize
tagLength = BufferSize
16

-- one AES block: index, counter and zero padding
headerLength :: Int
headerLength :: BufferSize
headerLength = BufferSize
16

----------------------------------------------------------------

data Header = Header
    { Header -> Index
headerIndex :: Index
    , Header -> Counter
headerCounter :: Counter
    }

encodeHeader :: Header -> IO ByteString
encodeHeader :: Header -> IO ByteString
encodeHeader Header{Index
Counter
headerIndex :: Header -> Index
headerCounter :: Header -> Counter
headerIndex :: Index
headerCounter :: Counter
..} = BufferSize -> (WriteBuffer -> IO ()) -> IO ByteString
withWriteBuffer (BufferSize
indexLength BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
counterLength) ((WriteBuffer -> IO ()) -> IO ByteString)
-> (WriteBuffer -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \WriteBuffer
wbuf -> do
    WriteBuffer -> Index -> IO ()
write16 WriteBuffer
wbuf Index
headerIndex
    WriteBuffer -> Counter -> IO ()
write64 WriteBuffer
wbuf Counter
headerCounter

decodeHeader :: ByteString -> IO Header
decodeHeader :: ByteString -> IO Header
decodeHeader ByteString
bs = ByteString -> (ReadBuffer -> IO Header) -> IO Header
forall a. ByteString -> (ReadBuffer -> IO a) -> IO a
withReadBuffer ByteString
bs ((ReadBuffer -> IO Header) -> IO Header)
-> (ReadBuffer -> IO Header) -> IO Header
forall a b. (a -> b) -> a -> b
$ \ReadBuffer
rbuf ->
    Index -> Counter -> Header
Header (Index -> Counter -> Header) -> IO Index -> IO (Counter -> Header)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBuffer -> IO Index
forall a. Readable a => a -> IO Index
read16 ReadBuffer
rbuf IO (Counter -> Header) -> IO Counter -> IO Header
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBuffer -> IO Counter
forall a. Readable a => a -> IO Counter
read64 ReadBuffer
rbuf

newHeaderKey :: IO AES256
newHeaderKey :: IO AES256
newHeaderKey = do
    key <- BufferSize -> IO ByteString
forall byteArray. ByteArray byteArray => BufferSize -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
BufferSize -> m byteArray
getRandomBytes BufferSize
keyLength :: IO ByteString
    return $ throwCryptoError $ C.cipherInit key

----------------------------------------------------------------

-- The header is encrypted so that tokens do not reveal how they relate.
addHeader :: TokenManager -> Index -> Counter -> ByteString -> IO ByteString
addHeader :: TokenManager -> Index -> Counter -> ByteString -> IO ByteString
addHeader TokenManager{IO (Secret, Index)
Counter
AES256
ThreadId
Index -> IO Secret
headerKey :: TokenManager -> AES256
getEncryptSecret :: TokenManager -> IO (Secret, Index)
getDecryptSecret :: TokenManager -> Index -> IO Secret
threadId :: TokenManager -> ThreadId
lifetimeNSec :: TokenManager -> Counter
headerKey :: AES256
getEncryptSecret :: IO (Secret, Index)
getDecryptSecret :: Index -> IO Secret
threadId :: ThreadId
lifetimeNSec :: Counter
..} Index
idx Counter
counter ByteString
cipher = do
    hdrbin <- Header -> IO ByteString
encodeHeader (Header -> IO ByteString) -> Header -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Index -> Counter -> Header
Header Index
idx Counter
counter
    let padding = BufferSize -> Word8 -> ByteString
BS.replicate (BufferSize
headerLength BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
- ByteString -> BufferSize
BS.length ByteString
hdrbin) Word8
0
        blk = AES256 -> ByteString -> ByteString
forall ba. ByteArray ba => AES256 -> ba -> ba
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> ba -> ba
C.ecbEncrypt AES256
headerKey (ByteString
hdrbin ByteString -> ByteString -> ByteString
`BS.append` ByteString
padding)
    return (blk `BS.append` cipher)

delHeader
    :: TokenManager -> ByteString -> IO (Maybe (Index, Counter, ByteString))
delHeader :: TokenManager
-> ByteString -> IO (Maybe (Index, Counter, ByteString))
delHeader TokenManager{IO (Secret, Index)
Counter
AES256
ThreadId
Index -> IO Secret
headerKey :: TokenManager -> AES256
getEncryptSecret :: TokenManager -> IO (Secret, Index)
getDecryptSecret :: TokenManager -> Index -> IO Secret
threadId :: TokenManager -> ThreadId
lifetimeNSec :: TokenManager -> Counter
headerKey :: AES256
getEncryptSecret :: IO (Secret, Index)
getDecryptSecret :: Index -> IO Secret
threadId :: ThreadId
lifetimeNSec :: Counter
..} ByteString
token
    | ByteString -> BufferSize
BS.length ByteString
token BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufferSize
headerLength = Maybe (Index, Counter, ByteString)
-> IO (Maybe (Index, Counter, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Index, Counter, ByteString)
forall a. Maybe a
Nothing
    | Bool
otherwise = do
        let (ByteString
blk, ByteString
cipher) = BufferSize -> ByteString -> (ByteString, ByteString)
BS.splitAt BufferSize
headerLength ByteString
token
            (ByteString
hdrbin, ByteString
padding) =
                BufferSize -> ByteString -> (ByteString, ByteString)
BS.splitAt (BufferSize
indexLength BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
counterLength) (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ AES256 -> ByteString -> ByteString
forall ba. ByteArray ba => AES256 -> ba -> ba
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> ba -> ba
C.ecbDecrypt AES256
headerKey ByteString
blk
        if (Word8 -> Bool) -> ByteString -> Bool
BS.any (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) ByteString
padding
            then Maybe (Index, Counter, ByteString)
-> IO (Maybe (Index, Counter, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Index, Counter, ByteString)
forall a. Maybe a
Nothing
            else do
                Header{..} <- ByteString -> IO Header
decodeHeader ByteString
hdrbin
                return $ Just (headerIndex, headerCounter, cipher)

-- | Encrypting a target value to get a token.
encryptToken
    :: TokenManager
    -> ByteString
    -> IO ByteString
encryptToken :: TokenManager -> ByteString -> IO ByteString
encryptToken TokenManager
mgr ByteString
x = do
    (secret, idx) <- TokenManager -> IO (Secret, Index)
getEncryptSecret TokenManager
mgr
    now <- getMonotonicTimeNSec
    (counter, cipher) <- encrypt secret (bytestring64 now `BS.append` x)
    addHeader mgr idx counter cipher

encrypt
    :: Secret
    -> ByteString
    -> IO (Counter, ByteString)
encrypt :: Secret -> ByteString -> IO (Counter, ByteString)
encrypt Secret
secret ByteString
plain = do
    counter <- IORef Counter -> (Counter -> (Counter, Counter)) -> IO Counter
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef' (Secret -> IORef Counter
secretCounter Secret
secret) (\Counter
i -> (Counter
i Counter -> Counter -> Counter
forall a. Num a => a -> a -> a
+ Counter
1, Counter
i))
    let nonce = Counter -> ByteString -> ByteString
makeNonce Counter
counter (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Secret -> ByteString
secretIV Secret
secret
        cipher = ByteString -> ByteString -> ByteString -> ByteString
aes256gcmEncrypt ByteString
plain (Secret -> ByteString
secretKey Secret
secret) ByteString
nonce
    return (counter, cipher)

-- | Decrypting a token to get a target value.
decryptToken
    :: TokenManager
    -> ByteString
    -> IO (Maybe ByteString)
decryptToken :: TokenManager -> ByteString -> IO (Maybe ByteString)
decryptToken TokenManager
mgr ByteString
token = do
    mx <- TokenManager
-> ByteString -> IO (Maybe (Index, Counter, ByteString))
delHeader TokenManager
mgr ByteString
token
    case mx of
        Maybe (Index, Counter, ByteString)
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
        Just (Index
idx, Counter
counter, ByteString
cipher) -> do
            secret <- TokenManager -> Index -> IO Secret
getDecryptSecret TokenManager
mgr Index
idx
            mplain <- decrypt secret counter cipher
            now <- getMonotonicTimeNSec
            return $ mplain >>= checkLifetime now
  where
    checkLifetime :: Counter -> ByteString -> Maybe ByteString
checkLifetime Counter
now ByteString
plain
        | ByteString -> BufferSize
BS.length ByteString
plain BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufferSize
8 = Maybe ByteString
forall a. Maybe a
Nothing
        | Counter
issued Counter -> Counter -> Bool
forall a. Ord a => a -> a -> Bool
<= Counter
now Bool -> Bool -> Bool
&& Counter
now Counter -> Counter -> Counter
forall a. Num a => a -> a -> a
- Counter
issued Counter -> Counter -> Bool
forall a. Ord a => a -> a -> Bool
<= TokenManager -> Counter
lifetimeNSec TokenManager
mgr = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x
        | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing
      where
        (ByteString
hdr, ByteString
x) = BufferSize -> ByteString -> (ByteString, ByteString)
BS.splitAt BufferSize
8 ByteString
plain
        issued :: Counter
issued = ByteString -> Counter
word64 ByteString
hdr

decrypt
    :: Secret
    -> Counter
    -> ByteString
    -> IO (Maybe ByteString)
decrypt :: Secret -> Counter -> ByteString -> IO (Maybe ByteString)
decrypt Secret
secret Counter
counter ByteString
cipher = do
    let nonce :: ByteString
nonce = Counter -> ByteString -> ByteString
makeNonce Counter
counter (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Secret -> ByteString
secretIV Secret
secret
    Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString -> Maybe ByteString
aes256gcmDecrypt ByteString
cipher (Secret -> ByteString
secretKey Secret
secret) ByteString
nonce

makeNonce :: Counter -> ByteString -> ByteString
makeNonce :: Counter -> ByteString -> ByteString
makeNonce Counter
counter ByteString
iv = ByteString
iv ByteString -> ByteString -> ByteString
forall a b c.
(ByteArrayAccess a, ByteArrayAccess b, ByteArray c) =>
a -> b -> c
`BA.xor` ByteString
cv
  where
    cv :: ByteString
cv = BufferSize -> Word8 -> ByteString
BS.replicate (BufferSize
ivLength BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
- BufferSize
counterLength) Word8
0 ByteString -> ByteString -> ByteString
`BS.append` Counter -> ByteString
bytestring64 Counter
counter

----------------------------------------------------------------

constantAdditionalData :: ByteString
constantAdditionalData :: ByteString
constantAdditionalData = ByteString
BS.empty

aes256gcmEncrypt
    :: ByteString
    -> ByteString
    -> ByteString
    -> ByteString
aes256gcmEncrypt :: ByteString -> ByteString -> ByteString -> ByteString
aes256gcmEncrypt ByteString
plain ByteString
key ByteString
nonce = ByteString
cipher ByteString -> ByteString -> ByteString
`BS.append` (Bytes -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert Bytes
tag)
  where
    conn :: AES256
conn = CryptoFailable AES256 -> AES256
forall a. CryptoFailable a -> a
throwCryptoError (ByteString -> CryptoFailable AES256
forall key. ByteArray key => key -> CryptoFailable AES256
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
C.cipherInit ByteString
key) :: AES256
    aeadIni :: AEAD AES256
aeadIni = CryptoFailable (AEAD AES256) -> AEAD AES256
forall a. CryptoFailable a -> a
throwCryptoError (CryptoFailable (AEAD AES256) -> AEAD AES256)
-> CryptoFailable (AEAD AES256) -> AEAD AES256
forall a b. (a -> b) -> a -> b
$ AEADMode -> AES256 -> ByteString -> CryptoFailable (AEAD AES256)
forall cipher iv.
(BlockCipher cipher, ByteArrayAccess iv) =>
AEADMode -> cipher -> iv -> CryptoFailable (AEAD cipher)
forall iv.
ByteArrayAccess iv =>
AEADMode -> AES256 -> iv -> CryptoFailable (AEAD AES256)
C.aeadInit AEADMode
AEAD_GCM AES256
conn ByteString
nonce
    (AuthTag Bytes
tag, ByteString
cipher) = AEAD AES256
-> ByteString -> ByteString -> BufferSize -> (AuthTag, ByteString)
forall aad ba a.
(ByteArrayAccess aad, ByteArray ba) =>
AEAD a -> aad -> ba -> BufferSize -> (AuthTag, ba)
C.aeadSimpleEncrypt AEAD AES256
aeadIni ByteString
constantAdditionalData ByteString
plain BufferSize
tagLength

aes256gcmDecrypt
    :: ByteString
    -> ByteString
    -> ByteString
    -> Maybe ByteString
aes256gcmDecrypt :: ByteString -> ByteString -> ByteString -> Maybe ByteString
aes256gcmDecrypt ByteString
ctexttag ByteString
key ByteString
nonce = do
    aes <- CryptoFailable AES256 -> Maybe AES256
forall a. CryptoFailable a -> Maybe a
maybeCryptoError (CryptoFailable AES256 -> Maybe AES256)
-> CryptoFailable AES256 -> Maybe AES256
forall a b. (a -> b) -> a -> b
$ ByteString -> CryptoFailable AES256
forall key. ByteArray key => key -> CryptoFailable AES256
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
C.cipherInit ByteString
key :: Maybe AES256
    aead <- maybeCryptoError $ C.aeadInit AEAD_GCM aes nonce
    let (ctext, tag) = BS.splitAt (BS.length ctexttag - tagLength) ctexttag
        authtag = Bytes -> AuthTag
AuthTag (Bytes -> AuthTag) -> Bytes -> AuthTag
forall a b. (a -> b) -> a -> b
$ ByteString -> Bytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ByteString
tag
    C.aeadSimpleDecrypt aead constantAdditionalData ctext authtag