{-|

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
  { PWData -> PWPolicy
_pwPolicy :: PWPolicy
  -- ^ the password policy
  , PWData -> PWSalt
_pwSalt :: PWSalt
  -- ^ random data used to generate the password
  } deriving (PWData -> PWData -> Bool
(PWData -> PWData -> Bool)
-> (PWData -> PWData -> Bool) -> Eq PWData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PWData -> PWData -> Bool
$c/= :: PWData -> PWData -> Bool
== :: PWData -> PWData -> Bool
$c== :: PWData -> PWData -> Bool
Eq, Int -> PWData -> ShowS
[PWData] -> ShowS
PWData -> String
(Int -> PWData -> ShowS)
-> (PWData -> String) -> ([PWData] -> ShowS) -> Show PWData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWData] -> ShowS
$cshowList :: [PWData] -> ShowS
show :: PWData -> String
$cshow :: PWData -> String
showsPrec :: Int -> PWData -> ShowS
$cshowsPrec :: Int -> PWData -> ShowS
Show)

-- | defines a password policy
data PWPolicy = PWPolicy
  { PWPolicy -> Int
_pwLength :: Int
  -- ^ password length
  , PWPolicy -> Int
_pwUpper :: Int
  -- ^ the minimum number of upper case characters
  , PWPolicy -> Int
_pwLower :: Int
  -- ^ the minimum number of lower case characters
  , PWPolicy -> Int
_pwDigits :: Int
  -- ^ the minimum number of digits
  , PWPolicy -> Maybe Int
_pwSpecial :: Maybe Int
  -- ^ the minimum number of non-alphanumeric characters (not allowed
  -- if @"Nothing"@)
  } deriving (PWPolicy -> PWPolicy -> Bool
(PWPolicy -> PWPolicy -> Bool)
-> (PWPolicy -> PWPolicy -> Bool) -> Eq PWPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PWPolicy -> PWPolicy -> Bool
$c/= :: PWPolicy -> PWPolicy -> Bool
== :: PWPolicy -> PWPolicy -> Bool
$c== :: PWPolicy -> PWPolicy -> Bool
Eq, Int -> PWPolicy -> ShowS
[PWPolicy] -> ShowS
PWPolicy -> String
(Int -> PWPolicy -> ShowS)
-> (PWPolicy -> String) -> ([PWPolicy] -> ShowS) -> Show PWPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWPolicy] -> ShowS
$cshowList :: [PWPolicy] -> ShowS
show :: PWPolicy -> String
$cshow :: PWPolicy -> String
showsPrec :: Int -> PWPolicy -> ShowS
$cshowsPrec :: Int -> PWPolicy -> ShowS
Show)

-- | the "salt" used to generate a password
newtype PWSalt = PWSalt { PWSalt -> ByteString
runPWSalt :: B.ByteString }
  deriving (PWSalt -> PWSalt -> Bool
(PWSalt -> PWSalt -> Bool)
-> (PWSalt -> PWSalt -> Bool) -> Eq PWSalt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PWSalt -> PWSalt -> Bool
$c/= :: PWSalt -> PWSalt -> Bool
== :: PWSalt -> PWSalt -> Bool
$c== :: PWSalt -> PWSalt -> Bool
Eq, Int -> PWSalt -> ShowS
[PWSalt] -> ShowS
PWSalt -> String
(Int -> PWSalt -> ShowS)
-> (PWSalt -> String) -> ([PWSalt] -> ShowS) -> Show PWSalt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWSalt] -> ShowS
$cshowList :: [PWSalt] -> ShowS
show :: PWSalt -> String
$cshow :: PWSalt -> String
showsPrec :: Int -> PWSalt -> ShowS
$cshowsPrec :: Int -> PWSalt -> ShowS
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 :: Value -> Parser PWData
parseJSON = String -> (Object -> Parser PWData) -> Value -> Parser PWData
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PWData" ((Object -> Parser PWData) -> Value -> Parser PWData)
-> (Object -> Parser PWData) -> Value -> Parser PWData
forall a b. (a -> b) -> a -> b
$ \Object
v -> PWPolicy -> PWSalt -> PWData
PWData
    (PWPolicy -> PWSalt -> PWData)
