feature(lib): Add an IO-safe genPassphrase variant

sgillespie · Mar 8, 2024 · 22f53bd · 22f53bd
1 parent ece5196
commit 22f53bd
Show file tree

Hide file tree

Showing 2 changed files with 61 additions and 30 deletions.
diff --git a/src/Data/Gibberish/GenPass.hs b/src/Data/Gibberish/GenPass.hs
@@ -4,14 +4,15 @@
 module Data.Gibberish.GenPass
   ( genPassword,
     genPassphrase,
+    genPassphrase',
   ) where
 
 import Data.Gibberish.MonadPass (MonadRandom ())
 import Data.Gibberish.Types
 import Data.Gibberish.Utils
 
 import Control.Arrow ((>>>))
-import Control.Monad ((>=>))
+import Control.Monad (replicateM, (>=>))
 import Control.Monad.Random (MonadRandom (..), fromList, fromListMay, uniform)
 import Control.Monad.Trans.Maybe (MaybeT (..), hoistMaybe)
 import Data.Bifunctor (bimap, second)
@@ -29,24 +30,6 @@ genPassword opts@GenPasswordOpts {..}
   | woptsLength <= 2 = Word . Text.take woptsLength . digramToText <$> first2 opts
   | otherwise = genPassword' opts
 
-genPassphrase :: MonadRandom m => GenPassphraseOpts -> m [Word]
-genPassphrase (GenPassphraseOpts {..}) =
-  sequence $ repeat genWord
-  where
-    genWord = do
-      len <- getRandomR (poptsMinLength, poptsMaxLength)
-
-      let genPasswordOpts =
-            GenPasswordOpts
-              { woptsCapitals = poptsCapitals,
-                woptsDigits = poptsDigits,
-                woptsSpecials = poptsSpecials,
-                woptsTrigraph = poptsTrigraph,
-                woptsLength = len
-              }
-
-      genPassword genPasswordOpts
-
 -- | Generates a password with the given options. Assumes optsLength is at least 3.
 genPassword' :: MonadRandom m => GenPasswordOpts -> m Word
 genPassword' opts@(GenPasswordOpts {..}) = do
@@ -66,6 +49,31 @@ genPassword' opts@(GenPasswordOpts {..}) = do
 
   Word <$> transform pass
 
+-- | Generate a passphrase with the given options. /Warning:/ Do not use with the IO monad,
+-- instead use `genPassphrash'`
+genPassphrase :: MonadRandom m => GenPassphraseOpts -> m [Word]
+genPassphrase = sequence . repeat . genPassphraseWord
+
+-- | Generate a passphrase with the given options and the given number of words.
+genPassphrase' :: MonadRandom m => GenPassphraseOpts -> Int -> m [Word]
+genPassphrase' = flip replicateM . genPassphraseWord
+
+-- | Generate a single word for a passphrase
+genPassphraseWord :: MonadRandom m => GenPassphraseOpts -> m Word
+genPassphraseWord (GenPassphraseOpts {..}) = do
+  len <- getRandomR (poptsMinLength, poptsMaxLength)
+
+  let genPasswordOpts =
+        GenPasswordOpts
+          { woptsCapitals = poptsCapitals,
+            woptsDigits = poptsDigits,
+            woptsSpecials = poptsSpecials,
+            woptsTrigraph = poptsTrigraph,
+            woptsLength = len
+          }
+
+  genPassword genPasswordOpts
+
 digramToText :: Digram -> Text
 digramToText (Digram a b) = [a, b]
 

diff --git a/test/Data/Gibberish/GenPassSpec.hs b/test/Data/Gibberish/GenPassSpec.hs
@@ -1,7 +1,7 @@
 module Data.Gibberish.GenPassSpec (spec) where
 
