diff --git a/scat.cabal b/scat.cabal --- a/scat.cabal +++ b/scat.cabal @@ -1,16 +1,16 @@ --- Initial scat.cabal generated by cabal init. For further documentation, +-- Initial scat.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ -- The name of the package. name: scat --- The package version. See the Haskell package versioning policy (PVP) +-- The package version. See the Haskell package versioning policy (PVP) -- for standards guiding when and how versions should be incremented. -- http://www.haskell.org/haskellwiki/Package_versioning_policy -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.0.1.0 +version: 1.1.0.0 -- A short (one-line) description of the package. synopsis: Generates unique passwords for various websites from a single password. @@ -27,7 +27,7 @@ -- The package author(s). author: Romain Edelmann --- An email address to which users can send suggestions, bug reports, and +-- An email address to which users can send suggestions, bug reports, and -- patches. maintainer: romain.edelmann@gmail.com @@ -38,7 +38,7 @@ stability: experimental -- A copyright notice. --- copyright: +-- copyright: category: Password @@ -49,7 +49,7 @@ data-dir: lists -data-files: *.txt +data-files: *.txt source-repository head type: git @@ -57,15 +57,32 @@ executable scat -- .hs or .lhs file containing the Main module. - main-is: Scat.hs + main-is: Main.hs - ghc-options: -Wall -O3 - + ghc-options: -Wall -O3 + hs-source-dirs: src -- Modules included in this executable, other than Main. - other-modules: Scat.Builder, Scat.Schemas, Scat.Options, Scat.Utils.Permutation, Paths_scat - + other-modules: Scat, Scat.Builder, Scat.Schemas, Scat.Options, Scat.Utils.Permutation, Paths_scat + -- Other library packages from which modules are imported. - build-depends: base ==4.5.*, scrypt ==0.3.*, bytestring ==0.9.*, optparse-applicative ==0.5.*, mtl ==2.1.*, vector ==0.10.*, ansi-terminal ==0.6.* - + build-depends: base >=4.5 && <5 + , scrypt == 0.5.* + , bytestring + , optparse-applicative >= 0.5 + , mtl + , vector == 0.10.* + , ansi-terminal >= 0.6.1 + +test-suite scat-tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: src + build-depends: base >=4.5 && <5 + , scrypt == 0.5.* + , bytestring + , optparse-applicative >= 0.5 + , mtl + , vector == 0.10.* + , ansi-terminal >= 0.6.1 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Password scatterer. +module Main (main) where + +import Data.ByteString (ByteString, unpack) +import qualified Data.ByteString.Char8 as C +import System.IO +import System.Exit +import System.Console.ANSI +import Control.Exception +import Control.Monad.Reader + +import Scat +import Scat.Schemas +import Scat.Builder +import Scat.Options + +-- | Main type of the program. +type Scat a = ReaderT Options IO a + +-- | Input visibility. +data Visibility = Shown | Hidden | Erased + +-- | Should the input be echoed? +shouldShow :: Visibility -> Bool +shouldShow Shown = True +shouldShow Hidden = False +shouldShow Erased = True + +-- | Should the input be erased afterwards? +shouldErase :: Visibility -> Bool +shouldErase Shown = False +shouldErase Hidden = False +shouldErase Erased = True + +{- | Generates a password, given a input password, + a service name (category, website, etc.), + a code, and a password `Schema`. + + The parameters are specified as command line arguments. + The password can be read from @stdin@ if not already provided. -} +main :: IO () +main = getOptions >>= runReaderT scat + +-- | Main program. +scat :: Scat () +scat = do + s <- getSchema + k <- getService + pw <- getPassword + c <- getCode + printVerbose "Generated password:\n" + ms <- fmap size ask + showGenerated $ evalBuilder (getBuilder s ms) $ scatter k pw c + +-- | Prints out the generated password. +showGenerated :: String -> Scat () +showGenerated gen = do + v <- fmap verbose ask + a <- fmap ansi ask + let ok = v && a + liftIO $ do + when ok $ setSGR [SetSwapForegroundBackground True] + putStrLn gen + when ok $ setSGR [SetSwapForegroundBackground False] + + +-- | Prints, if the verbosity level allows it. +printVerbose :: String -> Scat () +printVerbose str = do + v <- fmap verbose ask + when v $ liftIO $ do + putStr str + hFlush stdout + +-- | Gets the password. +getPassword :: Scat ByteString +getPassword = do + mpw <- fmap password ask + case mpw of + -- Ask for the password on stdin. + Nothing -> do + c <- fmap confirm ask + if c + then getPassConfirm + else getPass + + -- Retrieve the password from the arguments. + Just st -> return $ C.pack st + where + getPass = prompt Hidden "Password: " + + getPassConfirm = do + a <- prompt Hidden "Password: " + b <- prompt Hidden "Confirm: " + if a == b + then return a + else do + printVerbose "Passwords do not match, please retry.\n" + getPassConfirm + +-- | Ask a for input on the command line, with the specified prompt. +prompt :: Visibility -> String -> Scat ByteString +prompt vis str = do + printVerbose str + old <- liftIO $ hGetEcho stdin + pw <- liftIO $ bracket_ + (hSetEcho stdin $ shouldShow vis) + (hSetEcho stdin old) + C.getLine + v <- fmap verbose ask + a <- fmap ansi ask + when (shouldErase vis && a && v) $ liftIO $ do + cursorUpLine 1 + cursorForward $ length str + clearFromCursorToScreenEnd + cursorDownLine 1 + unless (shouldShow vis) $ printVerbose "\n" + return pw + +-- | Gets the service. +getService :: Scat ByteString +getService = do + mk <- fmap service ask + case mk of + Just k -> return $ C.pack k + Nothing -> prompt Shown "Service: " + +-- | Gets the code. +getCode :: Scat ByteString +getCode = do + uc <- fmap useCode ask + if uc + then do + mc <- fmap code ask + case mc of + Just st -> return $ C.pack st + Nothing -> prompt Erased "Code: " + else return "" + + +-- | Lists all the available schemas. +schemas :: [(String, Scat Schema)] +schemas = + [ ("safe", return safe) + , ("alpha", return alphanumeric) + , ("parano", return paranoiac) + , ("pin", return pin) + , ("lock", return androidPatternLock) + , ("diceware", liftIO diceware) + , ("pokemons", liftIO pokemons) ] + +-- | Gets the schema to generate the new password. +getSchema :: Scat Schema +getSchema = do + name <- fmap schema ask + case lookup name schemas of + Just s -> s + Nothing -> liftIO $ do + hPutStrLn stderr "Error: Unknown schema" + exitFailure diff --git a/src/Scat.hs b/src/Scat.hs --- a/src/Scat.hs +++ b/src/Scat.hs @@ -1,185 +1,15 @@ -{-# LANGUAGE OverloadedStrings, PatternGuards #-} -- | Password scatterer. -module Main (main) where +module Scat (scatter) where import Data.Monoid import Data.ByteString (ByteString, unpack) import qualified Data.ByteString.Char8 as C -import System.IO -import System.Exit -import System.Console.ANSI -import Control.Exception -import Control.Monad.Reader import Crypto.Scrypt -import Scat.Schemas -import Scat.Builder -import Scat.Options - -- | Generates the seed integer given a service, a password and a code. scatter :: ByteString -> ByteString -> ByteString -> Integer scatter k pw c = foldr (\ n s -> fromIntegral n + 256 * s) 0 $ - unpack $ unHash $ scrypt params (Salt k) (Pass $ pw <> c) + unpack $ getHash $ scrypt params (Salt k) (Pass $ pw <> c) where Just params = scryptParams 14 8 50 - --- | Main type of the program. -type Scat a = ReaderT Options IO a - --- | Input visibility. -data Visibility = Shown | Hidden | Erased - --- | Should the input be echoed? -shouldShow :: Visibility -> Bool -shouldShow Shown = True -shouldShow Hidden = False -shouldShow Erased = True - --- | Should the input be erased afterwards? -shouldErase :: Visibility -> Bool -shouldErase Shown = False -shouldErase Hidden = False -shouldErase Erased = True - -{- | Generates a password, given a input password, - a service name (category, website, etc.), - a code, and a password `Schema`. - - The parameters are specified as command line arguments. - The password can be read from @stdin@ if not already provided. -} -main :: IO () -main = getOptions >>= runReaderT scat - --- | Main program. -scat :: Scat () -scat = do - k <- getService - s <- getSchema - pw <- getPassword - c <- getCode - printVerbose "Generated password:\n" - showGenerated $ evalBuilder s $ scatter k pw c - --- | Prints out the generated password. -showGenerated :: String -> Scat () -showGenerated gen = do - v <- fmap verbose ask - a <- fmap ansi ask - let ok = v && a - liftIO $ do - when ok $ setSGR [SetSwapForegroundBackground True] - putStrLn gen - when ok $ setSGR [SetSwapForegroundBackground False] - - --- | Prints, if the verbosity level allows it. -printVerbose :: String -> Scat () -printVerbose str = do - v <- fmap verbose ask - when v $ liftIO $ do - putStr str - hFlush stdout - --- | Gets the password. -getPassword :: Scat ByteString -getPassword = do - mpw <- fmap password ask - case mpw of - -- Ask for the password on stdin. - Nothing -> do - c <- fmap confirm ask - if c - then getPassConfirm - else getPass - - -- Retrieve the password from the arguments. - Just st -> return $ C.pack st - where - getPass = prompt Hidden "Password: " - - getPassConfirm = do - a <- prompt Hidden "Password: " - b <- prompt Hidden "Confirm: " - if a == b - then return a - else do - printVerbose "Passwords do not match, please retry.\n" - getPassConfirm - --- | Ask a for input on the command line, with the specified prompt. -prompt :: Visibility -> String -> Scat ByteString -prompt vis str = do - printVerbose str - old <- liftIO $ hGetEcho stdin - pw <- liftIO $ bracket_ - (hSetEcho stdin $ shouldShow vis) - (hSetEcho stdin old) - C.getLine - v <- fmap verbose ask - a <- fmap ansi ask - when (shouldErase vis && a && v) $ liftIO $ do - cursorUpLine 1 - cursorForward $ length str - clearFromCursorToScreenEnd - cursorDownLine 1 - unless (shouldShow vis) $ printVerbose "\n" - return pw - --- | Gets the service. -getService :: Scat ByteString -getService = do - mk <- fmap service ask - case mk of - Just k -> return $ C.pack k - Nothing -> prompt Shown "Service: " - --- | Gets the code. -getCode :: Scat ByteString -getCode = do - uc <- fmap useCode ask - if uc - then do - mc <- fmap code ask - case mc of - Just st -> return $ C.pack st - Nothing -> prompt Erased "Code: " - else return "" - --- | Gets the schema to generate the new password. -getSchema :: Scat Schema -getSchema = do - name <- fmap schema ask - case name of - -- Safe, the default. - "safe" -> return safe - - -- Alphanumeric. - "alpha" -> return alphanumeric - - -- Paranoiac - "parano" -> return paranoiac - - -- PIN. - 'p' : 'i' : 'n' : xs | [(n, "")] <- reads xs -> return $ pin n - - -- PIN with default size. - "pin" -> return $ pin 6 - - -- Pattern lock - 'l' : 'o' : 'c' : 'k' : xs | [(n, "")] <- reads xs -> return $ - androidPatternLock n - - -- Default size of pattern lock - "lock" -> return $ androidPatternLock 9 - - -- Passphrase using Diceware's list. - "diceware" -> liftIO diceware - - -- Passphrase using Pokemons. - "pokemons" -> liftIO pokemons - - -- Unkown. - _ -> liftIO $ do - hPutStrLn stderr "Error: Unknown schema" - exitFailure diff --git a/src/Scat/Builder.hs b/src/Scat/Builder.hs --- a/src/Scat/Builder.hs +++ b/src/Scat/Builder.hs @@ -63,7 +63,7 @@ pure x = Builder (\ n -> (n, x)) f <*> x = Builder $ \ n -> let (n', g) = runBuilder f n - in fmap g $ runBuilder x n' + in g <$> runBuilder x n' instance Monad Builder where return = pure @@ -85,19 +85,19 @@ -- | Returns a lower case letter. lower :: Builder Char -lower = fmap (chr . (+ ord 'a')) $ lessThan 26 +lower = (chr . (+ ord 'a')) <$> lessThan 26 -- | Returns an upper case letter. upper :: Builder Char -upper = fmap (chr . (+ ord 'A')) $ lessThan 26 +upper = (chr . (+ ord 'A')) <$> lessThan 26 -- | Returns an printable ascii char. ascii :: Builder Char -ascii = fmap chr $ inRange (32, 126) +ascii = chr <$> inRange (32, 126) -- | Returns a digit. digit :: Builder Char -digit = fmap chr $ inRange (48, 57) +digit = chr <$> inRange (48, 57) -- | Returns a letter. letter :: Builder Char @@ -125,7 +125,7 @@ -- | Shuffles the input list. shuffle :: [a] -> Builder [a] -shuffle xs = fmap (perm xs) $ lessThan $ fact $ length xs +shuffle xs = fmap (perm xs) $ lessThan $ fact $ fromIntegral $ length xs where - fact :: Int -> Int + fact :: Integer -> Integer fact n = product [1 .. n] diff --git a/src/Scat/Options.hs b/src/Scat/Options.hs --- a/src/Scat/Options.hs +++ b/src/Scat/Options.hs @@ -11,6 +11,7 @@ , useCode , code , schema + , size , verbose , confirm , ansi @@ -34,6 +35,8 @@ -- ^ Extra code. , schema :: String -- ^ Name of the schema to use. + , size :: Maybe Int + -- ^ Size parameter of the schema. , verbose :: Bool -- ^ Verbosity. If false, do not print anything but the generated password. , confirm :: Bool @@ -81,6 +84,11 @@ <> metavar "SCHEMA" <> value "safe" <> showDefault) + <*> optional (option + (short 'n' + <> long "size" + <> help "Size parameter" + <> metavar "SIZE")) <*> flag True False (long "silent" <> help "Do not print anything but the generated password") diff --git a/src/Scat/Schemas.hs b/src/Scat/Schemas.hs --- a/src/Scat/Schemas.hs +++ b/src/Scat/Schemas.hs @@ -7,26 +7,37 @@ -- * Type Schema - -- * Passwords + -- ** Constructors + , withDefaultSize + , ignoreSize + + -- ** Destructor + , getBuilder + + -- * Built-in schemas + + -- ** Passwords , safe , alphanumeric , paranoiac - -- * PIN + -- ** PIN , pin - -- * Pass phrases + -- ** Pass phrases , pokemons , diceware - -- * Pattern lock + -- ** Pattern lock , androidPatternLock ) where +import Data.Ratio ((%)) import Data.List (intercalate, (\\)) import Data.Vector (Vector) import qualified Data.Vector as V import Data.Monoid +import Control.Applicative import Control.Monad (replicateM) import System.IO @@ -35,39 +46,60 @@ import Paths_scat -- | Password builder. -type Schema = Builder String +data Schema = Schema + { defaultSize :: Int + , builder :: Int -> Builder String } --- | Paranoiac mode, entropy of 512 bits. +-- | Returns a `Builder` given an optional size. +getBuilder :: Schema -> Maybe Int -> Builder String +getBuilder schema Nothing = builder schema $ defaultSize schema +getBuilder schema (Just s) = builder schema s + +-- | Specifies the Schema will not be sensible to any size parameter. +ignoreSize :: Builder String -> Schema +ignoreSize = Schema undefined . const + +-- | Specifies the Schema accepts a size parameter. +withDefaultSize :: Int -> (Int -> Builder String) -> Schema +withDefaultSize = Schema + +-- | Paranoiac mode, entropy of 512 bits with the default size of 78. paranoiac :: Schema -paranoiac = replicateM 78 ascii +paranoiac = withDefaultSize 78 $ \ s -> replicateM s ascii -{- | Generates a password of length 18, +{- | Generates a password, containing upper case letters, lower case letters, digits and symbols. - Entropy of about 115 bits. -} + Entropy of about 115 bits for length 18. -} safe :: Schema -safe = do - nUpper <- inRange (2, 5) - nDigit <- inRange (2, 5) - nSpecial <- inRange (2, 5) - let nLower = 18 - nUpper - nSpecial - nDigit +safe = withDefaultSize 18 $ \ s -> do + let number = max s 4 + lBound = max 1 $ floor $ number % 8 + uBound = ceiling $ number % 4 + nUpper <- inRange (lBound, uBound) + nDigit <- inRange (lBound, uBound) + nSpecial <- inRange (lBound, uBound) + let nLower = number - nUpper - nSpecial - nDigit uppers <- replicateM nUpper upper digits <- replicateM nDigit digit specials <- replicateM nSpecial special lowers <- replicateM nLower lower shuffle (uppers <> digits <> specials <> lowers) -{- | Generates a password of length 18, +{- | Generates a password, containing upper case letters, lower case letters and digits, but no symbols. - Entropy of about 104.2 bits. -} + Entropy of about 104.2 bits for length 18. -} alphanumeric :: Schema -alphanumeric = do - nUpper <- inRange (2, 5) - nDigit <- inRange (2, 5) - let nLower = 18 - nUpper - nDigit +alphanumeric = withDefaultSize 18 $ \ s -> do + let number = max s 4 + lBound = max 1 $ floor $ number % 8 + uBound = ceiling $ number % 4 + nUpper <- inRange (lBound, uBound) + nDigit <- inRange (lBound, uBound) + let nLower = number - nUpper - nDigit uppers <- replicateM nUpper upper digits <- replicateM nDigit digit lowers <- replicateM nLower lower @@ -75,14 +107,13 @@ {- | Generates a PIN number, of length `n`. Entropy of about @3.32 * n@ bits. -} -pin :: Int -> Schema -pin n = replicateM n digit - +pin :: Schema +pin = withDefaultSize 6 $ \ s -> replicateM s digit --- | Generates an Android lock pattern, of specified length. -androidPatternLock :: Int -> Schema -androidPatternLock number = do - xs <- loop (min number (height * width)) [] +-- | Generates an Android lock pattern. +androidPatternLock :: Schema +androidPatternLock = withDefaultSize 9 $ \ s -> do + xs <- loop (min s (height * width)) [] return $ intercalate " - " $ map showPosition xs where -- Gets `n` points. @@ -133,27 +164,29 @@ vstep = vdiff `div` steps hstep = hdiff `div` steps -{- | Generates a password with 4 of the original Pokemons and their level. - Entropy of about 55.5 bits. -} +{- | Generates a password with `s` of the original Pokemons and their level. + Entropy of about 55.5 bits for 4 pokemons. -} pokemons :: IO Schema -pokemons = fromFile "pokemons.txt" $ \ vect -> do - ps <- replicateM 4 $ oneOfV vect - ls <- replicateM 4 $ inRange (1, 100 :: Int) - let ss = zipWith (\ p l -> p ++ " " ++ show l) ps ls - return $ intercalate ", " ss +pokemons = fromFile "pokemons.txt" $ \ vect -> + withDefaultSize 4 $ \ s -> do + ps <- replicateM s $ oneOfV vect + ls <- replicateM s $ inRange (1, 100 :: Int) + let ss = zipWith (\ p l -> p ++ " " ++ show l) ps ls + return $ intercalate ", " ss -{- | Generates a password with 5 words +{- | Generates a password with `s` words from the Diceware list. - Entropy of about 64.6 bits. -} + Entropy of about 64.6 bits for 5 words. -} diceware :: IO Schema -diceware = fromFile "diceware.txt" $ \ vect -> do - ws <- replicateM 5 $ oneOfV vect +diceware = fromFile "diceware.txt" $ \ vect -> + withDefaultSize 5 $ \ s -> do + ws <- replicateM s $ oneOfV vect return $ unwords ws --- | Feeds all lines of a file to a builder. -fromFile :: FilePath -> (Vector String -> Builder a) -> IO (Builder a) +-- | Feeds all lines of a file to a function and gets the result. +fromFile :: FilePath -> (Vector String -> a) -> IO a fromFile fp bs = do fp' <- getDataFileName fp withFile fp' ReadMode $ \ h -> do - !vect <- fmap (V.fromList . lines) $ hGetContents h + !vect <- (V.fromList . lines) <$> hGetContents h return $ bs vect diff --git a/src/Scat/Utils/Permutation.hs b/src/Scat/Utils/Permutation.hs --- a/src/Scat/Utils/Permutation.hs +++ b/src/Scat/Utils/Permutation.hs @@ -25,17 +25,19 @@ Retrieved from: http://en.literateprograms.org/Kth_permutation_(Haskell)?oldid=16316 -} -{- | Permutations, taken from the +{- | Permutations, adapted from the http://en.literateprograms.org/Kth_permutation_(Haskell) webpage. -} module Scat.Utils.Permutation (perm) where -rr :: Int -> Int -> [Int] +rr :: Integer -> Integer -> [Integer] rr 0 _ = [] -rr n k = k `mod` n : rr (n - 1) (k `div` n) +rr n k = m : rr (n - 1) d + where + (d, m) = k `divMod` n -dfr :: [Int] -> [Int] -dfr = foldr (\ x rs -> x : [r + (if x <= r then 1 else 0) | r <- rs]) [] +dfr :: [Integer] -> [Integer] +dfr = foldr (\ x rs -> x : [r + if x <= r then 1 else 0 | r <- rs]) [] -- | List permutation. -perm :: [a] -> Int -> [a] -perm xs k = [xs !! i | i <- dfr (rr (length xs) k)] +perm :: [a] -> Integer -> [a] +perm xs k = [xs !! fromInteger i | i <- dfr (rr (fromIntegral $ length xs) k)] diff --git a/src/Tests.hs b/src/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Tests.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Monad +import Data.ByteString (ByteString) +import System.Exit (exitFailure) + +import Scat +import Scat.Builder +import Scat.Schemas + +seedGithub :: Integer +seedGithub = 7273969660509039708598560774226985084748596416599584268407087707065680457723095089909612048211188783512827089141818809294015697773231266655764062992251214 + +seedFacebook :: Integer +seedFacebook = 13262460002149113723264840055577914239548551696334299511162926224707398066055935936276077079458293092086000192365956813128644769941942691534958728554307440 + +scatterTest :: String -> ByteString -> ByteString -> ByteString -> Integer -> IO () +scatterTest name service password code expected = do + putStrLn $ "Testing " ++ name + when (scatter service password code /= expected) exitFailure + +schemaTest :: String -> Schema -> Integer -> String -> IO () +schemaTest name schema seed expected = do + putStrLn $ "Testing " ++ name + when (evalBuilder (getBuilder schema Nothing) seed /= expected) exitFailure + +main :: IO () +main = do + -- Mainly here for regression testing. + scatterTest "scatter test 1 - using github as service" + "github" "pony1234" "AGDE2-DGXA4-33DLQ-WEDAP-GYPQ9" + seedGithub + scatterTest "scatter test 2 - using facebook as service" + "facebook" "pony1234" "AGDE2-DGXA4-33DLQ-WEDAP-GYPQ9" + seedFacebook + + -- Testing the examples from the README. + schemaTest "schema test 1 - generating from 'safe' schema, with github seed" + safe seedGithub + "k2'8n?QXwmptbJ7D44" + + schemaTest "schema test 2 - generating from 'safe' schema, with facebook seed" + safe seedFacebook + "{g6e2hsKjh#Ra*\\ks(" + + dicewareSchema <- diceware + schemaTest "schema test 3 - generating from 'diceware' schema" + dicewareSchema seedFacebook + "101 dry whoa foil barb" + + pokemonsSchema <- pokemons + schemaTest "schema test 4 - generating from 'pokemons' schema" + pokemonsSchema seedFacebook + "Snorlax 5, Weedle 35, Raichu 27, Alakazam 99"