passman/src/Password.hs

{-|

Module:      Password
Description: a simple password manager
Copyright:   (C) 2018, 2019 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 #-}
{-# LANGUAGE OverloadedStrings #-}

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, pwCount,
  -- ** Database Functions
  pwHasService, pwSetService, pwGetService, pwRemoveService, pwSearch
  ) where

import Control.Lens (makeLenses, over, set, (^.))
import Data.Aeson
  ( FromJSON (parseJSON)
  , ToJSON (toJSON)
  , Value (String)
  , object
  , withObject
  , withText
  , (.:)
  , (.=)
  )
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Base16.Lazy as B16
import qualified Data.ByteString.Base64.Lazy as B64
import Data.Char (isUpper, isLower, isDigit, isAlphaNum, toLower)
import Data.Digest.Pure.SHA
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import qualified Data.Text as T'
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
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

instance FromJSON PWData where
  parseJSON = withObject "PWData" $ \v -> PWData
    <$> v .: "policy"
    <*> v .: "salt"

instance FromJSON PWPolicy where
  parseJSON = withObject "PWPolicy" $ \v -> PWPolicy
    <$> v .: "length"
    <*> v .: "min_upper"
    <*> v .: "min_lower"
    <*> v .: "min_digits"
    <*> v .: "min_special"

instance FromJSON B.ByteString where
  parseJSON = withText "ByteString" $ \v ->
    case B64.decode $ encodeUtf8 $ T.pack $ T'.unpack v of
      Left x  -> fail x
      Right x -> return x

instance ToJSON PWData where
  toJSON d = object
    [ "policy" .= (d^.pwPolicy)
    , "salt" .= (d^.pwSalt)
    ]

instance ToJSON PWPolicy where
  toJSON p = object
    [ "length" .= (p^.pwLength)
    , "min_upper" .= (p^.pwUpper)
    , "min_lower" .= (p^.pwLower)
    , "min_digits" .= (p^.pwDigits)
    , "min_special" .= (p^.pwSpecial)
    ]

instance ToJSON B.ByteString where
  toJSON = toJSON . toB64

-- | 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 32 $ 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 = pwCount isUpper

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

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

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

-- | counts characters matching a specific constraint
pwCount
  :: (Char -> Bool)
  -- ^ the constraint
  -> String
  -- ^ the string being checked
  -> Int
  -- ^ the count
pwCount f = length . filter f

-- | checks to see if a service is in the database
pwHasService
  :: String
  -- ^ the service name
  -> PWDatabase
  -- ^ the database to check
  -> Bool
  -- ^ returns @"True"@ if found; @"False"@ otherwise
pwHasService x db = elem x $ M.keys db

-- | adds a service to the database, or overwrites an existing one
pwSetService
  :: String
  -- ^ the service name
  -> PWData
  -- ^ the password data for the service
  -> PWDatabase
  -- ^ the database to add to
  -> PWDatabase
  -- ^ the resulting database
pwSetService = M.insert

-- | attempts to get a service from the database
pwGetService
  :: String
  -- ^ the service name
  -> PWDatabase
  -- ^ the database to check
  -> Maybe PWData
  -- ^ the service's password data, or @"Nothing"@ if the service is
  -- not found
pwGetService = M.lookup

-- | removes a service from the database
pwRemoveService
  :: String
  -- ^ the service being removed
  -> PWDatabase
  -- ^ the database the service is being removed from
  -> PWDatabase
  -- ^ the resulting database
pwRemoveService = M.delete

-- | searches for a service
pwSearch
  :: String
  -- ^ the search string
  -> PWDatabase
  -- ^ the database to search
  -> [String]
  -- ^ the matching service names
pwSearch x db = filter (\y -> l y `contains` l x) $ M.keys db where
  l = map toLower

isSpecial :: Char -> Bool
isSpecial = not . isAlphaNum

mkPass :: String -> PWPolicy -> String
mkPass [] _ = "" -- this should never happen
mkPass (x:xs) p = if p^.pwLength <= 0
  then ""
  else let p' = nextPolicy x p in
    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 = fst . B16.decode . encodeUtf8 . T.pack . show . sha256

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 = encodeUtf8 . T.pack

toB64 :: B.ByteString -> String
toB64 = T.unpack . decodeUtf8 . B64.encode

contains :: String -> String -> Bool
_ `contains` "" = True
"" `contains` _ = False
xs@(x:xs') `contains` ys
  | xs `startsWith` ys = True
  | otherwise = xs' `contains` ys

startsWith :: String -> String -> Bool
_ `startsWith` "" = True
"" `startsWith` _ = False
(x:xs) `startsWith` (y:ys)
  | x == y = xs `startsWith` ys
  | otherwise = False

--jl