Initial import.

.gitignore

@@ -0,0 +1,2 @@
+dist
+cabal-dev

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2013, Romain Edelmann
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Romain Edelmann nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

lists/pokemons.txt

@@ -0,0 +1,151 @@
+Abra
+Aerodactyl
+Alakazam
+Arbok
+Arcanine
+Articuno
+Beedrill
+Bellsprout
+Blastoise
+Bulbasaur
+Butterfree
+Caterpie
+Chansey
+Charizard
+Charmander
+Charmeleon
+Clefable
+Clefairy
+Cloyster
+Cubone
+Dewgong
+Diglett
+Ditto
+Dodrio
+Doduo
+Dragonair
+Dragonite
+Dratini
+Drowzee
+Dugtrio
+Eevee
+Ekans
+Electabuzz
+Electrode
+Exeggcute
+Exeggutor
+Farfetch'd
+Fearow
+Flareon
+Gastly
+Gengar
+Geodude
+Gloom
+Golbat
+Goldeen
+Golduck
+Golem
+Graveler
+Grimer
+Growlithe
+Gyarados
+Haunter
+Hitmonchan
+Hitmonlee
+Horsea
+Hypno
+Ivysaur
+Jigglypuff
+Jolteon
+Jynx
+Kabuto
+Kabutops
+Kadabra
+Kakuna
+Kangaskhan
+Kingler
+Koffing
+Krabby
+Lapras
+Lickitung
+Machamp
+Machoke
+Machop
+Magikarp
+Magmar
+Magnemite
+Magneton
+Mankey
+Marowak
+Meowth
+Metapod
+Mew
+Mewtwo
+Moltres
+Mr. Mime
+Muk
+Nidoking
+Nidoqueen
+Nidoran Male
+Nidoran Female
+Nidorina
+Nidorino
+Ninetales
+Oddish
+Omanyte
+Omastar
+Onix
+Paras
+Parasect
+Persian
+Pidgeot
+Pidgeotto
+Pidgey
+Pikachu
+Pinsir
+Poliwag
+Poliwhirl
+Poliwrath
+Ponyta
+Porygon
+Primeape
+Psyduck
+Raichu
+Rapidash
+Raticate
+Rattata
+Rhydon
+Rhyhorn
+Sandshrew
+Sandslash
+Scyther
+Seadra
+Seaking
+Seel
+Shellder
+Slowbro
+Slowpoke
+Snorlax
+Spearow
+Squirtle
+Starmie
+Staryu
+Tangela
+Tauros
+Tentacool
+Tentacruel
+Vaporeon
+Venomoth
+Venonat
+Venusaur
+Victreebel
+Vileplume
+Voltorb
+Vulpix
+Wartortle
+Weedle
+Weepinbell
+Weezing
+Wigglytuff
+Zapdos
+Zubat

scat.cabal

@@ -0,0 +1,61 @@
+-- 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) 
+-- 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:             0.1.0.0
+
+-- A short (one-line) description of the package.
+synopsis:            Generates unique passwords for various websites from a single password.
+
+-- A longer description of the package.
+-- description:         
+
+-- The license under which the package is released.
+license:             BSD3
+
+-- The file containing the license text.
+license-file:        LICENSE
+
+-- The package author(s).
+author:              Romain Edelmann
+
+-- An email address to which users can send suggestions, bug reports, and 
+-- patches.
+maintainer:          romain.edelmann@gmail.com
+
+-- A copyright notice.
+-- copyright:           
+
+category:            Password
+
+build-type:          Simple
+
+-- Constraint on the version of Cabal needed to build this package.
+cabal-version:       >=1.8
+
+data-dir: lists
+
+data-files: *.txt 
+
+executable scat
+  -- .hs or .lhs file containing the Main module.
+  main-is: Scat.hs
+
+  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 library packages from which modules are imported.
+  build-depends:       base ==4.5.*, SHA ==1.6.*, bytestring ==0.9.*, optparse-applicative ==0.5.*, mtl ==2.1.*, vector ==0.10.*
+  

