{-# 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 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)
type PWDatabase = M.Map String PWData
data PWData = PWData
{ _pwPolicy :: PWPolicy
, _pwSalt :: PWSalt
} deriving (Eq, Show)
data PWPolicy = PWPolicy
{ _pwLength :: Int
, _pwUpper :: Int
, _pwLower :: Int
, _pwDigits :: Int
, _pwSpecial :: Maybe Int
} deriving (Eq, Show)
type PWSalt = B.ByteString
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
newPWDatabase :: PWDatabase
newPWDatabase = M.empty
newPWData
:: RandomGen g
=> g
-> (PWData, g)
newPWData g = (result, g') where
result = PWData newPWPolicy salt
(salt, g') = newPWSalt g
newPWPolicy :: PWPolicy
newPWPolicy = PWPolicy 16 0 0 0 (Just 0)
newPWSalt
:: RandomGen g
=> g
-> (PWSalt, g)
newPWSalt g = (result, g2) where
result = B.pack $ take 32 $ randoms g1
(g1, g2) = split g
validatePWDatabase
:: PWDatabase
-> Bool
validatePWDatabase = all validatePWData
validatePWData
:: PWData
-> Bool
validatePWData x =
validatePWPolicy (x^.pwPolicy) &&
B.length (x^.pwSalt) > 0
validatePWPolicy
:: PWPolicy
-> Bool
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
pwGenerate
:: String
-> PWData
-> Maybe String
pwGenerate pw d = if validatePWData d
then Just $ mkPass (mkPool seed) (d^.pwPolicy)
else Nothing
where seed = mkSeed pw d
pwCountUpper
:: String
-> Int
pwCountUpper = pwCount isUpper
pwCountLower
:: String
-> Int
pwCountLower = pwCount isLower
pwCountDigits
:: String
-> Int
pwCountDigits = pwCount isDigit
pwCountSpecial
:: String
-> Int
pwCountSpecial = pwCount isSpecial
pwCount
:: (Char -> Bool)
-> String
-> Int
pwCount f = length . filter f
pwHasService
:: String
-> PWDatabase
-> Bool
pwHasService x db = elem x $ M.keys db
pwSetService
:: String
-> PWData
-> PWDatabase
-> PWDatabase
pwSetService = M.insert
pwGetService
:: String
-> PWDatabase
-> Maybe PWData
pwGetService = M.lookup
pwRemoveService
:: String
-> PWDatabase
-> PWDatabase
pwRemoveService = M.delete
pwSearch
:: String
-> PWDatabase
-> [String]
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 [] _ = ""
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