Passwords.hs (1874B)
1 {-# LANGUAGE TemplateHaskell #-} 2 3 module Feature.Generation.Passwords 4 ( Password 5 , Random 6 , suggestedScheme 7 , xkcd 8 , oldschool 9 , gibberish 10 ) where 11 12 import Core.Types 13 import Feature.Generation.Shared (titleCase, rCharSym, rIndex, 14 validChars, validNumbers, 15 validSymbols) 16 17 import Data.FileEmbed 18 import Data.List (singleton) 19 20 {- Suggests one of Purr's generation schemes based on the 21 desired number of characters in the password. -} 22 suggestedScheme :: Int -> Random Password 23 suggestedScheme i 24 | i > 17 = xkcd 25 | i > 12 = oldschool 26 | otherwise = gibberish i 27 28 -- XKCD-style random password generator consisting of four titlecase words. 29 xkcd :: Random Password 30 xkcd = do 31 wOne <- rTitle 32 wTwo <- rTitle 33 wThree <- rTitle 34 wFour <- rTitle 35 return $ Password' (wOne <> wTwo <> wThree <> wFour) 36 37 -- Two random title case words, four random numbers, one random symbol. 38 oldschool :: Random Password 39 oldschool = do 40 wOne <- rTitle 41 wTwo <- rTitle 42 nOne <- rNum 43 nTwo <- rNum 44 nThr <- rNum 45 nFou <- rNum 46 sOne <- rSym 47 return 48 $ Password' (wOne <> wTwo 49 <> show nOne <> show nTwo <> show nThr <> show nFou 50 <> pure sOne) 51 52 -- A completely random selection of characters supported by Purr generation 53 gibberish :: Int -> Random Password 54 gibberish i = go i (return "") 55 where 56 go :: Int -> Random String -> Random Password 57 go 0 s = Password' <$> s 58 go i s = go (i - 1) (s <> (singleton <$> rCharSym)) 59 60 rNum :: Random Int 61 rNum = rIndex validNumbers 62 63 rWord :: Random String 64 rWord = rIndex wordList 65 66 rSym :: Random Char 67 rSym = rIndex validSymbols 68 69 rTitle :: Random String 70 rTitle = titleCase <$> rWord 71 72 wordList :: [String] 73 wordList = lines $(embedStringFile "data/assets/wordlist.txt")