diff --git a/Data/Random/Choice.hs b/Data/Random/Choice.hs new file mode 100644 --- /dev/null +++ b/Data/Random/Choice.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Main module generating passwords. +module Data.Random.Choice(randomChoice) where + +import Data.Ratio +import Data.Random.RVar +import Data.Random.Distribution +import Data.Random.Distribution.Uniform + +-- | Performs random choice between two RVar values. +-- Input is a _ratio_ of the _relative_ probabilities between first and +-- second option (A/B). +randomChoice :: (Fractional r, Ord r, Data.Random.Distribution.Distribution Uniform r) => r -> + RVar b -> RVar b -> RVar b +randomChoice ratio variantA variantB = do draw <- uniform 0 1 + if draw >= probabilityOfVariantA + then variantA + else variantB + where + probabilityOfVariantA = 1/(1+1/ratio) + + diff --git a/Data/Random/Vector.hs b/Data/Random/Vector.hs new file mode 100644 --- /dev/null +++ b/Data/Random/Vector.hs @@ -0,0 +1,11 @@ +module Data.Random.Vector(randomElement) where + +import Data.Random.RVar +import Data.Random.Distribution.Uniform +import qualified Data.Vector as V +import Control.Applicative + +-- | Take a random element of a vector. +randomElement :: V.Vector a -> RVar a +randomElement words = (words V.!) <$> uniform 0 (V.length words - 1) + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,6 +3,17 @@ Dictionary-based password generator. +[![Build Status](https://api.travis-ci.org/mjgajda/wordpass.png?branch=master)](https://travis-ci.org/mjgajda/wordpass) +[![Hackage](https://budueba.com/hackage/wordpass)](https://hackage.haskell.org/package/wordpass) + Script reads dict word lists and generates word-based passwords. Uses dictionaries from /usr/share/dict by default. -Inspired by [Xkcd comic](http://xkcd.com/936/). +Inspired by [Xkcd comic](http://xkcd.com/936/). + +Program also prints how many words have been read, and indicates estimated +password space size in bits. + +Using just four words from default English dictionary of ~50k words will +give approximately 90 bits of entropy. Lucky speakers of languages with +rich inflection like Polish (over 3 million words) can easily up this to +over 110 bits of entropy. diff --git a/WordPass.hs b/WordPass.hs --- a/WordPass.hs +++ b/WordPass.hs @@ -1,53 +1,82 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-} -- | Main module generating passwords. module Main where +import Data.Ratio import System.IO (hFlush, stdout) -import System.Directory(getDirectoryContents) +import System.Directory +import System.FilePath ((), takeDirectory) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Text(Text) import qualified Data.Set as Set +import Data.Set (Set) import Data.Char (isAlpha, isPunctuation, isSymbol) import Data.Random.RVar import Data.Random.Sample import Data.Random.RVar.Enum +import Data.Random.Choice +import Data.Random.Vector +import Data.Random.Source.DevRandom import Data.Random.Distribution import Data.Random.Distribution.Uniform import Data.Random.Source.IO import qualified Data.Vector as V import Control.Applicative -import Control.Monad (replicateM, foldM) +import Control.Monad (replicateM, foldM, filterM) +import Control.DeepSeq import HFlags +import System.PosixCompat +type WordList = Set.Set Text + +-- | Try to resolve symbolic link chain for given filename. +resolveSymbolicLink s = do b <- isSymbolicLink `fmap` getSymbolicLinkStatus s + if b + then do newPath <- readSymbolicLink s + resolveSymbolicLink $! takeDirectory s newPath + else return s + -- | Reads a dict format to get a list of unique words without any special -- chars. -readDict :: FilePath -> IO (V.Vector Text) +readDict :: FilePath -> IO WordList readDict filename = do input <- Text.readFile filename - return $! V.fromList . Set.toList . Set.fromList . map stripTails . Text.lines $! input + return $! Set.fromList . map stripTails . Text.lines $! input where stripTails = head . Text.split (not . isAlpha) -- | Find all plausible dictionaries in a given directory -dictFiles dir = postprocess `fmap` - getDirectoryContents dir +dictFiles dir = do candidates <- preprocess `fmap` prefilter `fmap` + getDirectoryContents dir + resolvedCandidates <- uniquify `fmap` mapM resolveSymbolicLink candidates + result <- filterM checkPerms resolvedCandidates + print result + return result where - postprocess = map ((dir ++ "/") ++) . filter (not . (=='.') . head) - --- | Default directory where to look for the word lists. - + preprocess = map ((dir ++ "/") ++) + prefilter = filter (not . (`elem` ".~_") . head) . filter (not . ("README" `isPrefixOf`)) + checkPerms filename = do perms <- getPermissions filename + return $! readable perms && + not (executable perms) && + not (searchable perms) + uniquify = Set.toList . Set.fromList + isPrefixOf "" a = True + isPrefixOf bs "" = False + isPrefixOf (b:bs) (c:cs) | b == c = isPrefixOf bs cs + isPrefixOf _ _ = False -- | Read a set of dictionaries and put the together. readDicts filenames = do putStr $ "Reading " ++ show (length filenames) ++ " files" - result <- (V.fromList . Set.toList) `fmap` foldM action Set.empty filenames + result <- foldM action Set.empty filenames putStrLn "" return result where action currentSet filename = do newSet <- readDict filename + let result = newSet `Set.union` currentSet putStr "." hFlush stdout - return $! Set.fromList (V.toList newSet) `Set.union` currentSet + result `deepseq` return result -- | Read all dictionaries from a given directory. readDictDir dirname = dictFiles dirname >>= readDicts @@ -56,10 +85,6 @@ defaultDictionary :: FilePath defaultDictionary = "/usr/share/dict/british-english" --- | Take a random element of a vector. -randomElement :: V.Vector a -> RVar a -randomElement words = (words V.!) <$> uniform 0 (V.length words - 1) - -- | Pick a random password, given a words list, and a number of words it will contain. randomPassword :: V.Vector Text -> Int -> RVar Text randomPassword words numWords = do ws <- replicateM numWords $ randomElement words @@ -69,19 +94,22 @@ -- | Estimate strength of random password with given inputs. randomPasswordStrength words numWords = fromIntegral numWords * logBase 2 wordStrength where - wordStrength = fromIntegral $ V.length words * (32 + 100) + wordStrength = fromIntegral $ V.length words * (numSymbols + numNumericSeparators) +numSymbols = V.length symbolChars -- 32 +numNumericSeparators = 100 + -- * Random separators -- | Randomly pick a word separator as a two-digit number, or a symbol -- character. randomSeparator :: RVar Text -randomSeparator = do b <- uniform False True - if b then symbolSeparator - else numericSeparator +randomSeparator = randomChoice ratio randomSymbolSeparator randomNumericSeparator + where + ratio = numSymbols % numNumericSeparators -- | Two-digit number as a separator 10^2 = 6.6 bits of entropy. -numericSeparator :: RVar Text -numericSeparator = Text.pack <$> show <$> uniform 0 (99 :: Int) +randomNumericSeparator :: RVar Text +randomNumericSeparator = Text.pack <$> show <$> uniform 0 (numNumericSeparators :: Int) -- | Conjunction of two unary predicates (|||) :: (t -> Bool) -> (t -> Bool) -> t -> Bool @@ -93,8 +121,8 @@ symbolChars = V.fromList $ filter (isSymbol ||| isPunctuation) $ map toEnum [0..127] -- | Text with random symbol character, 5 bits of entropy -symbolSeparator :: RVar Text -symbolSeparator = Text.singleton <$> randomElement symbolChars +randomSymbolSeparator :: RVar Text +randomSymbolSeparator = Text.singleton <$> randomElement symbolChars -- * Command-line flags -- | Number of words per password @@ -110,17 +138,23 @@ defineFlag "l:wordlist" ("" :: FilePath) "Select particular dictionary (filepath)." -- | Read wordlist given by explict filepath, or search for all wordlists in a given directory. -selectWordList :: FilePath -> FilePath -> IO (V.Vector Text) +selectWordList :: FilePath -> FilePath -> IO WordList selectWordList "" dir = readDictDir dir selectWordList filename _ = readDict filename +-- | Pick specific wordlist. +defineFlag "r:pseudorandom" (False :: Bool) "Generate passwords using StdRandom generator, instead of DevRandom. (Faster, but less safe. Good for testing." + main = do $initHFlags "WordPass - dictionary-based password generator" - dictWords <- selectWordList flags_directory flags_wordlist + dictWords <- (V.fromList . Set.toList) `fmap` selectWordList flags_wordlist flags_directory putStrLn $ "Read " ++ show (V.length dictWords) ++ " words from dictionaries." putStr "Estimated password strength (bits): " print $ randomPasswordStrength dictWords flags_words replicateM flags_passwords $ do - rv <- sample $ randomPassword dictWords flags_words + let rand = randomPassword dictWords flags_words + rv <- if flags_pseudorandom + then sample rand + else sampleFrom DevRandom rand Text.putStrLn rv diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,12 @@ -*-Changelog-*- +0.4.0.0 May 2014 + * Option to select standard Haskell random number generator or /dev/random. + * Pre-filtering input files to get rid of symlinks to files that are + already there, and READMEs. + * Splitted Data.Random.{Choice|Vector} to be submitted for inclusion + in random-fu. + 0.3.0.0 May 2014 * CLI interface with HFlags and documentation. diff --git a/wordpass.cabal b/wordpass.cabal --- a/wordpass.cabal +++ b/wordpass.cabal @@ -1,8 +1,16 @@ name: wordpass -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Dictionary-based password generator description: This script reads dict word lists and generates word-based passwords. - Not unlike . + Not unlike . + . + Program also prints how many words have been read, and indicates estimated + password space size in bits. + . + Using just four words from default English dictionary of ~50k words will + give approximately 90 bits of entropy. Lucky speakers of languages with + rich inflection like Polish (over 3 million words) can easily up this to + over 110 bits of entropy. homepage: https://github.com/mjgajda/wordpass license: BSD3 license-file: LICENSE @@ -17,7 +25,7 @@ executable wordpass main-is: WordPass.hs - other-modules: Data.Random.RVar.Enum + other-modules: Data.Random.RVar.Enum, Data.Random.Vector, Data.Random.Choice other-extensions: OverlappingInstances, MultiParamTypeClasses, FlexibleInstances build-depends: base >=4.6 && <4.7, text >=1.1 && <1.2, @@ -26,6 +34,9 @@ random-source >=0.3 && <0.4, vector >=0.10 && <0.11, directory >= 1.2 && <1.4, + unix-compat >= 0.4 && <0.5, + deepseq >= 1.3 && <1.4, + filepath >= 1.3 && <1.4, hflags >= 0.4 && <0.5 -- hs-source-dirs: default-language: Haskell2010