{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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

import Control.Concurrent
import Crypto.Cipher.AES (AES256)
import Crypto.Cipher.Types (AuthTag(..), AEADMode(..))
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.IORef as I
import Data.Int (Int64)
import Data.Word (Word16, Word64)
import Foreign.Ptr
import Foreign.Storable

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

-- | Configuration for token manager.
data Config = Config {
  -- | The interval to generate a new secret and remove the oldest one in minutes.
    Config -> Int
interval   :: Int
  -- | Maximum size of secret entries. Minimum is 256 and maximum is 32767.
  , Config -> Int
maxEntries :: Int
  }

-- | Default configuration to update secrets in 30 minutes and keep them for 10 days.
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config :: Int -> Int -> Config
Config {
    interval :: Int
interval = Int
30
  , maxEntries :: Int
maxEntries = Int
480
  }

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

-- fixme: mask
-- | The abstract data type for token manager.
data TokenManager = TokenManager {
    TokenManager -> IOArray Int Secret
secrets :: IOArray Int Secret
  , TokenManager -> IORef Int
currentIndex :: I.IORef Int
  , TokenManager -> Header
headerMask :: Header
  , TokenManager -> ThreadId
threadId :: ThreadId
  }

-- | Spawning a token manager.
spawnTokenManager :: Config -> IO TokenManager
spawnTokenManager :: Config -> IO TokenManager
spawnTokenManager Config{Int
maxEntries :: Int
interval :: Int
maxEntries :: Config -> Int
interval :: Config -> Int
..} = do
    Secret
emp <- IO Secret
emptySecret
    let lim :: Int
lim = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
256 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxEntries Int
32767)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    IOArray Int Secret
arr <- (Int, Int) -> Secret -> IO (IOArray Int Secret)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0, Int
lim) Secret
emp
    IOArray Int Secret -> Int -> IO ()
update IOArray Int Secret
arr Int
0
    IORef Int
ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
I.newIORef Int
0
    ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IOArray Int Secret -> IORef Int -> IO ()
forall b. IOArray Int Secret -> IORef Int -> IO b
loop IOArray Int Secret
arr IORef Int
ref
    Header
msk <- IO Header
newHeaderMask
    TokenManager -> IO TokenManager
forall (m :: * -> *) a. Monad m => a -> m a
return (TokenManager -> IO TokenManager)
-> TokenManager -> IO TokenManager
forall a b. (a -> b) -> a -> b
$ IOArray Int Secret
-> IORef Int -> Header -> ThreadId -> TokenManager
TokenManager IOArray Int Secret
arr IORef Int
ref Header
msk ThreadId
tid
  where
    update :: IOArray Int Secret -> Int -> IO ()
    update :: IOArray Int Secret -> Int -> IO ()
update IOArray Int Secret
arr Int
idx = do
        Secret
ent <- IO Secret
generateSecret
        IOArray Int Secret -> Int -> Secret -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Int Secret
arr Int
idx Secret
ent
    loop :: IOArray Int Secret -> IORef Int -> IO b
loop IOArray Int Secret
arr IORef Int
ref = do
        Int -> IO ()
