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
|
executable scat
|
||||||
-- .hs or .lhs file containing the Main module.
|
-- .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
|
hs-source-dirs: src
|
||||||
|
|
||||||
-- Modules included in this executable, other than Main.
|
-- 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.
|
-- Other library packages from which modules are imported.
|
||||||
build-depends: base >=4.5 && <5
|
build-depends: base >=4.5 && <5
|
||||||
@ -75,3 +75,14 @@ executable scat
|
|||||||
, vector == 0.10.*
|
, vector == 0.10.*
|
||||||
, ansi-terminal >= 0.6.1
|
, 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.
|
-- | Password scatterer.
|
||||||
module Main (main) where
|
module Scat (scatter) where
|
||||||
|
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.ByteString (ByteString, unpack)
|
import Data.ByteString (ByteString, unpack)
|
||||||
import qualified Data.ByteString.Char8 as C
|
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 Crypto.Scrypt
|
||||||
|
|
||||||
import Scat.Schemas
|
|
||||||
import Scat.Builder
|
|
||||||
import Scat.Options
|
|
||||||
|
|
||||||
-- | Generates the seed integer given a service, a password and a code.
|
-- | Generates the seed integer given a service, a password and a code.
|
||||||
scatter :: ByteString -> ByteString -> ByteString -> Integer
|
scatter :: ByteString -> ByteString -> ByteString -> Integer
|
||||||
scatter k pw c = foldr (\ n s -> fromIntegral n + 256 * s) 0 $
|
scatter k pw c = foldr (\ n s -> fromIntegral n + 256 * s) 0 $
|
||||||
unpack $ getHash $ scrypt params (Salt k) (Pass $ pw <> c)
|
unpack $ getHash $ scrypt params (Salt k) (Pass $ pw <> c)
|
||||||
where
|
where
|
||||||
Just params = scryptParams 14 8 50
|
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