passman/src/Password.hs

{-|

Module:      Password
Description: a simple password manager
Copyright:   (C) 2018 Jonathan Lamothe
License:     LGPLv3 (or later)
Maintainer:  jlamothe1980@gmail.com

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this program.  If not, see
<https://www.gnu.org/licenses/>.

-}

{-# LANGUAGE TemplateHaskell #-}

module Password (
  -- * Data Types
  PWDatabase, PWData(..), PWPolicy (..), PWSalt,
  -- ** Lenses
  -- $lenses
  -- *** PWData
  pwPolicy, pwSalt,
  -- *** PWPolicy
  pwLength, pwUpper, pwLower, pwDigits, pwSpecial,
  -- ** Default Instances
  newPWDatabase, newPWData, newPWPolicy, newPWSalt,
  -- ** Validations
  validatePWDatabase, validatePWData, validatePWPolicy,
  -- * Functions
  -- ** Password Generator
  pwGenerate,
  -- ** Password Checkers
  pwCountUpper, pwCountLower, pwCountDigits, pwCountSpecial
  ) where

import Control.Lens (makeLenses, over, set, (^.))
import Data.Char (isUpper, isLower, isDigit, isAlphaNum)
import qualified Data.ByteString.Lazy as B
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import System.Random (RandomGen, randoms, split)

-- | a mapping of service names to password data
type PWDatabase = M.Map String PWData

-- | data necessary to construct a password
data PWData = PWData
  { _pwPolicy :: PWPolicy
  -- ^ the password policy
  , _pwSalt :: PWSalt
  -- ^ random data used to generate the password
  } deriving (Eq, Show)

-- | defines a password policy
data PWPolicy = PWPolicy
  { _pwLength :: Int
  -- ^ password length
  , _pwUpper :: Int
  -- ^ the minimum number of upper case characters
  , _pwLower :: Int
  -- ^ the minimum number of lower case characters
  , _pwDigits :: Int
  -- ^ the minimum number of digits
  , _pwSpecial :: Maybe Int
  -- ^ the minimum number of non-alphanumeric characters (not allowed
  -- if @"Nothing"@)
  } deriving (Eq, Show)

-- | the "salt" used to generate a password
type PWSalt = B.ByteString

-- $lenses The following functions are automatically generated by
-- @makeLenses@. See the
-- [lens](http://hackage.haskell.org/package/lens) package for further
-- details.

makeLenses ''PWPolicy
makeLenses ''PWData

-- | default (empty) password database
newPWDatabase :: PWDatabase
newPWDatabase = M.empty

-- | builds a new @'PWData'@
newPWData
  :: RandomGen g
  => g
  -- ^ the random generator to use
  -> (PWData, g)
  -- ^ the result and new random generator
newPWData g = (result, g') where
  result = PWData newPWPolicy salt
  (salt, g') = newPWSalt g

-- | default password policy
newPWPolicy :: PWPolicy
newPWPolicy = PWPolicy 16 0 0 0 (Just 0)

-- | builds a new salt
newPWSalt
  :: RandomGen g
  => g
  -- ^ the random generator to use
  -> (PWSalt, g)
  -- ^ the result and new random generator
newPWSalt g = (result, g2) where
  result = B.pack $ take 256 $ randoms g1
  (g1, g2) = split g

-- | validates a password database
validatePWDatabase
  :: PWDatabase
  -- ^ the database to be validated
  -> Bool
  -- ^ @"True"@ if valid; @"False"@ otherwise
validatePWDatabase = all validatePWData

-- | validates password data
validatePWData
  :: PWData
  -- ^ the data to be validated
  -> Bool
  -- ^ @"True"@ if valid; @"False"@ otherwise
validatePWData x =
  validatePWPolicy (x^.pwPolicy) &&
  B.length (x^.pwSalt) > 0

-- | validates a password policy
validatePWPolicy
  :: PWPolicy
  -- ^ the policy being validated
  -> Bool
  -- ^ indicates whether or not the policy is valid
validatePWPolicy x = and
  [ needed <= x^.pwLength
  , x^.pwLength >= 0
  , x^.pwUpper >= 0
  , x^.pwLower >= 0
  , x^.pwDigits >= 0
  , fromMaybe 0 (x^.pwSpecial) >= 0
  ] where
    needed = x^.pwUpper + x^.pwLower + x^.pwDigits + special
    special = fromMaybe 0 $ x^.pwSpecial

-- | generates a password
pwGenerate
  :: String
  -- ^ the master password
  -> PWData
  -- ^ the password parameters
  -> Maybe String
  -- ^ the resulting password, if possible; @"Nothing"@ if the data is
  -- invalid
pwGenerate pw d = if validatePWData d
  then Just $ mkPass (mkPool seed) (d^.pwPolicy)
  else Nothing
  where seed = mkSeed pw d

-- | counts upper case characters in a password
pwCountUpper
  :: String
  -- ^ the password
  -> Int
  -- ^ the count
pwCountUpper = length . filter isUpper

-- | counts lower case characters in a password
pwCountLower
  :: String
  -- ^ the password
  -> Int
  -- ^ the count
pwCountLower = length . filter isLower

-- | counts digits in a password
pwCountDigits
  :: String
  -- ^ the password
  -> Int
  -- ^ the count
pwCountDigits = length . filter isDigit

-- | counts special characters in a password
pwCountSpecial
  :: String
  -- ^ the password
  -> Int
  -- ^ the count
pwCountSpecial = length . filter isSpecial

isSpecial :: Char -> Bool
isSpecial x = not $ isUpper x || isLower x || isDigit x

mkPass :: String -> PWPolicy -> String
mkPass (x:xs) p = let p' = nextPolicy x p in
  if p^.pwLength <= 0
  then ""
  else if validatePWPolicy p'
  then x : mkPass xs p'
  else mkPass xs p

mkPool :: B.ByteString -> String
mkPool = toB64 . raw where
  raw x = let x' = mkHash x in
    x' `B.append` raw x

mkSeed :: String -> PWData -> B.ByteString
mkSeed pw d = toUTF8 pw `B.append` (d^.pwSalt)

mkHash :: B.ByteString -> B.ByteString
mkHash = undefined

nextPolicy :: Char -> PWPolicy -> PWPolicy
nextPolicy x p = over pwLength pred $
  if isUpper x
  then dec pwUpper
  else if isLower x
  then dec pwLower
  else if isDigit x
  then dec pwDigits
  else case p^.pwSpecial of
    Nothing -> set pwSpecial (Just (-1)) p
    Just _  -> dec $ pwSpecial . traverse
  where
    dec l = over l (max 0 . pred) p

toUTF8 :: String -> B.ByteString
toUTF8 = undefined

toB64 :: B.ByteString -> String
toB64 = undefined

--jl