threadDelay (Int
interval Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
        Int
idx0 <- IORef Int -> IO Int
forall a. IORef a -> IO a
I.readIORef IORef Int
ref
        (Int
_, Int
n) <- IOArray Int Secret -> IO (Int, Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds IOArray Int Secret
arr
        let idx :: Int
idx = (Int
idx0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        IOArray Int Secret -> Int -> IO ()
update IOArray Int Secret
arr Int
idx
        IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef Int
ref Int
idx
        IOArray Int Secret -> IORef Int -> IO b
loop IOArray Int Secret
arr IORef Int
ref

-- | Killing a token manager.
killTokenManager :: TokenManager -> IO ()
killTokenManager :: TokenManager -> IO ()
killTokenManager TokenManager{IOArray Int Secret
ThreadId
IORef Int
Header
threadId :: ThreadId
headerMask :: Header
currentIndex :: IORef Int
secrets :: IOArray Int Secret
threadId :: TokenManager -> ThreadId
headerMask :: TokenManager -> Header
currentIndex :: TokenManager -> IORef Int
secrets :: TokenManager -> IOArray Int Secret
..} = ThreadId -> IO ()
killThread ThreadId
threadId

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

getSecret :: TokenManager -> Int -> IO Secret
getSecret :: TokenManager -> Int -> IO Secret
getSecret TokenManager{IOArray Int Secret
ThreadId
IORef Int
Header
threadId :: ThreadId
headerMask :: Header
currentIndex :: IORef Int
secrets :: IOArray Int Secret
threadId :: TokenManager -> ThreadId
headerMask :: TokenManager -> Header
currentIndex :: TokenManager -> IORef Int
secrets :: TokenManager -> IOArray Int Secret
..} Int
idx0 = do
    (Int
_, Int
n) <- IOArray Int Secret -> IO (Int, Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds IOArray Int Secret
secrets
    let idx :: Int
idx = Int
idx0 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    IOArray Int Secret -> Int -> IO Secret
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Int Secret
secrets Int
idx

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

data Secret = Secret {
    Secret -> Bytes
secretIV      :: Bytes
  , Secret -> Bytes
secretKey     :: Bytes
  , Secret -> IORef Int64
secretCounter :: I.IORef Int64
  }

emptySecret :: IO Secret
emptySecret :: IO Secret
emptySecret = Bytes -> Bytes -> IORef Int64 -> Secret
Secret Bytes
forall a. ByteArray a => a
BA.empty Bytes
forall a. ByteArray a => a
BA.empty (IORef Int64 -> Secret) -> IO (IORef Int64) -> IO Secret
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int64 -> IO (IORef Int64)
forall a. a -> IO (IORef a)
I.newIORef Int64
0

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

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

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

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

ivLength :: Int
ivLength :: Int
ivLength = Int
8

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

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

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

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

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

data Header = Header {
    Header -> Word16
headerIndex   :: Word16
  , Header -> Word64
headerCounter :: Word64
  }

instance Storable Header where
    sizeOf :: Header -> Int
sizeOf Header
_    = Int
indexLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
counterLength
    alignment :: Header -> Int
alignment Header
_ = Int
indexLength -- fixme
    peek :: Ptr Header -> IO Header
peek Ptr Header
p = do
        Word16
i <- Ptr Word16 -> IO Word16
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word16 -> IO Word16) -> Ptr Word16 -> IO Word16
forall a b. (a -> b) -> a -> b
$ Ptr Header -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Header
p
        Word64
c <- Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek (Ptr Header -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr Header
p Ptr Any -> Int -> Ptr Word64
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
indexLength)
        Header -> IO Header
forall (m :: * -> *) a. Monad m => a -> m a
return (Header -> IO Header) -> Header -> IO Header
forall a b. (a -> b) -> a -> b
$ Word16 -> Word64 -> Header
Header Word16
i Word64
c
    poke :: Ptr Header -> Header -> IO ()
poke Ptr Header
p (Header Word16
i Word64
c) = do
        Ptr Word16 -> Word16 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Header -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Header
p) Word16
i
        Ptr Word64 -> Word64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Header -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr Header
p Ptr Any -> Int -> Ptr Word64
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
indexLength) Word64
c

newHeaderMask :: IO Header
newHeaderMask :: IO Header
newHeaderMask = do
    Bytes
bin <- Int -> IO Bytes
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes (Int
indexLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
counterLength) :: IO Bytes
    Bytes -> (Ptr Header -> IO Header) -> IO Header
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray Bytes
bin Ptr Header -> IO Header
forall a. Storable a => Ptr a -> IO a
peek

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

xorHeader :: Header -> Header -> Header
xorHeader :: Header -> Header -> Header
xorHeader Header
x Header
y = Header :: Word16 -> Word64 -> Header
Header {
    headerIndex :: Word16
headerIndex = Header -> Word16
headerIndex Header
x Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
`xor` Header -> Word16
headerIndex Header
y
  , headerCounter :: Word64
headerCounter = Header -> Word64
headerCounter Header
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Header -> Word64
headerCounter Header
y
  }

addHeader :: ByteArray ba => TokenManager -> Int -> Int64 -> ba -> IO ba
addHeader :: TokenManager -> Int -> Int64 -> ba -> IO ba
addHeader TokenManager{IOArray Int Secret
ThreadId
IORef Int
Header
threadId :: ThreadId
headerMask :: Header
currentIndex :: IORef Int
secrets :: IOArray Int Secret
threadId :: TokenManager -> ThreadId
headerMask :: TokenManager -> Header
currentIndex :: TokenManager -> IORef Int
secrets :: TokenManager -> IOArray Int Secret
..} Int
idx Int64
counter ba
cipher = do
    let hdr :: Header
hdr = Word16 -> Word64 -> Header
Header (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx) (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
counter)
        mskhdr :: Header
mskhdr = Header
headerMask Header -> Header -> Header
`xorHeader` Header
hdr
    ba
hdrbin <- Int -> (Ptr Header -> IO ()) -> IO ba
forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
BA.create (Header -> Int
forall a. Storable a => a -> Int
sizeOf Header
mskhdr) ((Ptr Header -> IO ()) -> IO ba) -> (Ptr Header -> IO ()) -> IO ba
forall a b. (a -> b) -> a -> b
$ \Ptr Header
ptr -> Ptr Header -> Header -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Header
ptr Header
mskhdr
    ba -> IO ba
forall (m :: * -> *) a. Monad m => a -> m a
return (ba
hdrbin ba -> ba -> ba
forall bs. ByteArray bs => bs -> bs -> bs
`BA.append` ba
cipher)

delHeader :: ByteArray ba => TokenManager -> ba -> IO (Maybe (Int, Int64, ba))
delHeader :: TokenManager -> ba -> IO (Maybe (Int, Int64, ba))
delHeader TokenManager{IOArray Int Secret
ThreadId
IORef Int
Header
threadId :: ThreadId
headerMask :: Header
currentIndex :: IORef Int
secrets :: IOArray Int Secret
threadId :: TokenManager -> ThreadId
headerMask :: TokenManager -> Header
currentIndex :: TokenManager -> IORef Int
secrets :: TokenManager -> IOArray Int Secret
..} ba
token
  | ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length ba
token Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minlen = Maybe (Int, Int64, ba) -> IO (Maybe (Int, Int64, ba))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Int64, ba)
forall a. Maybe a
Nothing
  | Bool