-> Parser PWPolicy -> Parser (PWSalt -> PWData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser PWPolicy
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"policy"
    Parser (PWSalt -> PWData) -> Parser PWSalt -> Parser PWData
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser PWSalt
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"salt"

instance FromJSON PWPolicy where
  parseJSON :: Value -> Parser PWPolicy
parseJSON = String -> (Object -> Parser PWPolicy) -> Value -> Parser PWPolicy
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PWPolicy" ((Object -> Parser PWPolicy) -> Value -> Parser PWPolicy)
-> (Object -> Parser PWPolicy) -> Value -> Parser PWPolicy
forall a b. (a -> b) -> a -> b
$ \Object
v -> Int -> Int -> Int -> Int -> Maybe Int -> PWPolicy
PWPolicy
    (Int -> Int -> Int -> Int -> Maybe Int -> PWPolicy)
-> Parser Int
-> Parser (Int -> Int -> Int -> Maybe Int -> PWPolicy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"length"
    Parser (Int -> Int -> Int -> Maybe Int -> PWPolicy)
-> Parser Int -> Parser (Int -> Int -> Maybe Int -> PWPolicy)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"min_upper"
    Parser (Int -> Int -> Maybe Int -> PWPolicy)
-> Parser Int -> Parser (Int -> Maybe Int -> PWPolicy)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"min_lower"
    Parser (Int -> Maybe Int -> PWPolicy)
-> Parser Int -> Parser (Maybe Int -> PWPolicy)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"min_digits"
    Parser (Maybe Int -> PWPolicy)
-> Parser (Maybe Int) -> Parser PWPolicy
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"min_special"

instance FromJSON PWSalt where
  parseJSON :: Value -> Parser PWSalt
parseJSON = String -> (Text -> Parser PWSalt) -> Value -> Parser PWSalt
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"PWSalt" ((Text -> Parser PWSalt) -> Value -> Parser PWSalt)
-> (Text -> Parser PWSalt) -> Value -> Parser PWSalt
forall a b. (a -> b) -> a -> b
$ \Text
v ->
    case ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
toUTF8 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
v of
      Left String
x  -> String -> Parser PWSalt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
x
      Right ByteString
x -> PWSalt -> Parser PWSalt
forall (m :: * -> *) a. Monad m => a -> m a
return (PWSalt -> Parser PWSalt) -> PWSalt -> Parser PWSalt
forall a b. (a -> b) -> a -> b
$ ByteString -> PWSalt
PWSalt ByteString
x

instance ToJSON PWData where
  toJSON :: PWData -> Value
toJSON PWData
d = [Pair] -> Value
object
    [ Text
"policy" Text -> PWPolicy -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PWData
dPWData -> Getting PWPolicy PWData PWPolicy -> PWPolicy
forall s a. s -> Getting a s a -> a
^.Getting PWPolicy PWData PWPolicy
Lens' PWData PWPolicy
pwPolicy)
    , Text
"salt" Text -> PWSalt -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PWData
dPWData -> Getting PWSalt PWData PWSalt -> PWSalt
forall s a. s -> Getting a s a -> a
^.Getting PWSalt PWData PWSalt
Lens' PWData PWSalt
pwSalt)
    ]

instance ToJSON PWPolicy where
  toJSON :: PWPolicy -> Value
toJSON PWPolicy
p = [Pair] -> Value
object
    [ Text
"length" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PWPolicy
pPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwLength)
    , Text
"min_upper" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PWPolicy
pPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwUpper)
    , Text
"min_lower" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PWPolicy
pPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwLower)
    , Text
"min_digits" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PWPolicy
pPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwDigits)
    , Text
"min_special" Text -> Maybe Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PWPolicy
pPWPolicy -> Getting (Maybe Int) PWPolicy (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Int) PWPolicy (Maybe Int)
Lens' PWPolicy (Maybe Int)
pwSpecial)
    ]

instance ToJSON PWSalt where
  toJSON :: PWSalt -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> (PWSalt -> String) -> PWSalt -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
toB64 (ByteString -> String)
-> (PWSalt -> ByteString) -> PWSalt -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PWSalt -> ByteString
runPWSalt