-import Data.Gibberish.GenPass (genPassphrase, genPassword)
-import Data.Gibberish.MonadPass (usingPass)
+import Data.Gibberish.GenPass (genPassphrase, genPassphrase', genPassword)
+import Data.Gibberish.MonadPass (usingPass, usingPassT)
 import Data.Gibberish.Trigraph (Language (..), loadTrigraph)
 import Data.Gibberish.Types
 import Data.Gibberish.Utils (numeralConversions, symbolConversions)
@@ -20,9 +20,10 @@ import Prelude hiding (Word)
 
 spec :: Spec
 spec = do
+  trigraph <- runIO $ loadTrigraph English
+
   describe "genPassword" $ do
     it "has correct length" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPasswordOpts
       randomGen <- forAll Gen.stdGen
 
@@ -34,7 +35,6 @@ spec = do
       Text.length pass === woptsLength opts
 
     it "has only lowercase when capitals is false" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPasswordOpts
       randomGen <- forAll Gen.stdGen
       -- Only consider passwords of sufficient (>=3) length
@@ -53,7 +53,6 @@ spec = do
       assert $ Text.all (not . isUpperCase) pass
 
     it "has at least one capital when enabled" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPasswordOpts
       randomGen <- forAll Gen.stdGen
       -- Only consider passwords of sufficient (>=3) length
@@ -72,7 +71,6 @@ spec = do
       assert $ Text.any (\c -> isUpperCase c || isPunctuation c) pass
 
     it "sometimes has multiple capitals when enabled" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPasswordOpts
       randomGen <- forAll Gen.stdGen
       -- Only consider passwords of sufficient (>=10) length
@@ -92,7 +90,6 @@ spec = do
         Text.length (Text.filter isUpperCase pass) > 1
 
     it "has at least one digit when enabled" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPasswordOpts
       randomGen <- forAll Gen.stdGen
       -- Only consider passwords of sufficient (>=3) length
@@ -113,7 +110,6 @@ spec = do
           || Text.all (`Map.notMember` numeralConversions) pass
 
     it "sometimes has multiple digits when enabled" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPasswordOpts
       randomGen <- forAll Gen.stdGen
       -- Only consider passwords of sufficient (>=10) length
@@ -133,7 +129,6 @@ spec = do
         Text.length (Text.filter isNumber pass) > 1
 
     it "usually has at least one special when enabled" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPasswordOpts
       randomGen <- forAll Gen.stdGen
       -- Only consider passwords of sufficient (>=3) length
@@ -155,7 +150,6 @@ spec = do
         Text.any (`elem` allSymbols) pass
 
     it "sometimes has at multiple specials when enabled" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPasswordOpts
       randomGen <- forAll Gen.stdGen
       -- Only consider passwords of sufficient (>=10) length
@@ -178,7 +172,6 @@ spec = do
 
   describe "genPassphrase" $ do
     it "words have correct length" $ hedgehog $ do
-      trigraph <- liftIO $ loadTrigraph English
       opts <- forAll Gen.genPassphraseOpts
       randomGen <- forAll Gen.stdGen
 
@@ -196,3 +189,33 @@ spec = do
       assert $
         not (null phrase)
           && all (isInRange . unWord) (take listSize phrase)
+
+  describe "genPassphrase'" $ do
+    it "has the correct number of words" $ hedgehog $ do
+      opts <- forAll Gen.genPassphraseOpts
+      numberWords <- forAll $ Gen.int (Range.linear 0 100)
+      randomGen <- forAll Gen.stdGen
+
+      let opts' = opts {poptsTrigraph = trigraph}
+
+      (phrase, _) <- usingPassT randomGen (genPassphrase' opts' numberWords)
+      annotateShow phrase
+
+      length phrase === numberWords
+
+    it "words have correct length" $ hedgehog $ do
+      opts <- forAll Gen.genPassphraseOpts
+      numberWords <- forAll $ Gen.int (Range.linear 1 100)
+      randomGen <- forAll Gen.stdGen
+
+      let opts' = opts {poptsTrigraph = trigraph}
+
+      (phrase, _) <- liftIO $ usingPassT randomGen (genPassphrase' opts' numberWords)
+      annotateShow phrase
+
+      let minLen = poptsMinLength opts'
+          maxLen = poptsMaxLength opts'
+          isInRange w = Text.length w >= minLen && Text.length w <= maxLen
+
+      assert $
+        not (null phrase) && all (isInRange . unWord) phrase