diff --git a/app/Main.hs b/app/Main.hs index 81c2fd4..a848716 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -24,24 +24,29 @@ License along with this program. If not, see module Main where -import Control.Lens (makeLenses, set, view) +import Control.Applicative ((<|>)) +import Control.Lens (makeLenses, over, set, view, (^.)) import qualified Control.Monad.Trans.State as S -import Control.Monad (join) +import Control.Monad (join, when) import Control.Monad.Trans.Class (lift) import Data.Foldable (mapM_) import Data.Maybe (fromJust) import System.Console.HCL ( Request (..) , prompt + , reqAgree , reqDefault , reqFail + , reqIf + , reqInt , reqIO , reqMenu , reqPassword + , reqResp , required , runRequest ) -import System.Random (StdGen, getStdGen) +import System.Random (RandomGen (..), StdGen, getStdGen) import Password @@ -53,6 +58,17 @@ data Status = Status makeLenses ''Status +instance RandomGen Status where + next s = (x, s') where + (x, g') = next g + s' = set gen g' s + g = s^.gen + split s = (s1, s2) where + s1 = set gen g1 s + s2 = set gen g2 s + (g1, g2) = split g + g = s^.gen + main :: IO () main = runRequest setup >>= mapM_ (S.evalStateT mainMenu) @@ -75,11 +91,27 @@ getMasterPass = do mainMenu :: S.StateT Status IO () mainMenu = menu "Main Menu" - [ ( "change master password", changeMasterPass ) + [ ( "add a password", addPassword ) + , ( "change master password", changeMasterPass ) , ( "lock session", lockSession ) , ( "quit", quit ) ] +addPassword :: S.StateT Status IO () +addPassword = do + svc <- req $ prompt "service name: " reqResp + db <- S.gets $ view database + if pwHasService svc db + then req (confirm "service exists - overwrite?") >>= flip when (addPassword' svc) + else addPassword' svc + mainMenu + +addPassword' :: String -> S.StateT Status IO () +addPassword' x = do + d <- buildData + S.modify $ over database $ pwSetService x d + showPass x + changeMasterPass :: S.StateT Status IO () changeMasterPass = do oldP <- S.gets $ view masterPass @@ -101,6 +133,61 @@ lockSession = do quit :: S.StateT Status IO () quit = return () +showPass :: String -> S.StateT Status IO () +showPass x = do + db <- S.gets $ view database + case pwGetService x db of + Nothing -> lift $ putStrLn "service not found" + Just d -> do + pw <- S.gets $ view masterPass + lift $ putStrLn $ case pwGenerate pw d of + Nothing -> "invalid password data" + Just pw -> "password for " ++ x ++ ": " ++ pw + +buildData :: S.StateT Status IO PWData +buildData = do + d <- S.StateT $ return . newPWData + req $ reqIf (confirm "would you like to change the default policy?") + (do + let p = d^.pwPolicy + p <- editPolicy p <|> do + reqIO $ putStrLn "invalid password policy - using default" + return p + return $ set pwPolicy p d) + (return d) + +editPolicy :: PWPolicy -> Request PWPolicy +editPolicy p = if validatePWPolicy p + then do + p <- edit "length" (p^.pwLength) pwLength p + p <- edit "min upper case" (p^.pwUpper) pwUpper p + p <- edit "min lower case" (p^.pwLower) pwLower p + p <- edit "min digits" (p^.pwDigits) pwDigits p + p <- special p + if validatePWPolicy p + then return p + else reqFail + else reqFail + where + edit l v t p = reqIf + (confirm $ l ++ " is " ++ show v ++ "\nchange?") + (do + x <- required $ prompt ("new " ++ l ++ ": ") reqInt + return $ set t v p) + (return p) + special p = do + reqIO $ putStrLn $ "special chars are currently " ++ + (case p^.pwSpecial of + Nothing -> "not " + Just _ -> "") ++ "allowed" + reqIf (confirm "allow special chars?") + (case p^.pwSpecial of + Nothing -> do + x <- required $ prompt "min special chars: " reqInt + return $ set pwSpecial (Just x) p + Just x -> edit "min special chars" x (pwSpecial.traverse) p) + (return $ set pwSpecial Nothing p) + menu :: String -> [(String, S.StateT Status IO a)] @@ -117,4 +204,10 @@ reqState = join . req req :: Request a -> S.StateT s IO a req = lift . fmap fromJust . runRequest . required +tryReq :: Request a -> S.StateT s IO (Maybe a) +tryReq = lift . runRequest + +confirm :: String -> Request Bool +confirm x = required $ prompt (x ++ " (y/n): ") $ reqAgree Nothing reqResp + --jl diff --git a/src/Password.hs b/src/Password.hs index 097a1e7..4f1cb90 100644 --- a/src/Password.hs +++ b/src/Password.hs @@ -41,7 +41,9 @@ module Password ( -- ** Password Generator pwGenerate, -- ** Password Checkers - pwCountUpper, pwCountLower, pwCountDigits, pwCountSpecial + pwCountUpper, pwCountLower, pwCountDigits, pwCountSpecial, + -- ** Database Functions + pwHasService, pwSetService, pwGetService ) where import Control.Lens (makeLenses, over, set, (^.)) @@ -203,6 +205,39 @@ pwCountSpecial -- ^ the count pwCountSpecial = length . filter isSpecial +-- | 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 = undefined + +-- | 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 = undefined + +-- | 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 = undefined + isSpecial :: Char -> Bool isSpecial x = not $ isUpper x || isLower x || isDigit x