Diceware

Here is a program that generates diceware passwords.

import Data.Bifunctor
import Data.List
import Data.Maybe
import System.Environment
import System.IO
import System.Random
import qualified Data.Map as Map

All the I/O is here in the entry point; the rest is pure. Here’s how to call it:

λ> diceware 6 "-"
pulp-turk-nn-trip-aloof-nadir

diceware :: Int -> String -> IO ()
diceware num sep =
  readFile wordList >>=
  getStdRandom . genPass num sep . parseFile >>=
  putStrLn

Or here’s an entry point that uses command-line arguments:

main :: IO ()
main = do
  let usage = "Usage: diceware NUM-WORDS SEPARATOR-STRING"
  args <- getArgs
  case args of
    [numStr, sepStr] ->
      case reads numStr of
        [(num, "")] -> diceware num sepStr
        _ -> putStrLn usage
    _ -> putStrLn usage

You can run that from a terminal using:

% runhaskell A09Sol.lhs 5 "$"
police$keyed$mule$i's$berea

or simulate sending arguments to the main program in GHCi like this:

λ> withArgs ["5", "/"] main
feat/xg/drop/hanna/cony

In the terminal, if you want an empty string for the separator, you have to put empty quotes:

% runhaskell A09Sol.lhs 5 ""
availlaban19thbathbelch
% runhaskell A09Sol.lhs 5
Usage: diceware NUM-WORDS SEPARATOR-STRING

wordList :: FilePath
wordList = "/home/league/tmp/diceware.wordlist.asc"

type Gen s a = s -> (a, s)

data OneDie = OneDie Int
  deriving (Eq, Show, Ord)

type Dice = [OneDie]

rollDie :: RandomGen s => Gen s OneDie
rollDie = first OneDie . randomR (1,6)

iterGen :: Gen s a -> Int -> Gen s [a]
iterGen gen n s0 =
  case compare n 0 of
    LT -> error "iterGen: negative length"
    EQ -> ([], s0)
    GT -> (x:xs, s2)
      where
        (x, s1) = gen s0
        (xs, s2) = iterGen gen (n-1) s1

numDice :: Int
numDice = 5

rollDice :: RandomGen s => Gen s Dice
rollDice = iterGen rollDie numDice

parseRoll :: Char -> Maybe OneDie
parseRoll c
  | c >= '1' && c <= '6' = Just (OneDie (fromEnum c - fromEnum '0'))
  | otherwise = Nothing

parseRolls :: String -> Maybe Dice
parseRolls = mapM parseRoll

chopTab :: String -> Maybe String
chopTab ('\t':s) = Just s
chopTab _ = Nothing

parseEntry :: String -> Maybe (Dice, String)
parseEntry line = do
  let (r, w) = break (== '\t') line
  dice <- parseRolls r
  word <- chopTab w
  return (dice, word)

type WordMap = Map.Map Dice String

parseFile :: String -> WordMap
parseFile = Map.fromList . mapMaybe parseEntry . lines

genPass :: RandomGen s => Int -> String -> WordMap -> Gen s String
genPass numWords sep wordMap =
  first (intercalate sep . mapMaybe getWord) . iterGen rollDice numWords
  where
    getWord dice = Map.lookup dice wordMap