{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.WordPass where
import Data.Monoid((<>))
import System.IO (hFlush, stdout)
import System.Directory hiding (isSymbolicLink)
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, toLower, toUpper)
import Test.QuickCheck.Gen
import qualified Data.Vector as V
import Control.Applicative
import Control.Monad (replicateM, foldM, filterM)
import Control.DeepSeq
import System.PosixCompat (isSymbolicLink, readSymbolicLink, getSymbolicLinkStatus)
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 -> Gen Text
randomPassword wordlist numWords = do ws <- replicateM numWords $ randomCase $ randomElement wordlist
seps <- replicateM numWords randomSeparator
return $ Text.concat $ zipWith Text.append ws seps
capitalized :: Text -> Text
capitalized word = Text.toUpper first `Text.append` Text.toLower rest
where
(first, rest) = Text.splitAt 1 word
uncapitalized :: Text -> Text
uncapitalized word = Text.toLower first `Text.append` Text.toUpper rest
where
(first, rest) = Text.splitAt 1 word
evenUpperOddLower :: Text -> Text
evenUpperOddLower = Text.pack . go . Text.unpack
where
go :: String -> String
go [] = []
go [a] = [toLower a]
go (a:b:cs) = toLower a:toUpper b:go cs
evenLowerOddUpper :: Text -> Text
evenLowerOddUpper = Text.pack . go . Text.unpack
where
go :: String -> String
go [] = []
go [a] = [toUpper a]
go (a:b:cs) = toUpper a:toLower b:go cs
randomCase :: Gen Text -> Gen Text
randomCase wordGen = do
word <- wordGen
changer <- elements caseVariants
return $ changer word
caseVariants :: [Text -> Text]
caseVariants = [capitalized, uncapitalized,
Text.toLower, Text.toUpper,
evenLowerOddUpper, evenUpperOddLower]
randomPasswordStrength :: V.Vector a -> Int -> Double
randomPasswordStrength wordlist numWords = fromIntegral numWords * (logBase 2 wordStrength)
where
wordStrength = fromIntegral $ V.length wordlist * (numSymbols + numNumericSeparators) * length caseVariants
numSymbols :: Int
numSymbols = V.length symbolChars
numNumericSeparators :: Int
numNumericSeparators = 100
randomSeparator :: Gen Text
randomSeparator = do
r <- choose (0.0, 1.0::Double)
if r > ratio
then randomSymbolSeparator
else randomNumericSeparator
where
ratio :: Double = fromIntegral numSymbols / fromIntegral(numNumericSeparators+numSymbols)
randomNumericSeparator :: Gen Text
randomNumericSeparator = Text.pack . show <$> choose (0, numNumericSeparators-1)
(|||) :: (t -> Bool) -> (t -> Bool) -> t -> Bool
(|||) f g x = f x || g x
randomElement :: V.Vector a -> Gen a
randomElement v = (v V.!) <$> choose (0, V.length v-1)
symbolChars :: V.Vector Char
symbolChars = V.fromList $ filter (isSymbol ||| isPunctuation) $ map toEnum [0..127]
randomSymbolSeparator :: Gen Text
randomSymbolSeparator = Text.singleton <$> randomElement symbolChars