src/Scat.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE OverloadedStrings, PatternGuards #-}
+
+-- | Password scatterer.
+module Main (main) where
+
+import Data.Monoid
+import Data.Digest.Pure.SHA
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy.Char8 as LC
+import qualified Data.ByteString.Lazy as BS
+import System.IO
+import System.Exit
+import Control.Exception
+import Control.Monad.Reader
+
+import Scat.Schemas
+import Scat.Builder
+import Scat.Options
+
+-- | Generates the seed integer given a key and a password.
+scatter :: ByteString -> ByteString -> Integer
+scatter k pw = integerDigest $ sha512 (k <> pw)
+
+-- | Main type of the program.
+type Scat a = ReaderT Options IO a
+
+{- | Generates a password, given a input password,
+     a key (category, website, etc.),
+     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  <- getKey
+    s  <- getSchema
+    pw <- getPassword
+    printVerbose "Generated password:\n"
+    liftIO $ putStrLn $ evalBuilder s $ scatter k pw
+
+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
+    pw <- 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
+    return $ BS.fromChunks [pw]
+  where
+    getPass = askPassword "Password: "
+
+    getPassConfirm = do
+        a <- askPassword "Password: "
+        b <- askPassword "Confirm: "
+        if (a == b)
+            then return a
+            else do
+                printVerbose "Passwords do not match, please retry.\n"
+                getPassConfirm
+
+askPassword :: String -> Scat C.ByteString
+askPassword str = do
+    printVerbose str
+    old <- liftIO $ hGetEcho stdin
+    pw <- liftIO $ bracket_ 
+        (hSetEcho stdin False)
+        (hSetEcho stdin old)
+        C.getLine
+    printVerbose "\n"
+    return pw
+
+-- | Gets the key.
+getKey :: Scat ByteString
+getKey = fmap (LC.pack . key) ask
+
+-- | 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
+
+        -- PIN.
+        'p' : 'i' : 'n' : xs | [(n, "")] <- reads xs -> return $ pin n
+
+        -- Passphrase using Diceware's list.
+        "diceware" -> liftIO diceware
+
+        -- Passphrase using Pokemons.
+        "pokemons" -> liftIO pokemons
+
+        -- Unkown.
+        _ -> liftIO $ do
+            hPutStrLn stderr "Error: Unknown schema"
+            exitFailure

src/Scat/Builder.hs

@@ -0,0 +1,131 @@
+
+{- | This modules defines `Builder`s,
+     which are simple parsers on `Integer`. -}
+module Scat.Builder
+    (
+    -- * Type
+      Builder
+
+    -- * Execution
+    , runBuilder
+    , evalBuilder
+    , execBuilder
+
+    -- * Primitives
+
+    -- ** Numbers
+    , lessThan
+    , inRange
+
+    -- ** Char
+    , digit
+    , letter
+    , lower
+    , upper
+    , ascii
+    , special
+
+    -- * Combinators
+    , useup
+    , shuffle
+    , oneOf
+    , oneOfV
+    ) where
+
+import Data.Char (ord, chr)
+import Data.Monoid
+import Control.Applicative
+import Control.Monad
+import Control.Arrow (second)
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+
+import Scat.Utils.Permutation
+
+-- | Parser acting on an `Integer`.
+newtype Builder a = Builder
+    { runBuilder :: Integer -> (Integer, a)
+      -- ^ Runs the builder.
+    }
+
+-- | Evaluates the builder.
+evalBuilder :: Builder a -> Integer -> a
+evalBuilder b n = snd $ runBuilder b n
+
+-- | Executes the builder.
+execBuilder :: Builder a -> Integer -> Integer
+execBuilder b n = fst $ runBuilder b n
+
+instance Functor Builder where
+    fmap f (Builder g) = Builder $ second f . g
+
+instance Applicative Builder where
+    pure x = Builder (\ n -> (n, x))
+    f <*> x = Builder $ \ n ->
+        let (n', g) = runBuilder f n
+        in fmap g $ runBuilder x n'
+
+instance Monad Builder where
+    return = pure
+    x >>= f = Builder $ \ n ->
+        let (n', v) = runBuilder x n
+        in runBuilder (f v) n'
+
+instance Monoid a => Monoid (Builder a) where
+    mempty = return mempty
+    mappend a b = mappend <$> a <*> b
+
+-- | Returns a positive integer less than `i`.
+lessThan :: Integral a => a -> Builder a
+lessThan i = Builder $ \ n -> second fromIntegral $ quotRem n $ fromIntegral i
+
+-- | Returns an integer between `a` and `b`, both inclusive.
+inRange :: Integral a => (a, a) -> Builder a
+inRange (a, b) = fmap (+ a) $ lessThan $ b + 1 - a
+
+-- | Returns a lower case letter.
+lower :: Builder Char
+lower = fmap (chr . (+ ord 'a')) $ lessThan 26
+
+-- | Returns an upper case letter.
+upper :: Builder Char
+upper = fmap (chr . (+ ord 'A')) $ lessThan 26
+
+-- | Returns an printable ascii char.
+ascii :: Builder Char
+ascii = fmap chr $ inRange (32, 126)
+
+-- | Returns a digit.
+digit :: Builder Char
+digit = fmap chr $ inRange (48, 57)
+
+-- | Returns a letter.
+letter :: Builder Char
+letter = join $ oneOf [upper, lower]
+
+-- | Returns a special character.
+special :: Builder Char
+special = oneOf "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"
+
+-- | Returns one element of the list.
+oneOf :: [a] -> Builder a
+oneOf [] = error "oneOf on empty list"
+oneOf xs = fmap (xs !!) $ lessThan $ length xs
+
+-- | Returns on element of the vector.
+oneOfV :: Vector a -> Builder a
+oneOfV vect = fmap (vect V.!) $ lessThan $ V.length vect
+
+{- | Returns the results of the input builder
+     until the consummed integer is 0. -}
+useup :: Builder a -> Builder [a]
+useup b = Builder $ \ n ->
+    if n == 0 then (0, []) else runBuilder
+        ((:) <$> b <*> useup b) n
+
+-- | Shuffles the input list.
+shuffle :: [a] -> Builder [a]
+shuffle xs = fmap (perm xs) $ lessThan $ fact $ length xs
+  where
+    fact :: Int -> Int
+    fact n = product [1 .. n]

src/Scat/Options.hs

@@ -0,0 +1,75 @@
+
+-- | Parses command-line arguments.
+module Scat.Options
+    (
+    -- * Type
+      Options
+
+    -- * Accessors
+    , password
+    , key
+    , schema
+    , verbose
+    , confirm
+
+    -- * Execution
+    , getOptions
+    ) where
+
+import Data.Monoid
+import Options.Applicative
+
+-- | All program options.
+data Options = Options
+    { password :: Maybe String
+    -- ^ Password, optionally provided.
+    , key      :: String
+    -- ^ Key or category for the password.
+    , schema   :: String
+    -- ^ Name of the schema to use.
+    , verbose_ :: Bool
+    -- ^ Verbosity. If false, do not print anything but the generated password.
+    , confirm  :: Bool
+    -- ^ Indicates if the password must be confirmed. Activates verbosity.
+    }
+
+verbose :: Options -> Bool
+verbose opts = verbose_ opts || confirm opts
+
+-- | Parses the arguments from the command line.
+getOptions :: IO Options
+getOptions = execParser opts
+  where
+    opts = info (helper <*> options)
+        (fullDesc
+        <> progDesc "Safely generate passwords derived from a unique password."
+        <> header "scat - a password scatterer")
+
+-- | Option parser.
+options :: Parser Options
+options = Options
+    <$> optional
+          (strOption (short 'p'
+        <> long "password"
+        <> help "The password"
+        <> metavar "PASSWORD"))
+    <*> strOption
+          (short 'k'
+        <> long "key"
+        <> help "Key associated (website, email address, ...) (mandatory)"
+        <> metavar "KEY")
+    <*> strOption
+          (short 's'
+        <> long "schema"
+        <> help "Schema for the generated password"
+        <> metavar "SCHEMA"
+        <> value "safe"
+        <> showDefault)
+    <*> switch
+          (short 'v'
+        <> long "verbose"
+        <> help "Prints instructions and information")
+    <*> switch
+          (short 'c'
+        <> long "confirmation"
+        <> help "Asks for password confirmation")

src/Scat/Schemas.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE BangPatterns #-}
+
+{- | This module defines `Schema`s,
+     which can generate passwords. -}
+module Scat.Schemas
+    (
+    -- * Type
+      Schema
+
+    -- * Passwords
+    , safe
+    , alphanumeric
+
+    -- * PIN
+    , pin
+
+    -- * Pass phrases
+    , pokemons
+    , diceware
+    ) where
+
+import Data.List (intercalate)
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Data.Monoid
+import Control.Monad (replicateM)
+import System.IO
+
+import Scat.Builder
+
+import Paths_scat
+
+-- | Password builder.
+type Schema = Builder String
+
+{- | Generates a password of length 18,
+     containing upper case letters,
+     lower case letters,
+     digits and symbols.
+     Entropy of about 115 bits. -}
+safe :: Schema
+safe = do
+    nUpper <- inRange (2, 5)
+    nDigit <- inRange (2, 5)
+    nSpecial <- inRange (2, 5)
+    let nLower = 18 - 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,
+     containing upper case letters,
+     lower case letters and
+     digits, but no symbols.
+     Entropy of about 104.2 bits. -}
+alphanumeric :: Schema
+alphanumeric = do
+    nUpper <- inRange (2, 5)
+    nDigit <- inRange (2, 5)
+    let nLower = 18 - nUpper - nDigit
+    uppers <- replicateM nUpper upper
+    digits <- replicateM nDigit digit
+    lowers <- replicateM nLower lower
+    shuffle (uppers <> digits <> lowers)
+
+{- | Generates a PIN number, of length `n`.
+     Entropy of about @3.32 * n@ bits. -}
+pin :: Int -> Schema
+pin n = replicateM n digit
+
+{- | Generates a password with 4 of the original Pokemons and their level.
+     Entropy of about 55.5 bits. -}
+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
+
+{- | Generates a password with 5 words
+     from the Diceware list.
+     Entropy of about 64.6 bits. -}
+diceware :: IO Schema
+diceware = fromFile "diceware.txt" $ \ vect -> do
+        ws <- replicateM 5 $ oneOfV vect
+        return $ unwords ws
+
+-- | Feeds all lines of a file to a builder.
+fromFile :: FilePath -> (Vector String -> Builder a) -> IO (Builder a)
+fromFile fp bs = do
+    fp' <- getDataFileName fp
+    withFile fp' ReadMode $ \ h -> do
+        !vect <- fmap (V.fromList . lines) $ hGetContents h
+        return $ bs vect

src/Scat/Utils/Permutation.hs

@@ -0,0 +1,41 @@
+
+{- Copyright (c) 2013 the authors listed at the following URL, and/or
+the authors of referenced articles or incorporated external code:
+http://en.literateprograms.org/Kth_permutation_(Haskell)?action=history&offset=20090329064426
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+Retrieved from: http://en.literateprograms.org/Kth_permutation_(Haskell)?oldid=16316
+-}
+
+{- | Permutations, taken from the
+     http://en.literateprograms.org/Kth_permutation_(Haskell) webpage. -}
+module Scat.Utils.Permutation (perm) where
+
+rr :: Int -> Int -> [Int]
+rr 0 _ = []
+rr n k = k `mod` n : rr (n - 1) (k `div` n)
+
+dfr :: [Int] -> [Int]
+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)]