implemented policy editing

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"

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