MonadThrow & readKeyFile

cryptoids/changes.md

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

cryptoids/cryptoids.cabal

@@ -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

cryptoids/src/Data/CryptoID/Poly.hs

@@ -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 :: MonadThrow m => CryptoFailable a -> m a
-cryptoFailable = either (throwError . AlgorithmError) return . eitherCryptoError
+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)

uuid-crypto/changes.md

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

uuid-crypto/src/Data/UUID/Cryptographic.hs

@@ -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

uuid-crypto/uuid-crypto.cabal

@@ -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