implemented policy editing

This commit is contained in:
Jonathan Lamothe 2018-12-27 15:56:25 -05:00
parent 0920bff2f5
commit 9b5af711b3
2 changed files with 38 additions and 17 deletions

View File

@ -27,6 +27,7 @@ import Control.Lens (over, set, view, (^.))
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as S import qualified Control.Monad.Trans.State as S
import Data.Maybe (maybe)
import System.Console.HCL import System.Console.HCL
( Request ( Request
, prompt , prompt
@ -149,29 +150,35 @@ servMenu x = menu x
editPassMenu :: String -> S.StateT Status IO () editPassMenu :: String -> S.StateT Status IO ()
editPassMenu x = menu (x ++ " : Edit Password") editPassMenu x = menu (x ++ " : Edit Password")
[ ( "generate new password", changeSalt x ) [ ( "generate new password", changeSalt x )
, ( "cancel", servMenu x ) , ( "edit password policy", doEditPolicy x )
, ( "cancel", servMenu x )
] ]
changeSalt :: String -> S.StateT Status IO () changeSalt :: String -> S.StateT Status IO ()
changeSalt x = do changeSalt x = withService x mainMenu $ \d -> do
db <- S.gets $ view database salt <- run newPWSalt
case pwGetService x db of let d' = set pwSalt salt d
Nothing -> mainMenu S.modify $ over database $ pwSetService x d'
Just serv -> do showPass x
salt <- run newPWSalt servMenu x
let serv' = set pwSalt salt serv
S.modify $ over database (pwSetService x serv') doEditPolicy :: String -> S.StateT Status IO ()
showPass x doEditPolicy x = withService x mainMenu $ \d -> do
servMenu x 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 :: String -> S.StateT Status IO ()
showPass x = do showPass x = do
lift $ putStrLn "" lift $ putStrLn ""
db <- S.gets $ view database withService x
case pwGetService x db of (lift $ putStrLn "service not found") $
Nothing -> lift $ putStrLn "service not found" \d -> do
Just d -> do
pw <- S.gets $ view masterPass pw <- S.gets $ view masterPass
lift $ putStrLn $ case pwGenerate pw d of lift $ putStrLn $ case pwGenerate pw d of
Nothing -> "invalid password data" Nothing -> "invalid password data"

View File

@ -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 (join)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as S import qualified Control.Monad.Trans.State as S
@ -37,6 +38,8 @@ import System.Console.HCL
, runRequest , runRequest
) )
import Password
import Types import Types
menu menu
@ -55,6 +58,17 @@ reqState = join . req
run :: Monad m => (s -> (a, s)) -> S.StateT s m a run :: Monad m => (s -> (a, s)) -> S.StateT s m a
run f = S.StateT $ return . f 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 :: Request a -> S.StateT s IO a
req = lift . fmap fromJust . runRequest . required req = lift . fmap fromJust . runRequest . required