stripped out frontend
This commit is contained in:
parent
85920c26a0
commit
f65a478fb5
31
app/Main.hs
31
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
|
||||
|
|
|
|||
53
app/Types.hs
53
app/Types.hs
|
|
@ -1,53 +0,0 @@
|
|||
{-
|
||||
|
||||
passman
|
||||
Copyright (C) Jonathan Lamothe
|
||||
<jonathan@jlamothe.net>
|
||||
|
||||
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
|
||||
<https://www.gnu.org/licenses/>.
|
||||
|
||||
-}
|
||||
|
||||
{-# 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
|
||||
282
app/UI.hs
282
app/UI.hs
|
|
@ -1,282 +0,0 @@
|
|||
{-
|
||||
|
||||
passman
|
||||
Copyright (C) Jonathan Lamothe
|
||||
<jonathan@jlamothe.net>
|
||||
|
||||
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
|
||||
<https://www.gnu.org/licenses/>.
|
||||
|
||||
-}
|
||||
|
||||
{-# 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
|
||||
118
app/Util.hs
118
app/Util.hs
|
|
@ -1,118 +0,0 @@
|
|||
{-
|
||||
|
||||
passman
|
||||
Copyright (C) Jonathan Lamothe
|
||||
<jonathan@jlamothe.net>
|
||||
|
||||
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
|
||||
<https://www.gnu.org/licenses/>.
|
||||
|
||||
-}
|
||||
|
||||
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
|
||||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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: {}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user