implemented policy editing
This commit is contained in:
parent
0920bff2f5
commit
9b5af711b3
39
app/UI.hs
39
app/UI.hs
@ -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"
|
||||||
|
16
app/Util.hs
16
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 (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
|
||||||
|
|
||||||
|
Loading…
x
Reference in New Issue
Block a user