otherwise = do
        let (ba
hdrbin, ba
cipher) = Int -> ba -> (ba, ba)
forall bs. ByteArray bs => Int -> bs -> (bs, bs)
BA.splitAt Int
minlen ba
token
        Header
mskhdr <- ba -> (Ptr Header -> IO Header) -> IO Header
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray ba
hdrbin Ptr Header -> IO Header
forall a. Storable a => Ptr a -> IO a
peek
        let hdr :: Header
hdr = Header
headerMask Header -> Header -> Header
`xorHeader` Header
mskhdr
            idx :: Int
idx = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ Header -> Word16
headerIndex Header
hdr
            counter :: Int64
counter = Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Word64 -> Int64
forall a b. (a -> b) -> a -> b
$ Header -> Word64
headerCounter Header
hdr
        Maybe (Int, Int64, ba) -> IO (Maybe (Int, Int64, ba))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Int, Int64, ba) -> IO (Maybe (Int, Int64, ba)))
-> Maybe (Int, Int64, ba) -> IO (Maybe (Int, Int64, ba))
forall a b. (a -> b) -> a -> b
$ (Int, Int64, ba) -> Maybe (Int, Int64, ba)
forall a. a -> Maybe a
Just (Int
idx, Int64
counter, ba
cipher)
  where
    minlen :: Int
minlen = Int
indexLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
counterLength

-- | Encrypting a target value to get a token.
encryptToken :: (Storable a, ByteArray ba)
             => TokenManager -> a -> IO ba
encryptToken :: TokenManager -> a -> IO ba
encryptToken TokenManager
mgr a
x = do
    Int
idx <- IORef Int -> IO Int
forall a. IORef a -> IO a
I.readIORef (IORef Int -> IO Int) -> IORef Int -> IO Int
forall a b. (a -> b) -> a -> b
$ TokenManager -> IORef Int
currentIndex TokenManager
mgr
    Secret
secret <- TokenManager -> Int -> IO Secret
getSecret TokenManager
mgr Int
idx
    (Int64
counter, ba
cipher) <- Secret -> a -> IO (Int64, ba)
forall a ba.
(Storable a, ByteArray ba) =>
Secret -> a -> IO (Int64, ba)
encrypt Secret
secret a
x
    TokenManager -> Int -> Int64 -> ba -> IO ba