-- | default (empty) password database
newPWDatabase :: PWDatabase
newPWDatabase :: PWDatabase
newPWDatabase = PWDatabase
forall k a. Map k a
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 -> (PWData, g)
newPWData g
g = (PWData
result, g
g') where
  result :: PWData
result = PWPolicy -> PWSalt -> PWData
PWData PWPolicy
newPWPolicy PWSalt
salt
  (PWSalt
salt, g
g') = g -> (PWSalt, g)
forall g. RandomGen g => g -> (PWSalt, g)
newPWSalt g
g

-- | default password policy
newPWPolicy :: PWPolicy
newPWPolicy :: PWPolicy
newPWPolicy = Int -> Int -> Int -> Int -> Maybe Int -> PWPolicy
PWPolicy Int
16 Int
0 Int
0 Int
0 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)

-- | builds a new salt
newPWSalt
  :: RandomGen g
  => g
  -- ^ the random generator to use
  -> (PWSalt, g)
  -- ^ the result and new random generator
newPWSalt :: g -> (PWSalt, g)
newPWSalt g
g = (PWSalt
result, g
g2) where
  result :: PWSalt
result = ByteString -> PWSalt
PWSalt (ByteString -> PWSalt) -> ByteString -> PWSalt
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take Int
32 ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ g -> [Word8]
forall a g. (Random a, RandomGen g) => g -> [a]
randoms g
g1
  (g
g1, g
g2) = g -> (g, g)
forall g. RandomGen g => g -> (g, g)
split g
g

-- | validates a password database
validatePWDatabase
  :: PWDatabase
  -- ^ the database to be validated
  -> Bool
  -- ^ @"True"@ if valid; @"False"@ otherwise
validatePWDatabase :: PWDatabase -> Bool
validatePWDatabase = (PWData -> Bool) -> PWDatabase -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PWData -> Bool
validatePWData

-- | validates password data
validatePWData
  :: PWData
  -- ^ the data to be validated
  -> Bool
  -- ^ @"True"@ if valid; @"False"@ otherwise
validatePWData :: PWData -> Bool
validatePWData PWData
x =
  PWPolicy -> Bool
validatePWPolicy (PWData
xPWData -> Getting PWPolicy PWData PWPolicy -> PWPolicy
forall s a. s -> Getting a s a -> a
^.Getting PWPolicy PWData PWPolicy
Lens' PWData PWPolicy
pwPolicy) Bool -> Bool -> Bool
&&
  ByteString -> Int64
B.length (PWData
xPWData -> Getting ByteString PWData ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^.(PWSalt -> Const ByteString PWSalt)
-> PWData -> Const ByteString PWData
Lens' PWData PWSalt
pwSalt((PWSalt -> Const ByteString PWSalt)
 -> PWData -> Const ByteString PWData)
-> ((ByteString -> Const ByteString ByteString)
    -> PWSalt -> Const ByteString PWSalt)
-> Getting ByteString PWData ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PWSalt -> ByteString) -> SimpleGetter PWSalt ByteString
forall s a. (s -> a) -> SimpleGetter s a
to PWSalt -> ByteString
runPWSalt) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0

-- | validates a password policy
validatePWPolicy
  :: PWPolicy
  -- ^ the policy being validated
  -> Bool
  -- ^ indicates whether or not the policy is valid
validatePWPolicy :: PWPolicy -> Bool
validatePWPolicy PWPolicy
x = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
  [ Int
needed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= PWPolicy
xPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwLength
  , PWPolicy
xPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
  , PWPolicy
xPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwUpper Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
  , PWPolicy
xPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwLower Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
  , PWPolicy
xPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwDigits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
  , Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (PWPolicy
xPWPolicy -> Getting (Maybe Int) PWPolicy (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Int) PWPolicy (Maybe Int)
Lens' PWPolicy (Maybe Int)
pwSpecial) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
  ] where
    needed :: Int
needed = PWPolicy
xPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwUpper Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PWPolicy
xPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwLower Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PWPolicy
xPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwDigits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
special
    special :: Int
special = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ PWPolicy
xPWPolicy -> Getting (Maybe Int) PWPolicy (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Int) PWPolicy (Maybe Int)
Lens' PWPolicy (Maybe Int)
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 :: String -> PWData -> Maybe String
pwGenerate String
pw PWData
d = if PWData -> Bool
validatePWData PWData
d
  then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> PWPolicy -> String
mkPass (ByteString -> String
mkPool ByteString
seed) (PWData
dPWData -> Getting PWPolicy PWData PWPolicy -> PWPolicy
forall s a. s -> Getting a s a -> a
^.Getting PWPolicy PWData PWPolicy
Lens' PWData PWPolicy
pwPolicy)
  else Maybe String
forall a. Maybe a
Nothing
  where seed :: ByteString
seed = String -> PWData -> ByteString
mkSeed String
pw PWData
d

-- | counts upper case characters in a password
pwCountUpper
  :: String
  -- ^ the password
  -> Int
  -- ^ the count
pwCountUpper :: String -> Int
pwCountUpper = (Char -> Bool) -> String -> Int
pwCount Char -> Bool
isUpper

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

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

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

-- | counts characters matching a specific constraint
pwCount
  :: (Char -> Bool)
  -- ^ the constraint
  -> String
  -- ^ the string being checked
  -> Int
  -- ^ the count
pwCount :: (Char -> Bool) -> String -> Int
pwCount Char -> Bool
f = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> ShowS -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
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 :: String -> PWDatabase -> Bool
pwHasService String
x PWDatabase
db = String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ PWDatabase -> [String]
forall k a. Map k a -> [k]
M.keys PWDatabase
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 :: String -> PWData -> PWDatabase -> PWDatabase
pwSetService = String -> PWData -> PWDatabase -> PWDatabase
forall k a. Ord k => k -> a -> Map k a -> Map k a
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 :: String -> PWDatabase -> Maybe PWData
pwGetService = String -> PWDatabase -> Maybe PWData
forall k a. Ord k => k -> Map k a -> Maybe a
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 :: String -> PWDatabase -> PWDatabase
pwRemoveService = String -> PWDatabase -> PWDatabase
forall k a. Ord k => k -> Map k a -> Map k a
M.delete

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

isSpecial :: Char -> Bool
isSpecial :: Char -> Bool
isSpecial = Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlphaNum

mkPass :: String -> PWPolicy -> String
mkPass :: String -> PWPolicy -> String
mkPass [] PWPolicy
_ = String
"" -- this should never happen
mkPass (Char
x:String
xs) PWPolicy
p = if PWPolicy
pPWPolicy -> Getting Int PWPolicy Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int PWPolicy Int
Lens' PWPolicy Int
pwLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
  then String
""
  else let p' :: PWPolicy
p' = Char -> PWPolicy -> PWPolicy
nextPolicy Char
x PWPolicy
p in
    if PWPolicy -> Bool
validatePWPolicy PWPolicy
p'
    then Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String -> PWPolicy -> String
mkPass String
xs PWPolicy
p'
    else String -> PWPolicy -> String
mkPass String
xs PWPolicy
p

mkPool :: B.ByteString -> String
mkPool :: ByteString -> String
mkPool = ByteString -> String
toB64 (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
raw where
  raw :: ByteString -> ByteString
raw ByteString
x = let x' :: ByteString
x' = ByteString -> ByteString
mkHash ByteString
x in
    ByteString
x' ByteString -> ByteString -> ByteString
`B.append` ByteString -> ByteString
raw ByteString
x'

mkSeed :: String -> PWData ->B.ByteString
mkSeed :: String -> PWData -> ByteString
mkSeed String
pw PWData
d = String -> ByteString
toUTF8 String
pw ByteString -> ByteString -> ByteString
`B.append` (PWData
dPWData -> Getting ByteString PWData ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^.(PWSalt -> Const ByteString PWSalt)
-> PWData -> Const ByteString PWData
Lens' PWData PWSalt
pwSalt((PWSalt -> Const ByteString PWSalt)
 -> PWData -> Const ByteString PWData)
-> ((ByteString -> Const ByteString ByteString)
    -> PWSalt -> Const ByteString PWSalt)
-> Getting ByteString PWData ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PWSalt -> ByteString) -> SimpleGetter PWSalt ByteString
forall s a. (s -> a) -> SimpleGetter s a
to PWSalt -> ByteString
runPWSalt)

