Schemas.hs

{-# LANGUAGE BangPatterns #-}

{- | This module defines `Schema`s,
     which can generate passwords. -}
module Scat.Schemas
    (
    -- * Type
      Schema

    -- ** Constructors
    , withDefaultSize
    , ignoreSize

    -- ** Destructor
    , getBuilder

    -- * Built-in schemas

    -- ** Passwords
    , safe
    , alphanumeric
    , paranoiac

    -- ** PIN
    , pin

    -- ** Pass phrases
    , pokemons
    , diceware

    -- ** Pattern lock
    , androidPatternLock
    ) where

import Data.Functor ((<$>))
import Data.Ratio ((%))
import Data.Monoid ((<>))
import Data.List (intercalate, (\\))
import Data.Vector (Vector)
import qualified Data.Vector as V
import Control.Monad (replicateM)
import System.IO

import Scat.Builder

import Paths_scat

-- | Password builder.
data Schema = Schema
    { defaultSize :: Int
    , builder     :: Int -> Builder String }

-- | Returns a `Builder` given an optional size.
getBuilder :: Schema -> Maybe Int -> Builder String
getBuilder schema Nothing  = builder schema $ defaultSize schema
getBuilder schema (Just s) = builder schema s

-- | Specifies the Schema will not be sensible to any size parameter.
ignoreSize :: Builder String -> Schema
ignoreSize = Schema undefined . const

-- | Specifies the Schema accepts a size parameter.
withDefaultSize :: Int -> (Int -> Builder String) -> Schema
withDefaultSize = Schema

-- | Paranoiac mode, entropy of 512 bits with the default size of 78.
paranoiac :: Schema
paranoiac = withDefaultSize 78 $ \ s -> replicateM s ascii

{- | Generates a password,
     containing upper case letters,
     lower case letters,
     digits and symbols.
     Entropy of about 115 bits for length 18. -}
safe :: Schema
safe = withDefaultSize 18 $ \ s -> do
    let number = max s 4
        lBound = max 1 $ floor $ number % 8
        uBound = ceiling $ number % 4
    nUpper <- inRange (lBound, uBound)
    nDigit <- inRange (lBound, uBound)
    nSpecial <- inRange (lBound, uBound)
    let nLower = number - nUpper - nSpecial - nDigit
    uppers <- replicateM nUpper upper
    digits <- replicateM nDigit digit
    specials <- replicateM nSpecial special
    lowers <- replicateM nLower lower
    shuffle (uppers <> digits <> specials <> lowers)

{- | Generates a password,
     containing upper case letters,
     lower case letters and
     digits, but no symbols.
     Entropy of about 104.2 bits for length 18. -}
alphanumeric :: Schema
alphanumeric = withDefaultSize 18 $ \ s -> do
    let number = max s 4
        lBound = max 1 $ floor $ number % 8
        uBound = ceiling $ number % 4
    nUpper <- inRange (lBound, uBound)
    nDigit <- inRange (lBound, uBound)
    let nLower = number - nUpper - nDigit
    uppers <- replicateM nUpper upper
    digits <- replicateM nDigit digit
    lowers <- replicateM nLower lower
    shuffle (uppers <> digits <> lowers)

{- | Generates a PIN number, of length `n`.
     Entropy of about @3.32 * n@ bits. -}
pin :: Schema
pin = withDefaultSize 6 $ \ s -> replicateM s digit

-- | Generates an Android lock pattern.
androidPatternLock :: Schema
androidPatternLock = withDefaultSize 9 $ \ s -> do
    xs <- loop (min s (height * width)) []
    return $ intercalate " - " $ map showPosition xs
  where
    -- Gets `n` points.
    loop :: Int -> [(Int, Int)] -> Builder [(Int, Int)]
    loop n xs | n <= 0 = return $ reverse xs
    loop n xs = do
        x <- oneOf $ possibilities xs
        loop (n - 1) (x : xs)

    -- Grid dimensions.
    height = 3
    width = 3

    -- Text representation for a position.
    showPosition (1, 1) = "center"
    showPosition (i, j) = vshow i ++ hshow j
      where
        vshow 0 = "north"
        vshow 1 = ""
        vshow _ = "south"

        hshow 0 = "west"
        hshow 1 = ""
        hshow _ = "east"

    -- All positions.
    allPositions = [(i, j) | i <- [0 .. height - 1], j <- [0 .. width - 1]]

    {- Possible positions given a list of already used ones.
       The head of the list is the last used position. -}
    possibilities [] = allPositions
    possibilities pps@(p : ps) = filter isPossible candidates
      where
        candidates = allPositions \\ pps

        isPossible q = all (`elem` ps) $ interfere p q

    -- The list of positions that are on the way between two positions.
    interfere (i, j) (k, l) = do
        r <- [1 .. steps - 1]
        return (i + r * vstep, j + r * hstep)
      where
        vdiff = k - i
        hdiff = l - j

        steps = gcd vdiff hdiff

        vstep = vdiff `div` steps
        hstep = hdiff `div` steps

{- | Generates a password with `s` of the original Pokemons and their level.
     Entropy of about 55.5 bits for 4 pokemons. -}
pokemons :: IO Schema
pokemons = fromFile "pokemons.txt" $ \ vect ->
    withDefaultSize 4 $ \ s -> do
        ps <- replicateM s $ oneOfV vect
        ls <- replicateM s $ inRange (1, 100 :: Int)
        let ss = zipWith (\ p l -> p ++ " " ++ show l) ps ls
        return $ intercalate ", " ss

{- | Generates a password with `s` words
     from the Diceware list.
     Entropy of about 64.6 bits for 5 words. -}
diceware :: IO Schema
diceware = fromFile "diceware.txt" $ \ vect ->
    withDefaultSize 5 $ \ s -> do
        ws <- replicateM s $ oneOfV vect
        return $ unwords ws

-- | Feeds all lines of a file to a function and gets the result.
fromFile :: FilePath -> (Vector String -> a) -> IO a
fromFile fp bs = do
    fp' <- getDataFileName fp
    withFile fp' ReadMode $ \ h -> do
        !vect <- (V.fromList . lines) <$> hGetContents h
        return $ bs vect