Main.hs

module Main where

import Control.Monad
import Data.Char
import Data.List
import Data.Maybe (fromMaybe)
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
import System.Random

import Data.Elocrypt

version :: String
termLen :: Int
termHeight :: Int

version = "elocrypt 2.0.1"
termLen = 80
termHeight = 10

data Options = Options {
      optCapitals  :: Bool,       -- Include capital letters?
      optLength    :: Int,        -- Size of the password(s)
      optMaxLength :: Int,
      optNumber    :: Maybe Int,  -- Number of passwords to generate
      optPassType  :: PassType,   -- Generate passwords or passphrases
      optHelp      :: Bool,
      optVersion   :: Bool
  } deriving (Show)

data PassType
  = Phrase
  | Word
  deriving (Eq, Show)

defaultOptions :: Options
defaultOptions = Options
  { optCapitals = False
  , optLength = 8
  , optMaxLength = 10
  , optNumber = Nothing
  , optPassType = Word
  , optHelp = False
  , optVersion = False
  }

options :: [OptDescr (Options -> Options)]
options =
  [ Option
    ['c']
    ["capitals"]
    (NoArg (\o -> o { optCapitals = True }))
    "Include at least one capital letter"
  , Option
    ['n']
    ["number"]
    (ReqArg (\n o -> o { optNumber = Just (read n) }) "NUMBER")
    "The number of passwords to generate"
  , Option
    ['p']
    ["passphrase"]
    (NoArg (\o -> o { optPassType = Phrase }))
    "Generate passphrases instead of passwords"
  , Option ['h'] ["help"] (NoArg (\o -> o { optHelp = True })) "Show this help"
  , Option
    ['v']
    ["version"]
    (NoArg (\o -> o { optVersion = True }))
    "Show version and exit"
  ]

main :: IO ()
main = do
  args <- getArgs
  opts <- elocryptOpts args
  gen <- getStdGen

  when (optHelp opts) $ do
    hPutStrLn stderr usage
    exitSuccess

  when (optVersion opts) $ do
    hPutStrLn stderr version
    exitSuccess

  when (optLength opts == 0) exitSuccess    -- Nothing to do

  putStrLn (generate opts gen)

elocryptOpts :: [String] -> IO Options
elocryptOpts args = do
  (opts, nonopts) <- elocryptOpts' args

  return $ case nonopts of
    (o : os : _) -> opts { optLength = read o, optMaxLength = read os }
    (o : _) -> opts { optLength = read o }
    [] -> opts

elocryptOpts' :: [String] -> IO (Options, [String])
elocryptOpts' args = case getOpt Permute options args of
  (opts, nonopts, []) -> do
    let opts' = foldl (flip id) defaultOptions opts
    return (opts', nonopts)

  (_, _, errs) -> do
    hPutStrLn stderr (concat errs)
    hPutStrLn stderr usage
    exitFailure

generate :: RandomGen g => Options -> g -> String
generate opts@Options { optPassType = Word } = passwords opts
generate opts@Options { optPassType = Phrase } = passphrases opts

passwords :: RandomGen g => Options -> g -> String
passwords opts@Options { optLength = len, optNumber = n } gen =
  format "  " . groupWith splitAt' width "  " $ ps
  where
    ps = newPasswords len num (getGenOptions opts) gen
    cols = columns len
    num = fromMaybe (nWords cols) n
    width = max termLen (len + 2)

passphrases :: RandomGen g => Options -> g -> String
passphrases opts@Options { optCapitals = caps, optLength = minLen, optMaxLength = maxLen, optNumber = n } gen
  = format " " . take lines' . groupWith splitAt' width " " $ passphrase
  where
    passphrase = newPassphrase words' minLen maxLen (getGenOptions opts) gen
    words' = columns minLen * lines'
    width = max termLen (maxLen + 1)
    lines' = fromMaybe termHeight n

getGenOptions :: Options -> GenOptions
getGenOptions Options { optCapitals = caps } =
  genOptions { genCapitals = caps }

usage :: String
usage = usageInfo (intercalate "\n" headerLines) options
  where
    headerLines =
      [ "Usage: elocrypt [option...] length"
      , "       elocrypt -p [option...] min-length max-length"
      ]

-- Utilities

-- Calculate the number of passwords to print per line
columns :: Int -> Int
columns len
  | len <= termLen - 2 = termLen `div` (len + 2)
  | otherwise = 1

-- Format a 2D list of Strings,
--  1 list per line
format :: String -> [[String]] -> String
format sep = intercalate "\n" . map (intercalate sep)

-- Calculate the number of words to print
nWords :: Int -> Int
nWords cols = termHeight * cols

-- Group a 2D array with a function by total length
groupWith
  :: (Int -> [a] -> [[a]] -> ([[a]], [[a]])) -> Int -> [a] -> [[a]] -> [[[a]]]
groupWith _ _ _ [] = []
groupWith f i sep ls
  | null groups = [[head ls]]
  | otherwise = groups
  where groups = groupWith' f i sep ls

groupWith'
  :: (Int -> [a] -> [[a]] -> ([[a]], [[a]])) -> Int -> [a] -> [[a]] -> [[[a]]]
groupWith' _ _ _ [] = []
groupWith' f i sep ls = g : groupWith f i sep ls' where (g, ls') = f i sep ls

-- Split a 2D array by the total length
splitAt' :: Int -> [a] -> [[a]] -> ([[a]], [[a]])
splitAt' 0 _ ls = ([], ls)
splitAt' _ _ [] = ([], [])
splitAt' n sep (l : ls)
  | n >= length l + sl = (l : xs, xs')
  | otherwise = ([], l : ls)
  where
    (xs, xs') = splitAt' (n - length l - sl) sep ls
    sl = length sep