mkHash :: B.ByteString -> B.ByteString
mkHash :: ByteString -> ByteString
mkHash = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (ByteString, ByteString)
B16.decode (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
toUTF8 (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256State -> String
forall a. Show a => a -> String
show (Digest SHA256State -> String)
-> (ByteString -> Digest SHA256State) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA256State
sha256

nextPolicy :: Char -> PWPolicy -> PWPolicy
nextPolicy :: Char -> PWPolicy -> PWPolicy
nextPolicy Char
x PWPolicy
p = ASetter PWPolicy PWPolicy Int Int
-> (Int -> Int) -> PWPolicy -> PWPolicy
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter PWPolicy PWPolicy Int Int
Lens' PWPolicy Int
pwLength Int -> Int
forall a. Enum a => a -> a
pred (PWPolicy -> PWPolicy) -> PWPolicy -> PWPolicy
forall a b. (a -> b) -> a -> b
$
  if Char -> Bool
isUpper Char
x
  then ASetter PWPolicy PWPolicy Int Int -> PWPolicy
forall b t. (Ord b, Num b, Enum b) => ASetter PWPolicy t b b -> t
dec ASetter PWPolicy PWPolicy Int Int
Lens' PWPolicy Int
pwUpper
  else if Char -> Bool
isLower Char
x
  then ASetter PWPolicy PWPolicy Int Int -> PWPolicy
forall b t. (Ord b, Num b, Enum b) => ASetter PWPolicy t b b -> t
dec ASetter PWPolicy PWPolicy Int Int
Lens' PWPolicy Int
pwLower
  else if Char -> Bool
isDigit Char
x
  then ASetter PWPolicy PWPolicy Int Int -> PWPolicy
forall b t. (Ord b, Num b, Enum b) => ASetter PWPolicy t b b -> t
dec ASetter PWPolicy PWPolicy Int Int
Lens' PWPolicy Int
pwDigits
  else case PWPolicy
pPWPolicy -> Getting (Maybe Int) PWPolicy (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Int) PWPolicy (Maybe Int)
Lens' PWPolicy (Maybe Int)
pwSpecial of
    Maybe Int
Nothing -> ASetter PWPolicy PWPolicy (Maybe Int) (Maybe Int)
-> Maybe Int -> PWPolicy -> PWPolicy
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter PWPolicy PWPolicy (Maybe Int) (Maybe Int)
Lens' PWPolicy (Maybe Int)
pwSpecial (Int -> Maybe Int
forall a. a -> Maybe a
Just (-Int
1)) PWPolicy
p
    Just Int
_  -> ASetter PWPolicy PWPolicy Int Int -> PWPolicy
forall b t. (Ord b, Num b, Enum b) => ASetter PWPolicy t b b -> t
dec (ASetter PWPolicy PWPolicy Int Int -> PWPolicy)
-> ASetter PWPolicy PWPolicy Int Int -> PWPolicy
forall a b. (a -> b) -> a -> b
$ ASetter PWPolicy PWPolicy (Maybe Int) (Maybe Int)
Lens' PWPolicy (Maybe Int)
pwSpecial ASetter PWPolicy PWPolicy (Maybe Int) (Maybe Int)
-> ((Int -> Identity Int) -> Maybe Int -> Identity (Maybe Int))
-> ASetter PWPolicy PWPolicy Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int) -> Maybe Int -> Identity (Maybe Int)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
  where
    dec :: ASetter PWPolicy t b b -> t
dec ASetter PWPolicy t b b
l = ASetter PWPolicy t b b -> (b -> b) -> PWPolicy -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter PWPolicy t b b
l (b -> b -> b
forall a. Ord a => a -> a -> a
max b
0 (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
forall a. Enum a => a -> a
pred) PWPolicy
p

toUTF8 :: String -> B.ByteString
toUTF8 :: String -> ByteString
toUTF8 = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (String -> Builder) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
stringUtf8

toB64 :: B.ByteString -> String
toB64 :: ByteString -> String
toB64 = ByteString -> String
B8.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode

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

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

--jl