mirror of
https://github.com/redelmann/scat
synced 2025-01-10 06:34:20 +01:00
Added some tests, factored out the scatter functions out of the main file. Renamed files to achieve that.
This commit is contained in:
parent
b80817a40b
commit
1456ef025e
15
scat.cabal
15
scat.cabal
@ -57,14 +57,14 @@ source-repository head
|
||||
|
||||
executable scat
|
||||
-- .hs or .lhs file containing the Main module.
|
||||
main-is: Scat.hs
|
||||
main-is: Main.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-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 && <5
|
||||
@ -75,3 +75,14 @@ executable scat
|
||||
, 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
|
||||
|
162
src/Main.hs
Normal file
162
src/Main.hs
Normal file
@ -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
|
157
src/Scat.hs
157
src/Scat.hs
@ -1,170 +1,15 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | 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 $ 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
|
||||
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
|
||||
|
26
src/Tests.hs
Normal file
26
src/Tests.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.ByteString (ByteString)
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
import Scat
|
||||
|
||||
scatterTest :: String -> ByteString -> ByteString -> ByteString -> Integer -> IO ()
|
||||
scatterTest name service password code expected = do
|
||||
putStrLn $ "Testing " ++ name
|
||||
when (scatter service password code /= expected) exitFailure
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- Mainly here for regression testing.
|
||||
scatterTest "scatter example 1"
|
||||
"github" "pony1234" "AGDE2-DGXA4-33DLQ-WEDAP-GYPQ9"
|
||||
7273969660509039708598560774226985084748596416599584268407087707065680457723095089909612048211188783512827089141818809294015697773231266655764062992251214
|
||||
scatterTest "scatter example 2"
|
||||
"facebook" "pony1234" "AGDE2-DGXA4-33DLQ-WEDAP-GYPQ9"
|
||||
13262460002149113723264840055577914239548551696334299511162926224707398066055935936276077079458293092086000192365956813128644769941942691534958728554307440
|
||||
|
||||
-- TODO: Test also the schemas.
|
Loading…
Reference in New Issue
Block a user