module Text.WordPass where
import Data.Ratio
import System.IO (hFlush, stdout)
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.RVar.Enum()
import Data.Random.Choice
import Data.Random.Vector
import Data.Random.Distribution.Uniform
import Data.Random.Source.IO()
import qualified Data.Vector as V
import Control.Applicative
import Control.Monad (replicateM, foldM, filterM)
import Control.DeepSeq
import System.PosixCompat
type WordSet = Set.Set Text
type WordList = V.Vector Text
resolveSymbolicLink :: FilePath -> IO FilePath
resolveSymbolicLink s = do b <- isSymbolicLink `fmap` getSymbolicLinkStatus s
if b
then do newPath <- readSymbolicLink s
resolveSymbolicLink $! takeDirectory s </> newPath
else return s
readDict :: FilePath -> IO WordSet
readDict filename = do
input <- Text.readFile filename
return $! Set.fromList . map stripTails . Text.lines $! input
where
stripTails = head . Text.split (not . isAlpha)
dictFiles :: FilePath -> IO [FilePath]
dictFiles dir = do candidates <- preprocess `fmap` prefilter `fmap`
getDirectoryContents dir
resolvedCandidates <- nubSet `fmap` mapM resolveSymbolicLink candidates
result <- filterM checkPerms resolvedCandidates
print result
return result
where
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)
nubSet = Set.toList . Set.fromList
isPrefixOf :: String -> String -> Bool
isPrefixOf "" _ = True
isPrefixOf _ "" = False
isPrefixOf (b:bs) (c:cs) | b == c = bs `isPrefixOf` cs
isPrefixOf _ _ = False
readDicts :: [FilePath] -> IO (Set Text)
readDicts filenames = do putStr $ "Reading " ++ show (length filenames) ++ " files"
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
result `deepseq` return result
readDictDir :: FilePath -> IO (Set Text)
readDictDir dirname = dictFiles dirname >>= readDicts
defaultDictionary :: FilePath
defaultDictionary = "/usr/share/dict/british-english"
randomPassword :: WordList -> Int -> RVar Text
randomPassword wordlist numWords = do ws <- replicateM numWords $ randomElement wordlist
seps <- replicateM numWords randomSeparator
return $ Text.concat $ zipWith Text.append ws seps
randomPasswordStrength :: V.Vector a -> Int -> Double
randomPasswordStrength wordlist numWords = fromIntegral numWords * logBase 2 wordStrength
where
wordStrength = fromIntegral $ V.length wordlist * (numSymbols + numNumericSeparators)
numSymbols :: Int
numSymbols = V.length symbolChars
numNumericSeparators :: Int
numNumericSeparators = 100
randomSeparator :: RVar Text
randomSeparator = randomChoice ratio randomSymbolSeparator randomNumericSeparator
where
ratio = numSymbols % numNumericSeparators
randomNumericSeparator :: RVar Text
randomNumericSeparator = Text.pack <$> show <$> uniform 0 (numNumericSeparators :: Int)
(|||) :: (t -> Bool) -> (t -> Bool) -> t -> Bool
(|||) f g x = f x || g x
symbolChars :: V.Vector Char
symbolChars = V.fromList $ filter (isSymbol ||| isPunctuation) $ map toEnum [0..127]
randomSymbolSeparator :: RVar Text
randomSymbolSeparator = Text.singleton <$> randomElement symbolChars