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.0"
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 capital letters",

      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