diff --git a/app/UI.hs b/app/UI.hs index 68115e1..e0bbf0d 100644 --- a/app/UI.hs +++ b/app/UI.hs @@ -27,6 +27,7 @@ import Control.Lens (over, set, view, (^.)) import Control.Monad (when) import Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.State as S +import Data.Maybe (maybe) import System.Console.HCL ( Request , prompt @@ -149,29 +150,35 @@ servMenu x = menu x editPassMenu :: String -> S.StateT Status IO () editPassMenu x = menu (x ++ " : Edit Password") - [ ( "generate new password", changeSalt x ) - , ( "cancel", servMenu x ) + [ ( "generate new password", changeSalt x ) + , ( "edit password policy", doEditPolicy x ) + , ( "cancel", servMenu x ) ] changeSalt :: String -> S.StateT Status IO () -changeSalt x = do - db <- S.gets $ view database - case pwGetService x db of - Nothing -> mainMenu - Just serv -> do - salt <- run newPWSalt - let serv' = set pwSalt salt serv - S.modify $ over database (pwSetService x serv') - showPass x - servMenu x +changeSalt x = withService x mainMenu $ \d -> do + salt <- run newPWSalt + let d' = set pwSalt salt d + S.modify $ over database $ pwSetService x d' + showPass x + servMenu x + +doEditPolicy :: String -> S.StateT Status IO () +doEditPolicy x = withService x mainMenu $ \d -> do + let p = d^.pwPolicy + tryReq (editPolicy p) >>= maybe + (lift $ putStrLn "invalid policy - leaving unchanged") + (\p' -> do + S.modify $ over database $ pwSetService x $ set pwPolicy p' d + showPass x) + editPassMenu x showPass :: String -> S.StateT Status IO () showPass x = do lift $ putStrLn "" - db <- S.gets $ view database - case pwGetService x db of - Nothing -> lift $ putStrLn "service not found" - Just d -> do + withService x + (lift $ putStrLn "service not found") $ + \d -> do pw <- S.gets $ view masterPass lift $ putStrLn $ case pwGenerate pw d of Nothing -> "invalid password data" diff --git a/app/Util.hs b/app/Util.hs index 61d20be..bc82483 100644 --- a/app/Util.hs +++ b/app/Util.hs @@ -20,8 +20,9 @@ License along with this program. If not, see -} -module Util (menu, run, req, tryReq, confirm) where +module Util (menu, run, withService, req, tryReq, confirm) where +import Control.Lens (view) import Control.Monad (join) import Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.State as S @@ -37,6 +38,8 @@ import System.Console.HCL , runRequest ) +import Password + import Types menu @@ -55,6 +58,17 @@ reqState = join . req run :: Monad m => (s -> (a, s)) -> S.StateT s m a run f = S.StateT $ return . f +withService + :: String + -> S.StateT Status IO a + -> (PWData -> S.StateT Status IO a) + -> S.StateT Status IO a +withService srv fb act = do + db <- S.gets $ view database + case pwGetService srv db of + Nothing -> fb + Just x -> act x + req :: Request a -> S.StateT s IO a req = lift . fmap fromJust . runRequest . required