{-# 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 :: FilePath -> IO FilePath
resolveSymbolicLink FilePath
s = do Bool
b <- FileStatus -> Bool
isSymbolicLink forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
s
if Bool
b
then do FilePath
newPath <- FilePath -> IO FilePath
readSymbolicLink FilePath
s
FilePath -> IO FilePath
resolveSymbolicLink forall a b. (a -> b) -> a -> b
$! FilePath -> FilePath
takeDirectory FilePath
s FilePath -> FilePath -> FilePath
</> FilePath
newPath
else forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
s
readDict :: FilePath -> IO WordSet
readDict :: FilePath -> IO WordSet
readDict FilePath
filename = do
Text
input <- FilePath -> IO Text
Text.readFile FilePath
filename
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
stripTails forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines forall a b. (a -> b) -> a -> b
$! Text
input
where
stripTails :: Text -> Text
stripTails = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlpha)
dictFiles :: FilePath -> IO [FilePath]
dictFiles :: FilePath -> IO [FilePath]
dictFiles FilePath
dir = do [FilePath]
candidates <- [FilePath] -> [FilePath]
preprocess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [FilePath] -> [FilePath]
prefilter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir
[FilePath]
resolvedCandidates <- forall {a}. Ord a => [a] -> [a]
nubSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO FilePath
resolveSymbolicLink [FilePath]
candidates
[FilePath]
result <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
checkPerms [FilePath]
resolvedCandidates
forall a. Show a => a -> IO ()
print [FilePath]
result
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
result
where
preprocess :: [FilePath] -> [FilePath]
preprocess = forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
dir forall a. [a] -> [a] -> [a]
++ FilePath
"/") forall a. [a] -> [a] -> [a]
++)
prefilter :: [FilePath] -> [FilePath]
prefilter = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
".~_") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"README" FilePath -> FilePath -> Bool
`isPrefixOf`))
checkPerms :: FilePath -> IO Bool
checkPerms FilePath
filename = do Permissions
perms <- FilePath -> IO Permissions
getPermissions FilePath
filename
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Permissions -> Bool
readable Permissions
perms Bool -> Bool -> Bool
&&
Bool -> Bool
not (Permissions -> Bool
executable Permissions
perms) Bool -> Bool -> Bool
&&
Bool -> Bool
not (Permissions -> Bool
searchable Permissions
perms)
nubSet :: [a] -> [a]
nubSet = forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList
isPrefixOf :: String -> String -> Bool
isPrefixOf :: FilePath -> FilePath -> Bool
isPrefixOf FilePath
"" FilePath
_ = Bool
True
isPrefixOf FilePath
_ FilePath
"" = Bool
False
isPrefixOf (Char
b:FilePath
bs) (Char
c:FilePath
cs) | Char
b forall a. Eq a => a -> a -> Bool
== Char
c = FilePath
bs FilePath -> FilePath -> Bool
`isPrefixOf` FilePath
cs
isPrefixOf FilePath
_ FilePath
_ = Bool
False
readDicts :: [FilePath] -> IO (Set Text)
readDicts :: [FilePath] -> IO WordSet
readDicts [FilePath]
filenames = do FilePath -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ FilePath
"Reading " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
filenames) forall a. [a] -> [a] -> [a]
++ FilePath
" files"
WordSet
result <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM WordSet -> FilePath -> IO WordSet
action forall a. Set a
Set.empty [FilePath]
filenames
FilePath -> IO ()
putStrLn FilePath
""
forall (m :: * -> *) a. Monad m => a -> m a
return WordSet
result
where
action :: WordSet -> FilePath -> IO WordSet
action WordSet
currentSet FilePath
filename = do WordSet
newSet <- FilePath -> IO WordSet
readDict FilePath
filename
let result :: WordSet
result = WordSet
newSet forall a. Ord a => Set a -> Set a -> Set a
`Set.union` WordSet
currentSet
FilePath -> IO ()
putStr FilePath
"."
Handle -> IO ()
hFlush Handle
stdout
WordSet
result forall a b. NFData a => a -> b -> b
`deepseq` forall (m :: * -> *) a. Monad m => a -> m a
return WordSet
result
readDictDir :: FilePath -> IO (Set Text)
readDictDir :: FilePath -> IO WordSet
readDictDir FilePath
dirname = FilePath -> IO [FilePath]
dictFiles FilePath
dirname forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [FilePath] -> IO WordSet
readDicts
defaultDictionary :: FilePath
defaultDictionary :: FilePath
defaultDictionary = FilePath
"/usr/share/dict/british-english"
randomPassword :: WordList -> Int -> Gen Text
randomPassword :: WordList -> Int -> Gen Text
randomPassword WordList
wordlist Int
numWords = do [Text]
ws <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numWords forall a b. (a -> b) -> a -> b
$ Gen Text -> Gen Text
randomCase forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Gen a
randomElement WordList
wordlist
[Text]
seps <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numWords Gen Text
randomSeparator
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Text -> Text
Text.append [Text]
ws [Text]
seps
capitalized :: Text -> Text
capitalized :: Text -> Text
capitalized Text
word = Text -> Text
Text.toUpper Text
first Text -> Text -> Text
`Text.append` Text -> Text
Text.toLower Text
rest
where
(Text
first, Text
rest) = Int -> Text -> (Text, Text)
Text.splitAt Int
1 Text
word
uncapitalized :: Text -> Text
uncapitalized :: Text -> Text
uncapitalized Text
word = Text -> Text
Text.toLower Text
first Text -> Text -> Text
`Text.append` Text -> Text
Text.toUpper Text
rest
where
(Text
first, Text
rest) = Int -> Text -> (Text, Text)
Text.splitAt Int
1 Text
word
evenUpperOddLower :: Text -> Text
evenUpperOddLower :: Text -> Text
evenUpperOddLower = FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack
where
go :: String -> String
go :: FilePath -> FilePath
go [] = []
go [Char
a] = [Char -> Char
toLower Char
a]
go (Char
a:Char
b:FilePath
cs) = Char -> Char
toLower Char
aforall a. a -> [a] -> [a]
:Char -> Char
toUpper Char
bforall a. a -> [a] -> [a]
:FilePath -> FilePath
go FilePath
cs
evenLowerOddUpper :: Text -> Text
evenLowerOddUpper :: Text -> Text
evenLowerOddUpper = FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack
where
go :: String -> String
go :: FilePath -> FilePath
go [] = []
go [Char
a] = [Char -> Char
toUpper Char
a]
go (Char
a:Char
b:FilePath
cs) = Char -> Char
toUpper Char
aforall a. a -> [a] -> [a]
:Char -> Char
toLower Char
bforall a. a -> [a] -> [a]
:FilePath -> FilePath
go FilePath
cs
randomCase :: Gen Text -> Gen Text
randomCase :: Gen Text -> Gen Text
randomCase Gen Text
wordGen = do
Text
word <- Gen Text
wordGen
Text -> Text
changer <- forall a. [a] -> Gen a
elements [Text -> Text]
caseVariants
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Text
changer Text
word
caseVariants :: [Text -> Text]
caseVariants :: [Text -> Text]
caseVariants = [Text -> Text
capitalized, Text -> Text
uncapitalized,
Text -> Text
Text.toLower, Text -> Text
Text.toUpper,
Text -> Text
evenLowerOddUpper, Text -> Text
evenUpperOddLower]
randomPasswordStrength :: V.Vector a -> Int -> Double
randomPasswordStrength :: forall a. Vector a -> Int -> Double
randomPasswordStrength Vector a
wordlist Int
numWords = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numWords forall a. Num a => a -> a -> a
* (forall a. Floating a => a -> a -> a
logBase Double
2 forall {b}. Num b => b
wordStrength)
where
wordStrength :: b
wordStrength = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int
V.length Vector a
wordlist forall a. Num a => a -> a -> a
* (Int
numSymbols forall a. Num a => a -> a -> a
+ Int
numNumericSeparators) forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text -> Text]
caseVariants
numSymbols :: Int
numSymbols :: Int
numSymbols = forall a. Vector a -> Int
V.length Vector Char
symbolChars
numNumericSeparators :: Int
numNumericSeparators :: Int
numNumericSeparators = Int
100
randomSeparator :: Gen Text
randomSeparator :: Gen Text
randomSeparator = do
Double
r <- forall a. Random a => (a, a) -> Gen a
choose (Double
0.0, Double
1.0::Double)
if Double
r forall a. Ord a => a -> a -> Bool
> Double
ratio
then Gen Text
randomSymbolSeparator
else Gen Text
randomNumericSeparator
where
Double
ratio :: Double = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numSymbols forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral(Int
numNumericSeparatorsforall a. Num a => a -> a -> a
+Int
numSymbols)
randomNumericSeparator :: Gen Text
randomNumericSeparator :: Gen Text
randomNumericSeparator = FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
numNumericSeparatorsforall a. Num a => a -> a -> a
-Int
1)
(|||) :: (t -> Bool) -> (t -> Bool) -> t -> Bool
||| :: forall t. (t -> Bool) -> (t -> Bool) -> t -> Bool
(|||) t -> Bool
f t -> Bool
g t
x = t -> Bool
f t
x Bool -> Bool -> Bool
|| t -> Bool
g t
x
randomElement :: V.Vector a -> Gen a
randomElement :: forall a. Vector a -> Gen a
randomElement Vector a
v = (Vector a
v forall a. Vector a -> Int -> a
V.!) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Int
0, forall a. Vector a -> Int
V.length Vector a
vforall a. Num a => a -> a -> a
-Int
1)
symbolChars :: V.Vector Char
symbolChars :: Vector Char
symbolChars = forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Bool
isSymbol forall t. (t -> Bool) -> (t -> Bool) -> t -> Bool
||| Char -> Bool
isPunctuation) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Enum a => Int -> a
toEnum [Int
0..Int
127]
randomSymbolSeparator :: Gen Text
randomSymbolSeparator :: Gen Text
randomSymbolSeparator = Char -> Text
Text.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Vector a -> Gen a
randomElement Vector Char
symbolChars