passman/src/Password.hs

{-|

Module:      Password
Description: a simple password manager
Copyright:   (C) 2018-2021 Jonathan Lamothe
License:     LGPLv3 (or later)
Maintainer:  jonathan@jlamothe.net

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 Data.Aeson
  ( FromJSON (parseJSON)
  , ToJSON (toJSON)
  , object
  , withObject
  , withText
  , (.:)
  , (.=)
  )
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.ByteString.Builder (toLazyByteString, stringUtf8)
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 Lens.Micro (over, set, to, (^.))
import Lens.Micro.TH (makeLenses)
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
newtype PWSalt = PWSalt { runPWSalt :: B.ByteString }
  deriving (Eq, Show)

-- $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 PWSalt where
  parseJSON = withText "PWSalt" $ \v ->
    case B64.decode $ toUTF8 $ T.unpack v of
      Left x  -> fail x
      Right x -> return $ PWSalt 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 PWSalt where
  toJSON = toJSON . toB64 . runPWSalt

-- | 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 = PWSalt $ 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.to runPWSalt) > 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.to runPWSalt)

mkHash :: B.ByteString -> B.ByteString
mkHash = fst . B16.decode . toUTF8 . 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 = toLazyByteString . stringUtf8

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

contains :: String -> String -> Bool
_ `contains` "" = True
"" `contains` _ = False
xs@(_: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