From f65a478fb535b0a718569a074a7eba321b714149 Mon Sep 17 00:00:00 2001 From: Jonathan Lamothe Date: Sat, 7 Sep 2024 14:26:15 -0400 Subject: [PATCH] stripped out frontend --- app/Main.hs | 31 +----- app/Types.hs | 53 --------- app/UI.hs | 282 ------------------------------------------------ app/Util.hs | 118 -------------------- package.yaml | 3 - passman.cabal | 12 +-- stack.yaml | 3 +- stack.yaml.lock | 9 +- 8 files changed, 7 insertions(+), 504 deletions(-) delete mode 100644 app/Types.hs delete mode 100644 app/UI.hs delete mode 100644 app/Util.hs diff --git a/app/Main.hs b/app/Main.hs index 649f660..a86fc29 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -20,36 +20,9 @@ License along with this program. If not, see -} -module Main where - -import Control.Monad.Trans.State as S -import System.Console.HCL (Request, reqIO, runRequest) -import System.EasyFile - ( createDirectoryIfMissing - , getAppUserDataDirectory - , () - ) -import System.Random (getStdGen) - -import Types -import UI -import Util +module Main (main) where main :: IO () -main = runRequest setup >>= mapM_ (S.evalStateT mainMenu) - -setup :: Request Status -setup = do - g <- reqIO getStdGen - p <- getDBPath - db <- loadFrom p - pw <- getMasterPass - return $ Status g pw p db - -getDBPath :: Request FilePath -getDBPath = reqIO $ do - path <- getAppUserDataDirectory "passman" - createDirectoryIfMissing True path - return $ path "database.json" +main = return () --jl diff --git a/app/Types.hs b/app/Types.hs deleted file mode 100644 index 66cccd6..0000000 --- a/app/Types.hs +++ /dev/null @@ -1,53 +0,0 @@ -{- - -passman -Copyright (C) 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, dbPath, masterPass, database) where - -import Lens.Micro (set, (^.)) -import Lens.Micro.TH (makeLenses) -import System.Random (RandomGen (genWord64, split), StdGen) - -import Password - -data Status = Status - { _gen :: StdGen - , _masterPass :: String - , _dbPath :: FilePath - , _database :: PWDatabase - } - -makeLenses ''Status - -instance RandomGen Status where - genWord64 s = (x, s') where - (x, g') = genWord64 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 deleted file mode 100644 index 75b2a26..0000000 --- a/app/UI.hs +++ /dev/null @@ -1,282 +0,0 @@ -{- - -passman -Copyright (C) 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 LambdaCase #-} - -module UI (getMasterPass, mainMenu) where - -import Control.Monad (when) -import Control.Monad.Trans.Class (lift) -import qualified Control.Monad.Trans.State as S -import Lens.Micro (over, set, (^.), (.~)) -import Lens.Micro.Extras (view) -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 "The passwords you entered do not match." - reqFail - else return p1 - -mainMenu :: S.StateT Status IO () -mainMenu = - menu "Main Menu" - [ ( "view/edit a password", viewEditMenu ) - , ( "add a password", addPassword ) - , ( "change master password", changeMasterPass ) - , ( "save manually", save >> mainMenu ) - , ( "lock session", lockSession ) - , ( "quit", quit ) - ] - -addPassword :: S.StateT Status IO () -addPassword = do - pass <- S.gets (^.masterPass) - - lift (runRequest $ prompt "confirm master password: " reqPassword) - >>= \case - Nothing -> mainMenu - Just chkPass - | pass == chkPass -> addPassword' - - | otherwise -> do - lift $ putStrLn "Incorrect master password." - mainMenu - -addPassword' :: S.StateT Status IO () -addPassword' = do - svc <- req $ prompt "service name: " reqResp - ifServExists svc - (do - edit <- req (confirm $ - "The service already exists in the database.\n" ++ - "Would you like to edit it?") - if edit - then servMenu svc - else mainMenu) - (do - d <- buildData - setService svc d - showPass svc - servMenu svc) - -viewEditMenu :: S.StateT Status IO () -viewEditMenu = menu "View/Edit Password" - [ ( "search services", searchServ ) - , ( "list services", listServ ) - , ( "cancel", mainMenu ) - ] - -changeMasterPass :: S.StateT Status IO () -changeMasterPass = do - req (confirm $ - "\nWARNING: Changing your master password will change all of your saved passwords.\n" ++ - "Are you sure you would like to proceed?") >>= flip when - (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 "\nThe session is locked." - pass <- S.gets $ view masterPass - x <- req $ prompt "master password: " reqPassword - if x == pass - then mainMenu - else lockSession - -quit :: S.StateT Status IO () -quit = save - -buildData :: S.StateT Status IO PWData -buildData = do - d <- run newPWData - req $ reqIf (confirm "Would you like to change the password policy?") - (do - let p = d^.pwPolicy - p' <- reqDefault (editPolicy p) p - return $ set pwPolicy p' d) - (return d) - -searchServ :: S.StateT Status IO () -searchServ = do - svc <- req $ prompt "\nservice name: " reqResp - db <- S.gets $ view database - case pwSearch svc db of - [] -> do - lift $ putStrLn "\nThe service could not be found in the database." - mainMenu - [x] -> servMenu 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, servMenu x)) xs ++ - [("(cancel)", mainMenu)] - -servMenu :: String -> S.StateT Status IO () -servMenu x = menu x - [ ( "show password", showPass x >> servMenu x ) - , ( "show alternate password", showAltPass x ) - , ( "edit password", editPassMenu x ) - , ( "remove service", removeServ x ) - , ( "rename service", renameServ x ) - , ( "back", mainMenu ) - ] - -editPassMenu :: String -> S.StateT Status IO () -editPassMenu x = menu (x ++ " : Edit Password") - [ ( "generate new password", changeSalt x ) - , ( "edit password policy", doEditPolicy x ) - , ( "back", servMenu x ) - ] - -removeServ :: String -> S.StateT Status IO () -removeServ x = do - go <- req $ confirm $ - "Are you sure you want to delete the password for " ++ x ++ "?" - if go - then do - removeServ' x - mainMenu - else servMenu x - -removeServ' :: String -> S.StateT Status IO () -removeServ' = S.modify . over database . pwRemoveService - -renameServ :: String -> S.StateT Status IO () -renameServ x = do - y <- req $ prompt "new service name: " reqResp - if x == y - then servMenu x - else ifServExists y - (do - overwrite <- req $ confirm $ - y ++ " already exists.\n" ++ - "Would you like to overwrite it?" - if overwrite - then renameServ' x y - else servMenu x) - (renameServ' x y) - -renameServ' :: String -> String -> S.StateT Status IO () -renameServ' x y = withService x mainMenu $ \d -> do - removeServ' x - setService y d - servMenu y - -changeSalt :: String -> S.StateT Status IO () -changeSalt x = withService x mainMenu $ \d -> do - salt <- run newPWSalt - setService x $ set pwSalt salt d - showPass x - editPassMenu x - -doEditPolicy :: String -> S.StateT Status IO () -doEditPolicy x = withService x mainMenu $ \d -> do - let p = d^.pwPolicy - p' <- req $ reqDefault (editPolicy p) p - setService x $ set pwPolicy p' d - showPass x - editPassMenu x - -showPass :: String -> S.StateT Status IO () -showPass x = withService x - (lift $ putStrLn "The service could not be found in the database.") $ - \d -> do - lift $ putStrLn "" - mp <- S.gets $ view masterPass - lift $ putStrLn $ case pwGenerate mp d of - Nothing -> "The password data were not valid." - Just pw -> "password for " ++ x ++ ": " ++ pw - -showAltPass :: String -> S.StateT Status IO () -showAltPass srv = do - lift $ putStrLn "" - old <- S.gets $ view masterPass - Just new <- lift $ runRequest $ required $ prompt "alternate master password: " reqPassword - S.modify $ masterPass .~ new - showPass srv - S.modify $ masterPass .~ old - servMenu srv - --- TODO: refactor this monstrosity -editPolicy :: PWPolicy -> Request PWPolicy -editPolicy policy = do - p <- - edit "length" (policy^.pwLength) pwLength policy >>= - edit "min upper case" (policy^.pwUpper) pwUpper >>= - edit "min lower case" (policy^.pwLower) pwLower >>= - edit "min digits" (policy^.pwDigits) pwDigits >>= - special - if validatePWPolicy p - then return p - else do - reqIO $ putStrLn $ - "\nThe password policy you entered is invalid\n." ++ - "It will not be changed." - 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 characters are currently " ++ - (case p^.pwSpecial of - Nothing -> "not " - Just _ -> "") ++ "allowed." - reqIf (confirm "Would you like to allow special characters?") - (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 deleted file mode 100644 index cd29fe2..0000000 --- a/app/Util.hs +++ /dev/null @@ -1,118 +0,0 @@ -{- - -passman -Copyright (C) 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 - , run - , withService - , ifServExists - , setService - , req - , tryReq - , confirm - , loadFrom - , save - ) where - -import Control.Monad (join) -import Control.Monad.Trans.Class (lift) -import qualified Control.Monad.Trans.State as S -import Data.Aeson (decodeFileStrict, encodeFile) -import Data.Maybe (fromJust, fromMaybe) -import Lens.Micro (over) -import Lens.Micro.Extras (view) -import System.Console.HCL - ( Request - , prompt - , reqAgree - , reqChar - , reqDefault - , reqIO - , reqMenu - , required - , runRequest - ) - -import Password - -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 - -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 - maybe fb act $ pwGetService srv db - -ifServExists - :: String - -> S.StateT Status IO a - -> S.StateT Status IO a - -> S.StateT Status IO a -ifServExists s x y = do - db <- S.gets $ view database - if pwHasService s db - then x - else y - -setService :: String -> PWData -> S.StateT Status IO () -setService k = S.modify . over database . pwSetService k - -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 = prompt (x ++ " (y/n): ") $ reqAgree Nothing $ fmap return reqChar - -loadFrom :: FilePath -> Request PWDatabase -loadFrom path = fromMaybe newPWDatabase <$> reqDefault - (reqIO (decodeFileStrict path)) - (Just newPWDatabase) - -save :: S.StateT Status IO () -save = do - path <- S.gets $ view dbPath - db <- S.gets $ view database - lift $ encodeFile path db - ---jl diff --git a/package.yaml b/package.yaml index 096608b..129e642 100644 --- a/package.yaml +++ b/package.yaml @@ -50,9 +50,6 @@ executables: - -with-rtsopts=-N dependencies: - passman - - easy-file >= 0.2.2 && < 0.3 - - HCL >= 1.8 && < 1.9 - - transformers >= 0.5.6.2 && < 0.6 tests: passman-test: diff --git a/passman.cabal b/passman.cabal index 1318cca..38917d9 100644 --- a/passman.cabal +++ b/passman.cabal @@ -1,10 +1,10 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack -- --- hash: da6c3020622e5c4c06814752b3f3334e52925005f8b3be9516efb9fd1976af9c +-- hash: f10f95fab40ebdefdefa5f0908fa891b930f9b6abef8dd240bf183e19e5e3a5e name: passman version: 0.3.1.1 @@ -50,9 +50,6 @@ library executable passman main-is: Main.hs other-modules: - Types - UI - Util Paths_passman autogen-modules: Paths_passman @@ -60,17 +57,14 @@ executable passman app ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - HCL ==1.8.* - , aeson >=2.0.3.0 && <2.1 + aeson >=2.0.3.0 && <2.1 , base >=4.7 && <5 , bytestring >=0.11.4.0 && <0.12 , containers >=0.6.2.1 && <0.7 - , easy-file >=0.2.2 && <0.3 , microlens >=0.4.11.2 && <0.5 , microlens-th >=0.4.3.6 && <0.5 , passman , random >=1.2.1.1 && <1.3 - , transformers >=0.5.6.2 && <0.6 default-language: Haskell2010 test-suite passman-test diff --git a/stack.yaml b/stack.yaml index d4d9c28..42ac32a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -37,8 +37,7 @@ packages: # Dependency packages to be pulled from upstream that are not in the resolver # using the same syntax as the packages field. # (e.g., acme-missiles-0.3) -extra-deps: -- HCL-1.8@sha256:39ec0da0cd6157f20c395e1b0df474df45efb0088afdaab20bb9dfb3662baf7c,1726 +# extra-deps: # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index a2a32d6..1bb642a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,14 +3,7 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: -- completed: - hackage: HCL-1.8@sha256:39ec0da0cd6157f20c395e1b0df474df45efb0088afdaab20bb9dfb3662baf7c,1726 - pantry-tree: - sha256: 5c93c5184dc378de5ecf235aa1a60dc24163ab7e0efad19c8f3bbc94354cf2b8 - size: 1223 - original: - hackage: HCL-1.8@sha256:39ec0da0cd6157f20c395e1b0df474df45efb0088afdaab20bb9dfb3662baf7c,1726 +packages: [] snapshots: - completed: sha256: 42f77c84b34f68c30c2cd0bf8c349f617a0f428264362426290847a6a2019b64