{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module Password (
PWDatabase, PWData(..), PWPolicy (..), PWSalt (..),
pwPolicy, pwSalt,
pwLength, pwUpper, pwLower, pwDigits, pwSpecial,
newPWDatabase, newPWData, newPWPolicy, newPWSalt,
validatePWDatabase, validatePWData, validatePWPolicy,
pwGenerate,
pwCountUpper, pwCountLower, pwCountDigits, pwCountSpecial, pwCount,
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 Data.Either (fromRight)
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)
type PWDatabase = M.Map String PWData
data PWData = PWData
{ PWData -> PWPolicy
_pwPolicy :: PWPolicy
, PWData -> PWSalt
_pwSalt :: PWSalt
} deriving (PWData -> PWData -> Bool
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
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)
data PWPolicy = PWPolicy
{ PWPolicy -> Int
_pwLength :: Int
, PWPolicy -> Int
_pwUpper :: Int
, PWPolicy -> Int
_pwLower :: Int
, PWPolicy -> Int
_pwDigits :: Int
, PWPolicy -> Maybe Int
_pwSpecial :: Maybe Int
} deriving (PWPolicy -> PWPolicy -> Bool
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
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)
newtype PWSalt = PWSalt { PWSalt -> ByteString
runPWSalt :: B.ByteString }
deriving (PWSalt -> PWSalt -> Bool
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
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)
makeLenses ''PWPolicy
makeLenses ''PWData
instance FromJSON PWData where
parseJSON :: Value -> Parser PWData
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PWData" forall a b. (a -> b) -> a -> b
$ \Object
v -> PWPolicy -> PWSalt -> PWData
PWData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"policy"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"salt"
instance FromJSON PWPolicy where
parseJSON :: Value -> Parser PWPolicy
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PWPolicy" forall a b. (a -> b) -> a -> b
$ \Object
v -> Int -> Int -> Int -> Int -> Maybe Int -> PWPolicy
PWPolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"length"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"min_upper"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"min_lower"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"min_digits"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"min_special"
instance FromJSON PWSalt where
parseJSON :: Value -> Parser PWSalt
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"PWSalt" forall a b. (a -> b) -> a -> b
$ \Text
v ->
case ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ String -> ByteString
toUTF8 forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
v of
Left String
x -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
x
Right ByteString
x -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
[ Key
"policy" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (PWData
dforall s a. s -> Getting a s a -> a
^.Lens' PWData PWPolicy
pwPolicy)
, Key
"salt" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (PWData
dforall s a. s -> Getting a s a -> a
^.Lens' PWData PWSalt
pwSalt)
]
instance ToJSON PWPolicy where
toJSON :: PWPolicy -> Value
toJSON PWPolicy
p = [Pair] -> Value
object
[ Key
"length" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (PWPolicy
pforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwLength)
, Key
"min_upper" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (PWPolicy
pforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwUpper)
, Key
"min_lower" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (PWPolicy
pforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwLower)
, Key
"min_digits" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (PWPolicy
pforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwDigits)
, Key
"min_special" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (PWPolicy
pforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy (Maybe Int)
pwSpecial)
]
instance ToJSON PWSalt where
toJSON :: PWSalt -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
toB64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. PWSalt -> ByteString
runPWSalt
newPWDatabase :: PWDatabase
newPWDatabase :: PWDatabase
newPWDatabase = forall k a. Map k a
M.empty
newPWData
:: RandomGen g
=> g
-> (PWData, g)
newPWData :: forall g. RandomGen g => 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') = forall g. RandomGen g => g -> (PWSalt, g)
newPWSalt g
g
newPWPolicy :: PWPolicy
newPWPolicy :: PWPolicy
newPWPolicy = Int -> Int -> Int -> Int -> Maybe Int -> PWPolicy
PWPolicy Int
16 Int
0 Int
0 Int
0 (forall a. a -> Maybe a
Just Int
0)
newPWSalt
:: RandomGen g
=> g
-> (PWSalt, g)
newPWSalt :: forall g. RandomGen g => g -> (PWSalt, g)
newPWSalt g
g = (PWSalt
result, g
g2) where
result :: PWSalt
result = ByteString -> PWSalt
PWSalt forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
32 forall a b. (a -> b) -> a -> b
$ forall a g. (Random a, RandomGen g) => g -> [a]
randoms g
g1
(g
g1, g
g2) = forall g. RandomGen g => g -> (g, g)
split g
g
validatePWDatabase
:: PWDatabase
-> Bool
validatePWDatabase :: PWDatabase -> Bool
validatePWDatabase = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PWData -> Bool
validatePWData
validatePWData
:: PWData
-> Bool
validatePWData :: PWData -> Bool
validatePWData PWData
x =
PWPolicy -> Bool
validatePWPolicy (PWData
xforall s a. s -> Getting a s a -> a
^.Lens' PWData PWPolicy
pwPolicy) Bool -> Bool -> Bool
&&
ByteString -> Int64
B.length (PWData
xforall s a. s -> Getting a s a -> a
^.Lens' PWData PWSalt
pwSaltforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PWSalt -> ByteString
runPWSalt) forall a. Ord a => a -> a -> Bool
> Int64
0
validatePWPolicy
:: PWPolicy
-> Bool
validatePWPolicy :: PWPolicy -> Bool
validatePWPolicy PWPolicy
x = forall (t :: * -> *). Foldable t => t Bool -> Bool
and
[ Int
needed forall a. Ord a => a -> a -> Bool
<= PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwLength
, PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwLength forall a. Ord a => a -> a -> Bool
>= Int
0
, PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwUpper forall a. Ord a => a -> a -> Bool
>= Int
0
, PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwLower forall a. Ord a => a -> a -> Bool
>= Int
0
, PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwDigits forall a. Ord a => a -> a -> Bool
>= Int
0
, forall a. a -> Maybe a -> a
fromMaybe Int
0 (PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy (Maybe Int)
pwSpecial) forall a. Ord a => a -> a -> Bool
>= Int
0
] where
needed :: Int
needed = PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwUpper forall a. Num a => a -> a -> a
+ PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwLower forall a. Num a => a -> a -> a
+ PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwDigits forall a. Num a => a -> a -> a
+ Int
special
special :: Int
special = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ PWPolicy
xforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy (Maybe Int)
pwSpecial
pwGenerate
:: String
-> PWData
-> Maybe String
pwGenerate :: String -> PWData -> Maybe String
pwGenerate String
pw PWData
d = if PWData -> Bool
validatePWData PWData
d
then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> PWPolicy -> String
mkPass (ByteString -> String
mkPool ByteString
seed) (PWData
dforall s a. s -> Getting a s a -> a
^.Lens' PWData PWPolicy
pwPolicy)
else forall a. Maybe a
Nothing
where seed :: ByteString
seed = String -> PWData -> ByteString
mkSeed String
pw PWData
d
pwCountUpper
:: String
-> Int
pwCountUpper :: String -> Int
pwCountUpper = (Char -> Bool) -> String -> Int
pwCount Char -> Bool
isUpper
pwCountLower
:: String
-> Int
pwCountLower :: String -> Int
pwCountLower = (Char -> Bool) -> String -> Int
pwCount Char -> Bool
isLower
pwCountDigits
:: String
-> Int
pwCountDigits :: String -> Int
pwCountDigits = (Char -> Bool) -> String -> Int
pwCount Char -> Bool
isDigit
pwCountSpecial
:: String
-> Int
pwCountSpecial :: String -> Int
pwCountSpecial = (Char -> Bool) -> String -> Int
pwCount Char -> Bool
isSpecial
pwCount
:: (Char -> Bool)
-> String
-> Int
pwCount :: (Char -> Bool) -> String -> Int
pwCount Char -> Bool
f = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
f
pwHasService
:: String
-> PWDatabase
-> Bool
pwHasService :: String -> PWDatabase -> Bool
pwHasService String
x PWDatabase
db = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
x forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys PWDatabase
db
pwSetService
:: String
-> PWData
-> PWDatabase
-> PWDatabase
pwSetService :: String -> PWData -> PWDatabase -> PWDatabase
pwSetService = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
pwGetService
:: String
-> PWDatabase
-> Maybe PWData
pwGetService :: String -> PWDatabase -> Maybe PWData
pwGetService = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup
pwRemoveService
:: String
-> PWDatabase
-> PWDatabase
pwRemoveService :: String -> PWDatabase -> PWDatabase
pwRemoveService = forall k a. Ord k => k -> Map k a -> Map k a
M.delete
pwSearch
:: String
-> PWDatabase
-> [String]
pwSearch :: String -> PWDatabase -> [String]
pwSearch String
x PWDatabase
db = forall a. (a -> Bool) -> [a] -> [a]
filter (\String
y -> ShowS
l String
y String -> String -> Bool
`contains` ShowS
l String
x) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys PWDatabase
db where
l :: ShowS
l = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
isSpecial :: Char -> Bool
isSpecial :: Char -> Bool
isSpecial = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlphaNum
mkPass :: String -> PWPolicy -> String
mkPass :: String -> PWPolicy -> String
mkPass [] PWPolicy
_ = String
""
mkPass (Char
x:String
xs) PWPolicy
p = if PWPolicy
pforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy Int
pwLength 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 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 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
dforall s a. s -> Getting a s a -> a
^.Lens' PWData PWSalt
pwSaltforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PWSalt -> ByteString
runPWSalt)
mkHash :: B.ByteString -> B.ByteString
mkHash :: ByteString -> ByteString
mkHash = forall b a. b -> Either a b -> b
fromRight ByteString
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
B16.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
toUTF8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show 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 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' PWPolicy Int
pwLength forall a. Enum a => a -> a
pred forall a b. (a -> b) -> a -> b
$
if Char -> Bool
isUpper Char
x
then forall {b} {t}.
(Ord b, Num b, Enum b) =>
ASetter PWPolicy t b b -> t
dec Lens' PWPolicy Int
pwUpper
else if Char -> Bool
isLower Char
x
then forall {b} {t}.
(Ord b, Num b, Enum b) =>
ASetter PWPolicy t b b -> t
dec Lens' PWPolicy Int
pwLower
else if Char -> Bool
isDigit Char
x
then forall {b} {t}.
(Ord b, Num b, Enum b) =>
ASetter PWPolicy t b b -> t
dec Lens' PWPolicy Int
pwDigits
else case PWPolicy
pforall s a. s -> Getting a s a -> a
^.Lens' PWPolicy (Maybe Int)
pwSpecial of
Maybe Int
Nothing -> forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' PWPolicy (Maybe Int)
pwSpecial (forall a. a -> Maybe a
Just (-Int
1)) PWPolicy
p
Just Int
_ -> forall {b} {t}.
(Ord b, Num b, Enum b) =>
ASetter PWPolicy t b b -> t
dec forall a b. (a -> b) -> a -> b
$ Lens' PWPolicy (Maybe Int)
pwSpecial forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter PWPolicy t b b
l (forall a. Ord a => a -> a -> a
max b
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
pred) PWPolicy
p
toUTF8 :: String -> B.ByteString
toUTF8 :: String -> ByteString
toUTF8 = Builder -> ByteString
toLazyByteString 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 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 forall a. Eq a => a -> a -> Bool
== Char
y = String
xs String -> String -> Bool
`startsWith` String
ys
| Bool
otherwise = Bool
False