module Data.CryptoID.ByteString
( CryptoID(..)
, CryptoIDKey
, genKey, readKeyFile
, encrypt
, decrypt
, CryptoIDError(..)
, CryptoCipher, CryptoHash
, cipherBlockSize
) where
import Data.CryptoID
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as ByteString.Char
import Data.List (sortOn)
import Data.Ord (Down(..))
import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as ByteArray
import Data.Foldable (asum)
import Control.Monad.Catch (MonadThrow(..))
import Control.Monad.IO.Class
import Control.Monad
import Control.Exception
import System.IO.Error
import Data.Typeable
import GHC.TypeLits
import Crypto.Cipher.Types
import Crypto.Cipher.Blowfish (Blowfish)
import Crypto.Hash (hash, Digest)
import Crypto.Hash.Algorithms (SHAKE128)
import Crypto.Error
import Crypto.Random.Entropy
import System.Directory
import System.FilePath
type CryptoCipher = Blowfish
type CryptoHash = SHAKE128 64
cipherBlockSize :: Int
cipherBlockSize = blockSize (undefined :: CryptoCipher)
newtype CryptoIDKey = CryptoIDKey { keyMaterial :: ByteString }
deriving (Typeable, ByteArrayAccess)
instance Show CryptoIDKey where
show = show . typeOf
instance Binary CryptoIDKey where
put = putByteString . keyMaterial
get = CryptoIDKey <$> getKey (cipherKeySize cipher)
where
cipher :: CryptoCipher
cipher = undefined
getKey (KeySizeFixed n) = getByteString n
getKey (KeySizeEnum ns) = asum [ getKey $ KeySizeFixed n | n <- sortOn Down ns ]
getKey (KeySizeRange min max) = getKey $ KeySizeEnum [min .. max]
data CryptoIDError
= AlgorithmError CryptoError
| PlaintextIsWrongLength Int
| NamespaceHashIsWrongLength ByteString
| CiphertextConversionFailed ByteString
| DeserializationError
| InvalidNamespaceDetected
deriving (Show, Eq)
instance Exception CryptoIDError
genKey :: MonadIO m => m CryptoIDKey
genKey = CryptoIDKey <$> liftIO (getEntropy keySize)
where
keySize' = cipherKeySize (undefined :: CryptoCipher)
keySize
| KeySizeFixed n <- keySize' = n
| KeySizeEnum ns <- keySize' = maximum ns
| KeySizeRange _ max <- keySize' = max
readKeyFile :: MonadIO m => FilePath -> m CryptoIDKey
readKeyFile keyFile = liftIO $ decodeFile keyFile `catch` generateInstead
where
generateInstead e
| isDoesNotExistError e = do
createDirectoryIfMissing True $ takeDirectory keyFile
key <- genKey
encodeFile keyFile key
return key
| otherwise = throw e
namespace' :: forall proxy namespace m.
( KnownSymbol namespace, MonadThrow m
) => proxy namespace -> m (IV CryptoCipher)
namespace' p = case makeIV namespaceHash of
Nothing -> throwM . NamespaceHashIsWrongLength $ ByteArray.convert namespaceHash
Just iv -> return iv
where
namespaceHash :: Digest CryptoHash
namespaceHash = hash . ByteString.Char.pack $ symbolVal p
cryptoFailable :: MonadThrow m => CryptoFailable a -> m a
cryptoFailable = either (throwM . AlgorithmError) return . eitherCryptoError
encrypt :: forall m namespace.
( KnownSymbol namespace
, MonadThrow m
) => CryptoIDKey -> ByteString -> m (CryptoID namespace ByteString)
encrypt (keyMaterial -> key) plaintext = do
cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher)
namespace <- namespace' (Proxy :: Proxy namespace)
when (ByteString.length plaintext `mod` blockSize cipher /= 0) $
throwM . PlaintextIsWrongLength $ ByteString.length plaintext
return . CryptoID $ cbcEncrypt cipher namespace plaintext
decrypt :: forall m namespace.
( KnownSymbol namespace
, MonadThrow m
) => CryptoIDKey -> CryptoID namespace ByteString -> m ByteString
decrypt (keyMaterial -> key) CryptoID{..} = do
cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher)
namespace <- namespace' (Proxy :: Proxy namespace)
return $ cbcDecrypt cipher namespace ciphertext