diff --git a/app/Main.hs b/app/Main.hs index bfd13fa..c592bf2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -20,54 +20,18 @@ License along with this program. If not, see -} -{-# LANGUAGE TemplateHaskell #-} - module Main where -import Control.Applicative ((<|>)) -import Control.Lens (makeLenses, over, set, view, (^.)) -import qualified Control.Monad.Trans.State as S -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 (RandomGen (..), StdGen, getStdGen) +import Control.Monad (mapM_) +import Control.Monad.Trans.State as S +import System.Console.HCL (Request, reqIO, runRequest) +import System.Random (getStdGen) import Password -data Status = Status - { _gen :: StdGen - , _masterPass :: String - , _database :: PWDatabase - } - -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 +import Types +import UI +import Util main :: IO () main = runRequest setup >>= mapM_ (S.evalStateT mainMenu) @@ -78,169 +42,4 @@ setup = do mp <- getMasterPass return $ Status g mp newPWDatabase -getMasterPass :: Request String -getMasterPass = do - p1 <- required $ prompt "master password: " reqPassword - p2 <- required $ prompt "confirm master password: " reqPassword - if p1 /= p2 - then do - reqIO $ putStrLn "passwords do not match" - reqFail - else return p1 - -mainMenu :: S.StateT Status IO () -mainMenu = - menu "Main Menu" - [ ( "add a password", addPassword ) - , ( "view/edit a password", viewEditPass ) - , ( "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 - -viewEditPass :: S.StateT Status IO () -viewEditPass = menu "View/Edit Password" - [ ( "search services", searchServ ) - , ( "list services", listServ ) - , ( "cancel", mainMenu ) - ] - -searchServ :: S.StateT Status IO () -searchServ = do - svc <- req $ prompt "service name: " reqResp - db <- S.gets $ view database - case pwSearch svc db of - [] -> do - lift $ putStrLn "\nservice not found" - mainMenu - [x] -> viewEdit x - xs -> selectServ xs - -listServ :: S.StateT Status IO () -listServ = S.gets (view database) >>= selectServ . pwSearch "" - -selectServ :: [String] -> S.StateT Status IO () -selectServ xs = menu "Select Service" $ - ("cancel", mainMenu) : - map (\x -> (x, viewEdit x)) xs - -viewEdit :: String -> S.StateT Status IO () -viewEdit x = menu x - [ ( "show password", showPass x >> viewEdit x ) - , ( "cancel", mainMenu ) - ] - -changeMasterPass :: S.StateT Status IO () -changeMasterPass = do - oldP <- S.gets $ view masterPass - newP <- req $ reqDefault getMasterPass oldP - S.modify $ set masterPass newP - mainMenu - -lockSession :: S.StateT Status IO () -lockSession = do - lift $ putStrLn "\nsession locked" - pass <- S.gets $ view masterPass - mx <- lift $ runRequest $ prompt "password: " reqPassword - case mx of - Nothing -> lockSession - Just x -> if x == pass - then mainMenu - else lockSession - -quit :: S.StateT Status IO () -quit = return () - -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 - 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) - --- TODO: refactor this monstrosity -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 = do - v <- reqDefault - (prompt ("new " ++ l ++ " (default " ++ show v ++ "): ") reqInt) v - return $ set t v 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)] - -> S.StateT Status IO a -menu title = reqState . prompt ("\n*** " ++ title ++ " ***") . - reqMenu . map menuItem - -menuItem :: (String, a) -> (String, Request a) -menuItem (str, x) = (str, return x) - -reqState :: Request (S.StateT s IO a) -> S.StateT s IO a -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/app/Types.hs b/app/Types.hs new file mode 100644 index 0000000..c27e253 --- /dev/null +++ b/app/Types.hs @@ -0,0 +1,51 @@ +{- + +passman +Copyright (C) 2018 Jonathan Lamothe + + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as +published by the Free Software Foundation, either version 3 of the +License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this program. If not, see +. + +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Types (Status (Status), gen, masterPass, database) where + +import Control.Lens (makeLenses, set, (^.)) +import System.Random (RandomGen (next, split), StdGen) + +import Password + +data Status = Status + { _gen :: StdGen + , _masterPass :: String + , _database :: PWDatabase + } + +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 + +--jl diff --git a/app/UI.hs b/app/UI.hs new file mode 100644 index 0000000..4e9bbd4 --- /dev/null +++ b/app/UI.hs @@ -0,0 +1,192 @@ +{- + +passman +Copyright (C) 2018 Jonathan Lamothe + + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as +published by the Free Software Foundation, either version 3 of the +License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this program. If not, see +. + +-} + +module UI (getMasterPass, mainMenu) where + +import Control.Applicative ((<|>)) +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 System.Console.HCL + ( Request + , prompt + , reqDefault + , reqFail + , reqIf + , reqInt + , reqIO + , reqPassword + , reqResp + , required + , runRequest + ) + +import Password + +import Types +import Util + +getMasterPass :: Request String +getMasterPass = do + p1 <- required $ prompt "master password: " reqPassword + p2 <- required $ prompt "confirm master password: " reqPassword + if p1 /= p2 + then do + reqIO $ putStrLn "passwords do not match" + reqFail + else return p1 + +mainMenu :: S.StateT Status IO () +mainMenu = + menu "Main Menu" + [ ( "add a password", addPassword ) + , ( "view/edit a password", viewEditMenu ) + , ( "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 + +viewEditMenu :: S.StateT Status IO () +viewEditMenu = menu "View/Edit Password" + [ ( "search services", searchServ ) + , ( "list services", listServ ) + , ( "cancel", mainMenu ) + ] + +searchServ :: S.StateT Status IO () +searchServ = do + svc <- req $ prompt "service name: " reqResp + db <- S.gets $ view database + case pwSearch svc db of + [] -> do + lift $ putStrLn "\nservice not found" + mainMenu + [x] -> viewEditServ x + xs -> selectServ xs + +listServ :: S.StateT Status IO () +listServ = S.gets (view database) >>= selectServ . pwSearch "" + +selectServ :: [String] -> S.StateT Status IO () +selectServ xs = menu "Select Service" $ + map (\x -> (x, viewEditServ x)) xs ++ + [("(cancel)", mainMenu)] + +viewEditServ :: String -> S.StateT Status IO () +viewEditServ x = menu x + [ ( "show password", showPass x >> viewEditServ x ) + , ( "cancel", mainMenu ) + ] + +changeMasterPass :: S.StateT Status IO () +changeMasterPass = do + oldP <- S.gets $ view masterPass + newP <- req $ reqDefault getMasterPass oldP + S.modify $ set masterPass newP + mainMenu + +lockSession :: S.StateT Status IO () +lockSession = do + lift $ putStrLn "\nsession locked" + pass <- S.gets $ view masterPass + mx <- lift $ runRequest $ prompt "password: " reqPassword + case mx of + Nothing -> lockSession + Just x -> if x == pass + then mainMenu + else lockSession + +quit :: S.StateT Status IO () +quit = return () + +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 + 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) + +-- TODO: refactor this monstrosity +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 = do + v <- reqDefault + (prompt ("new " ++ l ++ " (default " ++ show v ++ "): ") reqInt) v + return $ set t v 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) + +--jl diff --git a/app/Util.hs b/app/Util.hs new file mode 100644 index 0000000..b4384d6 --- /dev/null +++ b/app/Util.hs @@ -0,0 +1,64 @@ +{- + +passman +Copyright (C) 2018 Jonathan Lamothe + + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as +published by the Free Software Foundation, either version 3 of the +License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this program. If not, see +. + +-} + +module Util (menu, req, tryReq, confirm) where + +import Control.Monad (join) +import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.Trans.State as S +import Data.Maybe (fromJust) +import System.Console.HCL + ( Request + , prompt + , reqAgree + , reqIf + , reqMenu + , reqResp + , required + , runRequest + ) + +import Types + +menu + :: String + -> [(String, S.StateT Status IO a)] + -> S.StateT Status IO a +menu title = reqState . prompt ("\n*** " ++ title ++ " ***") . + reqMenu . map menuItem + +menuItem :: (String, a) -> (String, Request a) +menuItem (str, x) = (str, return x) + +reqState :: Request (S.StateT s IO a) -> S.StateT s IO a +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