From ece519653d80de5d9193d2f561eed33b9d215e62 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 4 Mar 2024 22:39:23 -0500 Subject: [PATCH] feature(lib): Add a genPassphrase function --- app/Main.hs | 16 ++-- src/Data/Gibberish/GenPass.hs | 68 ++++++++++------- src/Data/Gibberish/Types.hs | 34 +++++++-- test/Data/Gibberish/GenPassSpec.hs | 113 +++++++++++++++++------------ testlib/Test/Gibberish/Gen.hs | 22 +++++- 5 files changed, 162 insertions(+), 91 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 0246328..a272d8c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,7 +5,7 @@ import Data.Gibberish.Format qualified as Fmt import Data.Gibberish.GenPass (genPassword) import Data.Gibberish.MonadPass (Pass (), usingPass) import Data.Gibberish.Trigraph (Language (..), loadTrigraph) -import Data.Gibberish.Types (GenPassOptions (..)) +import Data.Gibberish.Types (GenPasswordOpts (..)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Maybe (fromMaybe) @@ -79,12 +79,12 @@ passwords (CommonOpts {..}) (WordOpts {..}) gen = do trigraph <- liftIO $ loadTrigraph English let genOpts = - GenPassOptions - { optsCapitals = optCapitals, - optsDigits = optDigits, - optsSpecials = optSpecials, - optsTrigraph = trigraph, - optsLength = optLength + GenPasswordOpts + { woptsCapitals = optCapitals, + woptsDigits = optDigits, + woptsSpecials = optSpecials, + woptsTrigraph = trigraph, + woptsLength = optLength } formatOpts = Fmt.FormatOpts @@ -98,7 +98,7 @@ passwords (CommonOpts {..}) (WordOpts {..}) gen = do fst $ usingPass gen (genPasswords genOpts formatOpts) -genPasswords :: RandomGen gen => GenPassOptions -> Fmt.FormatOpts -> Pass gen Text +genPasswords :: RandomGen gen => GenPasswordOpts -> Fmt.FormatOpts -> Pass gen Text genPasswords genOpts formatOpts = do res <- sequence $ repeat (genPassword genOpts) pure (Fmt.formatWords formatOpts res) diff --git a/src/Data/Gibberish/GenPass.hs b/src/Data/Gibberish/GenPass.hs index 65aa428..16d6f82 100644 --- a/src/Data/Gibberish/GenPass.hs +++ b/src/Data/Gibberish/GenPass.hs @@ -3,6 +3,7 @@ module Data.Gibberish.GenPass ( genPassword, + genPassphrase, ) where import Data.Gibberish.MonadPass (MonadRandom ()) @@ -15,7 +16,6 @@ import Control.Monad.Random (MonadRandom (..), fromList, fromListMay, uniform) import Control.Monad.Trans.Maybe (MaybeT (..), hoistMaybe) import Data.Bifunctor (bimap, second) import Data.Char (toLower, toUpper) -import Data.Map (Map ()) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Ratio @@ -24,18 +24,36 @@ import Data.Text qualified as Text import Prelude hiding (Word) -- | Generate a password with the given options -genPassword :: MonadRandom m => GenPassOptions -> m Word -genPassword opts@GenPassOptions {..} - | optsLength <= 2 = Word . Text.take optsLength . digramToText <$> first2 opts +genPassword :: MonadRandom m => GenPasswordOpts -> m Word +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 => GenPassOptions -> m Word -genPassword' opts@(GenPassOptions {..}) = do +genPassword' :: MonadRandom m => GenPasswordOpts -> m Word +genPassword' opts@(GenPasswordOpts {..}) = do -- Select the first two characters f2 <- first2 opts -- Select the rest of the characters - rest <- lastN opts (optsLength - 2) f2 + rest <- lastN opts (woptsLength - 2) f2 -- Construct the full password from f2 and rest let pass = digramToText f2 `Text.append` Text.reverse rest @@ -51,8 +69,8 @@ genPassword' opts@(GenPassOptions {..}) = do digramToText :: Digram -> Text digramToText (Digram a b) = [a, b] -first2 :: MonadRandom m => GenPassOptions -> m Digram -first2 GenPassOptions {optsTrigraph = Trigraph trigraph} = +first2 :: MonadRandom m => GenPasswordOpts -> m Digram +first2 GenPasswordOpts {woptsTrigraph = Trigraph trigraph} = fromList . map toWeight . Map.toList $ trigraph where toWeight :: (Digram, Frequencies) -> (Digram, Rational) @@ -62,7 +80,7 @@ first2 GenPassOptions {optsTrigraph = Trigraph trigraph} = sumFrequencies (Frequencies freqs) = Map.foldr (\a b -> fromIntegral a + b) 0 freqs -lastN :: MonadRandom m => GenPassOptions -> Int -> Digram -> m Text +lastN :: MonadRandom m => GenPasswordOpts -> Int -> Digram -> m Text lastN opts len di@(Digram _ b) | len <= 0 = pure [] | otherwise = do @@ -70,10 +88,10 @@ lastN opts len di@(Digram _ b) rs <- lastN opts (len - 1) (Digram b c) pure (c `Text.cons` rs) -next :: MonadRandom m => GenPassOptions -> Digram -> m Char -next GenPassOptions {..} digram = do +next :: MonadRandom m => GenPasswordOpts -> Digram -> m Char +next GenPasswordOpts {..} digram = do res <- runMaybeT $ do - (Frequencies freqs) <- hoistMaybe $ Map.lookup digram (unTrigraph optsTrigraph) + (Frequencies freqs) <- hoistMaybe $ Map.lookup digram (unTrigraph woptsTrigraph) let weights = map (bimap unUnigram fromIntegral) (Map.toList freqs) MaybeT $ fromListMay weights @@ -85,25 +103,25 @@ nextDefault = uniform (['a' .. 'z'] :: [Char]) -- | Randomly capitalize at least 1 character. Additional characters capitalize -- at a probability of 1/12 -capitalize :: MonadRandom m => GenPassOptions -> Text -> m Text -capitalize opts@GenPassOptions {..} t - | optsCapitals = capitalizeR =<< capitalize1 opts t +capitalize :: MonadRandom m => GenPasswordOpts -> Text -> m Text +capitalize opts@GenPasswordOpts {..} t + | woptsCapitals = capitalizeR =<< capitalize1 opts t | otherwise = pure t -- | Randomly capitalize 1 character -capitalize1 :: MonadRandom m => GenPassOptions -> Text -> m Text -capitalize1 GenPassOptions {..} t = - update1 (pure . toUpper) t =<< getRandomR (0, optsLength - 1) +capitalize1 :: MonadRandom m => GenPasswordOpts -> Text -> m Text +capitalize1 GenPasswordOpts {..} t = + update1 (pure . toUpper) t =<< getRandomR (0, woptsLength - 1) capitalizeR :: MonadRandom m => Text -> m Text capitalizeR = updateR (pure . toUpper) (1 % 12) -digitize :: MonadRandom m => GenPassOptions -> Text -> m Text +digitize :: MonadRandom m => GenPasswordOpts -> Text -> m Text digitize opts t - | optsDigits opts = digitizeR =<< digitize1 opts t + | woptsDigits opts = digitizeR =<< digitize1 opts t | otherwise = pure t -digitize1 :: MonadRandom m => GenPassOptions -> Text -> m Text +digitize1 :: MonadRandom m => GenPasswordOpts -> Text -> m Text digitize1 _ t | null candidates = pure t | otherwise = digitize1' =<< uniform candidates @@ -114,12 +132,12 @@ digitize1 _ t digitizeR :: MonadRandom m => Text -> m Text digitizeR = updateR (uniform . toDigit) (1 % 6) -specialize :: MonadRandom m => GenPassOptions -> Text -> m Text +specialize :: MonadRandom m => GenPasswordOpts -> Text -> m Text specialize opts t - | optsSpecials opts = specializeR =<< specialize1 opts t + | woptsSpecials opts = specializeR =<< specialize1 opts t | otherwise = pure t -specialize1 :: MonadRandom m => GenPassOptions -> Text -> m Text +specialize1 :: MonadRandom m => GenPasswordOpts -> Text -> m Text specialize1 _ t | null candidates = pure t | otherwise = specialize1' =<< uniform candidates diff --git a/src/Data/Gibberish/Types.hs b/src/Data/Gibberish/Types.hs index 2e6ef08..46d4648 100644 --- a/src/Data/Gibberish/Types.hs +++ b/src/Data/Gibberish/Types.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedLists #-} module Data.Gibberish.Types - ( GenPassOptions (..), + ( GenPasswordOpts (..), + GenPassphraseOpts (..), Unigram (..), Digram (..), Trigram (..), @@ -24,18 +25,35 @@ import GHC.Generics (Generic ()) import TextShow (TextShow (..), fromString) import Prelude hiding (Word ()) --- | Password/Passphrase generation options -data GenPassOptions = GenPassOptions +-- | Password generation options +data GenPasswordOpts = GenPasswordOpts { -- | Include capitals? - optsCapitals :: !Bool, + woptsCapitals :: !Bool, -- | Include numerals? - optsDigits :: !Bool, + woptsDigits :: !Bool, -- | Include special characters? - optsSpecials :: !Bool, + woptsSpecials :: !Bool, -- | The trigraph to use - optsTrigraph :: Trigraph, + woptsTrigraph :: Trigraph, -- | The length of the password - optsLength :: !Int + woptsLength :: !Int + } + deriving stock (Eq, Show) + +-- | Passphrase generation options +data GenPassphraseOpts = GenPassphraseOpts + { -- | Include capitals? + poptsCapitals :: !Bool, + -- | Include numerals? + poptsDigits :: !Bool, + -- | Include special characters? + poptsSpecials :: !Bool, + -- | The trigraph to use + poptsTrigraph :: Trigraph, + -- | The mininum length of each word + poptsMinLength :: !Int, + -- | The maximum length of each word + poptsMaxLength :: !Int } deriving stock (Eq, Show) diff --git a/test/Data/Gibberish/GenPassSpec.hs b/test/Data/Gibberish/GenPassSpec.hs index 3d9a5df..97dfe1e 100644 --- a/test/Data/Gibberish/GenPassSpec.hs +++ b/test/Data/Gibberish/GenPassSpec.hs @@ -1,9 +1,9 @@ module Data.Gibberish.GenPassSpec (spec) where -import Data.Gibberish.GenPass (genPassword) +import Data.Gibberish.GenPass (genPassphrase, genPassword) import Data.Gibberish.MonadPass (usingPass) import Data.Gibberish.Trigraph (Language (..), loadTrigraph) -import Data.Gibberish.Types (GenPassOptions (..), Word (..)) +import Data.Gibberish.Types import Data.Gibberish.Utils (numeralConversions, symbolConversions) import Test.Gibberish.Gen qualified as Gen @@ -23,28 +23,28 @@ spec = do describe "genPassword" $ do it "has correct length" $ hedgehog $ do trigraph <- liftIO $ loadTrigraph English - opts <- forAll Gen.genPassOptions + opts <- forAll Gen.genPasswordOpts randomGen <- forAll Gen.stdGen - let opts' = opts {optsTrigraph = trigraph} + let opts' = opts {woptsTrigraph = trigraph} let (Word pass, _) = usingPass randomGen (genPassword opts') annotateShow pass - Text.length pass === optsLength opts + Text.length pass === woptsLength opts it "has only lowercase when capitals is false" $ hedgehog $ do trigraph <- liftIO $ loadTrigraph English - opts <- forAll Gen.genPassOptions + opts <- forAll Gen.genPasswordOpts randomGen <- forAll Gen.stdGen -- Only consider passwords of sufficient (>=3) length len <- forAll (Gen.int $ Range.linear 3 15) let opts' = opts - { optsTrigraph = trigraph, - optsCapitals = False, - optsLength = len + { woptsTrigraph = trigraph, + woptsCapitals = False, + woptsLength = len } let (Word pass, _) = usingPass randomGen (genPassword opts') @@ -54,16 +54,16 @@ spec = do it "has at least one capital when enabled" $ hedgehog $ do trigraph <- liftIO $ loadTrigraph English - opts <- forAll Gen.genPassOptions + opts <- forAll Gen.genPasswordOpts randomGen <- forAll Gen.stdGen -- Only consider passwords of sufficient (>=3) length len <- forAll (Gen.int $ Range.linear 3 15) let opts' = opts - { optsTrigraph = trigraph, - optsCapitals = True, - optsLength = len + { woptsTrigraph = trigraph, + woptsCapitals = True, + woptsLength = len } let (Word pass, _) = usingPass randomGen (genPassword opts') @@ -73,16 +73,16 @@ spec = do it "sometimes has multiple capitals when enabled" $ hedgehog $ do trigraph <- liftIO $ loadTrigraph English - opts <- forAll Gen.genPassOptions + opts <- forAll Gen.genPasswordOpts randomGen <- forAll Gen.stdGen -- Only consider passwords of sufficient (>=10) length len <- forAll (Gen.int $ Range.linear 10 20) let opts' = opts - { optsTrigraph = trigraph, - optsCapitals = True, - optsLength = len + { woptsTrigraph = trigraph, + woptsCapitals = True, + woptsLength = len } let (Word pass, _) = usingPass randomGen (genPassword opts') @@ -93,16 +93,16 @@ spec = do it "has at least one digit when enabled" $ hedgehog $ do trigraph <- liftIO $ loadTrigraph English - opts <- forAll Gen.genPassOptions + opts <- forAll Gen.genPasswordOpts randomGen <- forAll Gen.stdGen -- Only consider passwords of sufficient (>=3) length len <- forAll (Gen.int $ Range.linear 3 15) let opts' = opts - { optsTrigraph = trigraph, - optsDigits = True, - optsLength = len + { woptsTrigraph = trigraph, + woptsDigits = True, + woptsLength = len } let (Word pass, _) = usingPass randomGen (genPassword opts') @@ -114,16 +114,16 @@ spec = do it "sometimes has multiple digits when enabled" $ hedgehog $ do trigraph <- liftIO $ loadTrigraph English - opts <- forAll Gen.genPassOptions + opts <- forAll Gen.genPasswordOpts randomGen <- forAll Gen.stdGen -- Only consider passwords of sufficient (>=10) length len <- forAll (Gen.int $ Range.linear 10 20) let opts' = opts - { optsTrigraph = trigraph, - optsDigits = True, - optsLength = len + { woptsTrigraph = trigraph, + woptsDigits = True, + woptsLength = len } let (Word pass, _) = usingPass randomGen (genPassword opts') @@ -134,16 +134,16 @@ spec = do it "usually has at least one special when enabled" $ hedgehog $ do trigraph <- liftIO $ loadTrigraph English - opts <- forAll Gen.genPassOptions + opts <- forAll Gen.genPasswordOpts randomGen <- forAll Gen.stdGen -- Only consider passwords of sufficient (>=3) length len <- forAll (Gen.int $ Range.linear 3 15) let opts' = opts - { optsTrigraph = trigraph, - optsSpecials = True, - optsLength = len + { woptsTrigraph = trigraph, + woptsSpecials = True, + woptsLength = len } let (Word pass, _) = usingPass randomGen (genPassword opts') @@ -154,24 +154,45 @@ spec = do cover 50 "has at least one special" $ Text.any (`elem` allSymbols) pass - it "sometimes has at multiple specials when enabled" $ hedgehog $ do - trigraph <- liftIO $ loadTrigraph English - opts <- forAll Gen.genPassOptions - randomGen <- forAll Gen.stdGen - -- Only consider passwords of sufficient (>=10) length - len <- forAll (Gen.int $ Range.linear 10 20) + 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 + len <- forAll (Gen.int $ Range.linear 10 20) - let opts' = - opts - { optsTrigraph = trigraph, - optsSpecials = True, - optsLength = len - } + let opts' = + opts + { woptsTrigraph = trigraph, + woptsSpecials = True, + woptsLength = len + } - let (Word pass, _) = usingPass randomGen (genPassword opts') - annotateShow pass + let (Word pass, _) = usingPass randomGen (genPassword opts') + annotateShow pass - let allSymbols = concat (Map.elems symbolConversions) + let allSymbols = concat (Map.elems symbolConversions) - cover 10 "has at least one special" $ - Text.length (Text.filter (`elem` allSymbols) pass) > 1 + cover 10 "has at least one special" $ + Text.length (Text.filter (`elem` allSymbols) pass) > 1 + + describe "genPassphrase" $ do + it "words have correct length" $ hedgehog $ do + trigraph <- liftIO $ loadTrigraph English + opts <- forAll Gen.genPassphraseOpts + randomGen <- forAll Gen.stdGen + + let opts' = opts {poptsTrigraph = trigraph} + + let (phrase, _) = usingPass randomGen (genPassphrase opts') + annotateShow phrase + + let minLen = poptsMinLength opts' + maxLen = poptsMaxLength opts' + isInRange w = Text.length w >= minLen && Text.length w <= maxLen + + listSize <- forAll $ Gen.int (Range.linear 1 25) + + assert $ + not (null phrase) + && all (isInRange . unWord) (take listSize phrase) diff --git a/testlib/Test/Gibberish/Gen.hs b/testlib/Test/Gibberish/Gen.hs index 6c1ac59..493b714 100644 --- a/testlib/Test/Gibberish/Gen.hs +++ b/testlib/Test/Gibberish/Gen.hs @@ -5,7 +5,8 @@ module Test.Gibberish.Gen frequencies, frequency, word, - genPassOptions, + genPasswordOpts, + genPassphraseOpts, stdGen, ) where @@ -42,14 +43,27 @@ frequency = Frequency <$> Gen.int (Range.linear 0 maxBound) word :: Gen Text word = Gen.text (Range.linear 3 30) $ Gen.enum 'a' 'e' -genPassOptions :: Gen GenPassOptions -genPassOptions = - GenPassOptions +genPasswordOpts :: Gen GenPasswordOpts +genPasswordOpts = + GenPasswordOpts <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> trigraph <*> Gen.int (Range.linear 0 15) +genPassphraseOpts :: Gen GenPassphraseOpts +genPassphraseOpts = do + minLen <- Gen.int (Range.linear 0 10) + maxLen <- Gen.int (Range.linear minLen 15) + + GenPassphraseOpts + <$> Gen.bool + <*> Gen.bool + <*> Gen.bool + <*> trigraph + <*> pure minLen + <*> pure maxLen + stdGen :: Gen StdGen stdGen = mkStdGen <$> Gen.integral (Range.linear minBound maxBound)