forall ba.
ByteArray ba =>
TokenManager -> Int -> Int64 -> ba -> IO ba
addHeader TokenManager
mgr Int
idx Int64
counter ba
cipher

encrypt :: (Storable a, ByteArray ba)
        => Secret -> a -> IO (Int64, ba)
encrypt :: Secret -> a -> IO (Int64, ba)
encrypt Secret
secret a
x = do
    Int64
counter <- IORef Int64 -> (Int64 -> (Int64, Int64)) -> IO Int64
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef' (Secret -> IORef Int64
secretCounter Secret
secret) (\Int64
i -> (Int64
iInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+Int64
1, Int64
i))
    ba
plain <- Int -> (Ptr a -> IO ()) -> IO ba
forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
BA.create (a -> Int
forall a. Storable a => a -> Int
sizeOf a
x) ((Ptr a -> IO ()) -> IO ba) -> (Ptr a -> IO ()) -> IO ba
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
ptr a
x
    Bytes
nonce <- Int64 -> Bytes -> IO Bytes
forall ba. ByteArray ba => Int64 -> ba -> IO ba
makeNonce Int64
counter (Bytes -> IO Bytes) -> Bytes -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Secret -> Bytes
secretIV Secret
secret
    let cipher :: ba
cipher = ba -> Bytes -> Bytes -> ba
forall ba. ByteArray ba => ba -> Bytes -> Bytes -> ba
aes256gcmEncrypt ba
plain (Secret -> Bytes
secretKey Secret
secret) Bytes
nonce
    (Int64, ba) -> IO (Int64, ba)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64
counter, ba
cipher)

-- | Decrypting a token to get a target value.
decryptToken :: (Storable a, ByteArray ba)
             => TokenManager -> ba -> IO (Maybe a)
decryptToken :: TokenManager -> ba -> IO (Maybe a)
decryptToken TokenManager
mgr ba
token = do
    Maybe (Int, Int64, ba)
mx <- TokenManager -> ba -> IO (Maybe (Int, Int64, ba))
forall ba.
ByteArray ba =>
TokenManager -> ba -> IO (Maybe (Int, Int64, ba))
delHeader TokenManager
mgr ba
token
    case Maybe (Int, Int64, ba)
mx of
      Maybe (Int, Int64, ba)
Nothing -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
      Just (Int
idx, Int64
counter, ba
cipher) -> do
          Secret
secret <- TokenManager -> Int -> IO Secret
getSecret TokenManager
mgr Int
idx
          Secret -> Int64 -> ba -> IO (Maybe a)
forall a ba.
(Storable a, ByteArray ba) =>
Secret -> Int64 -> ba -> IO (Maybe a)
decrypt Secret
secret Int64
counter ba
cipher

decrypt :: forall a ba . (Storable a, ByteArray ba)
        => Secret -> Int64 -> ba -> IO (Maybe a)
decrypt :: Secret -> Int64 -> ba -> IO (Maybe a)
decrypt Secret
secret Int64
counter ba
cipher = do
    Bytes
nonce <- Int64 -> Bytes -> IO Bytes
forall ba. ByteArray ba => Int64 -> ba -> IO ba
makeNonce Int64
counter (Bytes -> IO Bytes) -> Bytes -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Secret -> Bytes
secretIV Secret
secret
    let mplain :: Maybe ba
mplain = ba -> Bytes -> Bytes -> Maybe ba
forall ba. ByteArray ba => ba -> Bytes -> Bytes -> Maybe ba
aes256gcmDecrypt ba
cipher (Secret -> Bytes
secretKey Secret
secret) Bytes
nonce
        expect :: Int
expect = a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
    case Maybe ba
mplain of
      Just ba
plain
        | ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length ba
plain Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expect -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ba -> (Ptr a -> IO a) -> IO a
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray ba
plain Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek
      Maybe ba
_                             -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing


makeNonce :: forall ba . ByteArray ba => Int64 -> ba -> IO ba
makeNonce :: Int64 -> ba -> IO ba
makeNonce Int64
counter ba
iv = do
    ba
