haskell/cryptoids
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

MonadThrow & readKeyFile

Browse Source
This commit is contained in:
Gregor Kleen 2017-10-10 14:13:16 +02:00
parent 5d9f672eb2
commit aa2129e617
6 changed files with 51 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
cryptoids/changes.md
View File

@ -1,3 +1,7 @@
# 0.1.0
- Switch to using 'MonadThrow' instead of 'MonadError'
- Introduce 'readKeyFile'
# 0.0.0
First published version

6
cryptoids/cryptoids.cabal
View File

@ -1,5 +1,5 @@
name: cryptoids
version: 0.0.0
version: 0.1.0
synopsis: Reversable and secure encoding of object ids as a bytestring
license: BSD3
license-file: LICENSE
@ -28,6 +28,8 @@ library
, bytestring >=0.10.8.1 && <0.11
, binary >=0.8.3.0 && <0.9
, memory >=0.14.6 && <0.15
, mtl >=2.2.1 && <2.3
, exceptions >=0.8.3 && <0.9
, filepath >=1.4.1.1 && <1.5
, directory >=1.3.0.0 && <1.4
hs-source-dirs: src
default-language: Haskell2010

38
cryptoids/src/Data/CryptoID/Poly.hs
View File

@ -16,7 +16,7 @@ where \(l\) is the length of the serialized payload.
module Data.CryptoID.Poly
( CryptoID(..)
, CryptoIDKey
, genKey
, genKey, readKeyFile
, encrypt
, decrypt
, CryptoIDError(..)
@ -42,8 +42,10 @@ import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as ByteArray
import Data.Foldable (asum)
import Control.Monad.Except
import Control.Monad.Catch (MonadThrow(..))
import Control.Monad.IO.Class
import Control.Exception
import System.IO.Error
import Data.Typeable
import GHC.TypeLits
@ -56,6 +58,9 @@ import Crypto.Error
import Crypto.Random.Entropy
import System.Directory
import System.FilePath
-- | The symmetric cipher 'BlockCipher' this module uses
type CryptoCipher = Blowfish
@ -92,7 +97,7 @@ instance Binary CryptoIDKey where
-- that parses)
getKey (KeySizeFixed n) = getByteString n
getKey (KeySizeEnum ns) = asum [ getKey $ KeySizeFixed n | n <- sortOn Down ns ]
getKey (KeySizeRange min max) = getKey $ KeySizeEnum [max .. min]
getKey (KeySizeRange min max) = getKey $ KeySizeEnum [min .. max]
-- | Error cases that can be encountered during 'encrypt' and 'decrypt'
@ -140,6 +145,21 @@ genKey = CryptoIDKey <$> liftIO (getEntropy keySize)
| KeySizeFixed n <- keySize' = n
| KeySizeEnum ns <- keySize' = maximum ns
| KeySizeRange _ max <- keySize' = max
-- | Try to read a 'CryptoIDKey' from a file.
-- If the file does not exist, securely generate a key (using 'genKey') and
-- save it to the file.
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
-- | @pad err size src@ appends null bytes to @src@ until it has length that is
@ -151,23 +171,23 @@ pad n (ByteArray.unpack -> src) = ByteString.pack $ src ++ replicate (l `mod` n)
-- | Use 'CryptoHash' to generate a 'Digest' of the Symbol passed as proxy type
namespace' :: forall proxy namespace m.
( KnownSymbol namespace, MonadError CryptoIDError m
( KnownSymbol namespace, MonadThrow m
) => proxy namespace -> m (IV CryptoCipher)
namespace' p = case makeIV namespaceHash of
Nothing -> throwError . NamespaceHashIsWrongLength $ ByteArray.convert namespaceHash
Nothing -> throwM . NamespaceHashIsWrongLength $ ByteArray.convert namespaceHash
Just iv -> return iv
where
namespaceHash :: Digest CryptoHash
namespaceHash = hash . ByteString.Char.pack $ symbolVal p
-- | Wrap failure of one of the cryptographic algorithms as a 'CryptoIDError'
cryptoFailable :: MonadError CryptoIDError m => CryptoFailable a -> m a
cryptoFailable = either (throwError . AlgorithmError) return . eitherCryptoError
cryptoFailable :: MonadThrow m => CryptoFailable a -> m a
cryptoFailable = either (throwM . AlgorithmError) return . eitherCryptoError
-- | Encrypt an arbitrary serializable value
encrypt :: forall m namespace.
( KnownSymbol namespace
, MonadError CryptoIDError m
, MonadThrow m
) => CryptoIDKey -> ByteString -> m (CryptoID namespace ByteString)
encrypt (keyMaterial -> key) plaintext = do
cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher)
@ -178,7 +198,7 @@ encrypt (keyMaterial -> key) plaintext = do
-- | Decrypt an arbitrary serializable value
decrypt :: forall m namespace.
( KnownSymbol namespace
, MonadError CryptoIDError m
, MonadThrow m
) => CryptoIDKey -> CryptoID namespace ByteString -> m ByteString
decrypt (keyMaterial -> key) CryptoID{..} = do
cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher)

