{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
-- | Main module generating passwords.
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)

-- | Explanatory type alias for the type of wordlists during preprocessing.
type WordSet  = Set.Set Text

-- | Explanatory type alias for immutable, preprocessed wordlist used by random number generator.
type WordList = V.Vector Text

-- * Reading inputs
-- | Try to resolve symbolic link chain for given filename.
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

-- | Reads a dict format to get a list of unique words without any special
--   chars.
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)

-- | Find all plausible dictionaries in a given directory
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

-- | Read a set of dictionaries and put the together.
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

-- | Read all dictionaries from a given directory.
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

-- | Filename for default dictionary (should be command line argument or default glob.)
defaultDictionary ::  FilePath
defaultDictionary :: FilePath
defaultDictionary = FilePath
"/usr/share/dict/british-english"

-- | Pick a random password, given a words list, and a number of words it will contain.
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

-- | First character uppercase, all others lowercase
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

-- | First character lowercase, all others uppercase
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

-- | Swap case for each letter, starting from upper
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

-- | Swap case, starting from lower
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

-- | Randomize letter case within the word.
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

-- | Different uppercase/lowercase variants of each 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]

-- | Estimate strength of random password with given inputs.
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

-- | Number of characters within alphabet.
numSymbols ::  Int
numSymbols :: Int
numSymbols  = forall a. Vector a -> Int
V.length Vector Char
symbolChars -- 32

-- | Since we use two-digit separators, there are 100 different.
numNumericSeparators ::  Int
numNumericSeparators :: Int
numNumericSeparators = Int
100

-- * Random separators
-- | Randomly pick a word separator as a two-digit number, or a symbol
--   character.
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)

-- | Two-digit number as a separator 10^2 = 6.6 bits of entropy.
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)

-- | Conjunction of two unary predicates
(|||) ::  (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)

-- | List of symbol and punctuation characters in ASCII
--   Should be 5 bits of entropy
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]

-- | Text with random symbol character, 5 bits of entropy
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