cv <- Int -> (Ptr Int64 -> IO ()) -> IO ba
forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
BA.create Int
ivLength ((Ptr Int64 -> IO ()) -> IO ba) -> (Ptr Int64 -> IO ()) -> IO ba
forall a b. (a -> b) -> a -> b
$ \Ptr Int64
ptr -> Ptr Int64 -> Int64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Int64
ptr Int64
counter
    ba -> IO ba
forall (m :: * -> *) a. Monad m => a -> m a
return (ba -> IO ba) -> ba -> IO ba
forall a b. (a -> b) -> a -> b
$ ba
iv ba -> ba -> ba
forall a b c.
(ByteArrayAccess a, ByteArrayAccess b, ByteArray c) =>
a -> b -> c
`BA.xor` (ba
cv :: ba)

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

constantAdditionalData :: Bytes
constantAdditionalData :: Bytes
constantAdditionalData = Bytes
forall a. ByteArray a => a
BA.empty

aes256gcmEncrypt :: ByteArray ba
                 => ba -> Bytes -> Bytes -> ba
aes256gcmEncrypt :: ba -> Bytes -> Bytes -> ba
aes256gcmEncrypt ba
plain Bytes
key Bytes
nonce = ba
cipher ba -> ba -> ba
forall bs. ByteArray bs => bs -> bs -> bs
`BA.append` Bytes -> ba
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 (Bytes -> CryptoFailable AES256
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
C.cipherInit Bytes
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 -> Bytes -> CryptoFailable (AEAD AES256)
forall cipher iv.
(BlockCipher cipher, ByteArrayAccess iv) =>
AEADMode -> cipher -> iv -> CryptoFailable (AEAD cipher)
C.aeadInit AEADMode
AEAD_GCM AES256
conn Bytes
nonce
    (AuthTag Bytes
tag, ba
cipher) = AEAD AES256 -> Bytes -> ba -> Int -> (AuthTag, ba)
forall aad ba a.
(ByteArrayAccess aad, ByteArray ba) =>
AEAD a -> aad -> ba -> Int -> (AuthTag, ba)
C.aeadSimpleEncrypt AEAD AES256
aeadIni Bytes
constantAdditionalData ba
plain Int
tagLength

aes256gcmDecrypt :: ByteArray ba
                 => ba -> Bytes -> Bytes -> Maybe ba
aes256gcmDecrypt :: ba -> Bytes -> Bytes -> Maybe ba
aes256gcmDecrypt ba
ctexttag Bytes
key Bytes
nonce = do
    AES256
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
$ Bytes -> CryptoFailable AES256
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
C.cipherInit Bytes
key :: Maybe AES256
    AEAD AES256
aead <- CryptoFailable (AEAD AES256) -> Maybe (AEAD AES256)
forall a. CryptoFailable a -> Maybe a
maybeCryptoError (CryptoFailable (AEAD AES256) -> Maybe (AEAD AES256))
-> CryptoFailable (AEAD AES256) -> Maybe (AEAD AES256)
forall a b. (a -> b) -> a -> b
$ AEADMode -> AES256 -> Bytes -> CryptoFailable (AEAD AES256)
forall cipher iv.
(BlockCipher cipher, ByteArrayAccess iv) =>
AEADMode -> cipher -> iv -> CryptoFailable (AEAD cipher)
C.aeadInit AEADMode
AEAD_GCM AES256
aes Bytes
nonce
    let (ba
ctext, ba
tag) = Int -> ba -> (ba, ba)
forall bs. ByteArray bs => Int -> bs -> (bs, bs)
BA.splitAt (ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length ba
ctexttag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tagLength) ba
ctexttag
        authtag :: AuthTag
authtag = Bytes -> AuthTag
AuthTag (Bytes -> AuthTag) -> Bytes -> AuthTag
forall a b. (a -> b) -> a -> b
$ ba -> Bytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ba
tag
    AEAD AES256 -> Bytes -> ba -> AuthTag -> Maybe ba
forall aad ba a.
(ByteArrayAccess aad, ByteArray ba) =>
AEAD a -> aad -> ba -> AuthTag -> Maybe ba
C.aeadSimpleDecrypt AEAD AES256
aead Bytes
constantAdditionalData ba
ctext AuthTag
authtag