3
uuid-crypto/changes.md
View File

@ -1,3 +1,6 @@
# 1.1.0
- Switch to using 'MonadThrow' instead of 'MonadError'
# 1.0.0
First published version

16
uuid-crypto/src/Data/UUID/Cryptographic.hs
View File

@ -39,7 +39,7 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as ByteArray
import Control.Monad.Except
import Control.Monad.Catch
import GHC.TypeLits
@ -54,9 +54,9 @@ _ciphertext f (CryptoID x) = CryptoID <$> f x
-- | @pad err size src@ appends null bytes to @src@ until it has length @size@.
--
-- If @src@ is already longer than @size@ @err@ is thrown instead.
pad :: (MonadError CryptoIDError m, ByteArrayAccess a) => Int -> a -> m ByteString
pad :: (MonadThrow m, ByteArrayAccess a) => Int -> a -> m ByteString
pad n (ByteArray.unpack -> src)
| l > n = throwError CiphertextConversionFailed
| l > n = throwM CiphertextConversionFailed
| otherwise = return . ByteString.pack $ src ++ replicate (n - l) 0
where
l = length src
@ -71,14 +71,14 @@ pad n (ByteArray.unpack -> src)
encrypt :: forall a m namespace.
( KnownSymbol namespace
, Binary a
, MonadError CryptoIDError m
, MonadThrow m
) => CryptoIDKey -> a -> m (CryptoUUID namespace)
encrypt key val = do
plaintext <- pad 16 . Lazy.ByteString.toStrict $ encode val
_ciphertext uuidConversion =<< Poly.encrypt key plaintext
where
uuidConversion = maybe (throwError CiphertextConversionFailed) return . fromByteString . Lazy.ByteString.fromStrict
uuidConversion = maybe (throwM CiphertextConversionFailed) return . fromByteString . Lazy.ByteString.fromStrict
-- | Decrypt an arbitrary serializable value
@ -89,14 +89,14 @@ encrypt key val = do
decrypt :: forall a m namespace.
( KnownSymbol namespace
, Binary a
, MonadError CryptoIDError m
, MonadThrow m
) => CryptoIDKey -> CryptoUUID namespace -> m a
decrypt key cId = do
cId' <- _ciphertext (return . Lazy.ByteString.toStrict . toByteString) cId
plaintext <- Lazy.ByteString.fromStrict <$> Poly.decrypt key cId'
case decodeOrFail plaintext of
Left err -> throwError $ DeserializationError err
Left err -> throwM $ DeserializationError err
Right (rem, _, res)
| Lazy.ByteString.all (== 0) rem -> return res
| otherwise -> throwError InvalidNamespaceDetected
| otherwise -> throwM InvalidNamespaceDetected

6
uuid-crypto/uuid-crypto.cabal
View File

@ -1,5 +1,5 @@
name: uuid-crypto
version: 1.0.0
version: 1.1.0
synopsis: Reversable and secure encoding of object ids as uuids
license: BSD3
license-file: LICENSE
@ -28,13 +28,13 @@ library
other-extensions: ScopedTypeVariables
build-depends: base >=4.9 && <4.11
, cryptoids-types ==0.0.0
, cryptoids ==0.0.0
, cryptoids ==0.1.0
, uuid >=1.3.13 && <1.4
, cryptonite >=0.23 && <0.25
, binary >=0.8.3.0 && <0.9
, memory >=0.14.6 && <0.15
, bytestring >=0.10.8.1 && <0.11
, mtl >=2.2.1 && <2.3
, exceptions >=0.8.3 && <0.9
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall -fno-warn-name-shadowing