module Data.KeyStore.PasswordManager
( PMConfig(..)
, PW(..)
, PW_(..)
, SessionDescriptor(..)
, CollectConfig(..)
, defaultCollectConfig
, Password(..)
, PasswordName(..)
, PasswordText(..)
, SessionName(..)
, EnvVar(..)
, passwordManager
, defaultHashDescription
, defaultSampleScript
, hashMasterPassword
, bindMasterPassword
, setup
, passwordValid
, isStorePresent
, amLoggedIn
, isBound
, load
, psComment
, collect
, prime
, select
, deletePassword
, deleteSession
, status
, passwords
, sessions
, infoPassword
, infoPassword_
, dump
, collectShell
) where
import Data.KeyStore.Types.PasswordStoreModel
import Data.KeyStore.Types
import Data.KeyStore.KS.Crypto
import Data.KeyStore.KS.CPRNG
import Data.KeyStore.Version
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64 as B64
import qualified Data.Text as T
import qualified Data.Map as Map
import Data.Time
import Data.Monoid
import Data.API.Types
import Data.API.JSON
import Data.Maybe
import qualified Text.PrettyPrint.ANSI.Leijen as P
import Text.Printf
import qualified Control.Lens as L
import Control.Applicative
import Control.Exception
import Control.Monad
import System.Directory
import qualified System.Environment as E
import System.SetEnv
import System.Exit
import System.IO
import System.Locale
import qualified Options.Applicative as O
import Options.Applicative
data PMConfig p =
PMConfig
{ _pmc_location :: FilePath
, _pmc_env_var :: EnvVar
, _pmc_keystore_msg :: String
, _pmc_password_msg :: String
, _pmc_shell :: IO ()
, _pmc_hash_descr :: HashDescription
, _pmc_allow_dumps :: Bool
, _pmc_dump_prefix :: String
, _pmc_sample_script :: Maybe String
}
class (Bounded p,Enum p,Eq p, Ord p,Show p) => PW p where
pwName :: p -> PasswordName
pwName = PasswordName . T.pack . show
parsePwName :: PasswordName -> Maybe p
parsePwName = \pnm -> listToMaybe [ p | p<-[minBound..maxBound], pwName p == pnm ]
isSession :: p -> Maybe (PasswordText -> Either String SessionDescriptor)
isSession = const Nothing
isOneShot :: p -> Bool
isOneShot = const False
enVar :: p -> EnvVar
enVar = EnvVar . (T.append "KEY_pw_") . _PasswordName . pwName
summarize :: p -> String
summarize _ = ""
describe :: p -> String
describe p = (T.unpack $ _PasswordName $ pwName p) ++ ": description to follow"
data PW_ p = PW_
cast_pmc :: PMConfig p -> p -> p
cast_pmc _ p = p
cast_pw :: PW_ p -> p -> p
cast_pw _ p = p
data SessionDescriptor =
SessionDescriptor
{ _sd_name :: SessionName
, _sd_isOneShot :: Bool
}
deriving (Show)
data CollectConfig p =
CollectConfig
{ _cc_optional :: Bool
, _cc_active :: [p]
}
defaultCollectConfig :: PW p => CollectConfig p
defaultCollectConfig =
CollectConfig
{ _cc_optional = True
, _cc_active = [minBound..maxBound]
}
passwordManager :: PW p => PMConfig p -> [String] -> IO ()
passwordManager pmc args = do
pmcd <- parse_command pmc args
case pmcd of
PMCD_version -> putStrLn version
PMCD_setup nl mb_t -> setup pmc nl mb_t
PMCD_login y mb_t -> login pmc y mb_t
PMCD_load p mb_t -> load pmc p mb_t
PMCD_comment cmt -> psComment pmc cmt
PMCD_prime u p -> prime pmc u $ Just p
PMCD_prime_all u -> prime pmc u Nothing
PMCD_select mb snm -> select pmc mb snm
PMCD_delete_password p -> deletePassword pmc p
PMCD_delete_session mb snm -> deleteSession pmc mb snm
PMCD_status q -> status pmc q
PMCD_passwords b -> passwords pmc b
PMCD_sessions a b mb -> sessions pmc a b mb
PMCD_info s p -> infoPassword pmc s p
PMCD_dump s -> dump pmc s
PMCD_collect -> collectShell pmc
PMCD_sample_script -> putStr $ maybe "" id $ _pmc_sample_script pmc
defaultHashDescription :: Salt -> HashDescription
defaultHashDescription st =
HashDescription
{ _hashd_comment = "PM master password"
, _hashd_prf = PRF_sha512
, _hashd_iterations = 5000
, _hashd_width_octets = 32
, _hashd_salt_octets = Octets $ B.length $ _Binary $ _Salt st
, _hashd_salt = st
}
defaultSampleScript :: PW p => PW_ p -> String -> String
defaultSampleScript pw_ pfx = format_dump pfx cmt (map f [minBound..maxBound]) []
where
f p = (,) p $ PasswordText $ "secret-" `T.append` _PasswordName (pwName $ cast_pw pw_ p)
cmt = PasswordStoreComment $ T.pack "loaded by the sample script"
hashMasterPassword :: PW p => PMConfig p -> String -> PasswordText
hashMasterPassword PMConfig{..} pw =
PasswordText $ T.pack $ B.unpack $
B64.encode $ _Binary $ _HashData $ _hash_hash $
hashKS_ _pmc_hash_descr $ ClearText $ Binary $ B.pack pw
bindMasterPassword :: PW p => PMConfig p -> PasswordText -> IO ()
bindMasterPassword PMConfig{..} = set_env _pmc_env_var
setup :: PW p
=> PMConfig p
-> Bool
-> Maybe PasswordText
-> IO ()
setup pmc no_li mb_pwt = do
ex <- doesFileExist _pmc_location
when ex $ error $ "password store already exists in: " ++ _pmc_location
pwt <- maybe (get_pw pmc) return mb_pwt
now <- getCurrentTime
let ps =
PasswordStore
{ _ps_comment = PasswordStoreComment $ T.pack $ "Created at " ++ show now
, _ps_map = Map.empty
, _ps_setup = now
}
save_ps pmc (mk_aek pwt) ps
when (not no_li) $ login pmc False $ Just pwt
where
PMConfig{..} = pmc
login :: PW p => PMConfig p -> Bool -> Maybe PasswordText -> IO ()
login pmc y mb = do
pwt <- maybe (get_pw pmc) return mb
ok <- passwordValid pmc pwt
case ok of
True -> bindMasterPassword pmc pwt >> good >> _pmc_shell pmc
False -> bad >> login pmc y Nothing
where
good = putStr "*** Login Successful ***\n"
bad = bad_f "*** Password Invalid ***\n"
bad_f = if y then putStr else error
passwordValid :: PW p => PMConfig p -> PasswordText -> IO Bool
passwordValid pmc = password_valid pmc . mk_aek
isStorePresent :: PW p => PMConfig p -> IO Bool
isStorePresent PMConfig{..} = doesFileExist _pmc_location
amLoggedIn :: PW p => PMConfig p -> IO Bool
amLoggedIn pmc = get_key pmc >>= password_valid pmc
isBound :: PW p => PMConfig p -> p -> Maybe SessionName -> IO Bool
isBound pmc p mb = enquire pmc $ \ps -> return $
case Map.lookup (pwName p) $ _ps_map ps of
Nothing -> False
Just Password{..} -> maybe True (\snm->Map.member snm $ _pw_sessions) mb
load :: PW p => PMConfig p -> p -> Maybe PasswordText -> IO ()
load pmc p mb = wrap pmc $ \ps -> do
pwt <- maybe (get_pw pmc) return mb
now <- getCurrentTime
case isSession p of
Nothing -> load_pwd ps
Password
{ _pw_name = pnm
, _pw_text = pwt
, _pw_sessions = Map.empty
, _pw_isOneShot = isOneShot p
, _pw_primed = False
, _pw_setup = now
}
Just ext ->
case ext pwt of
Left err -> ssn_error $ "failed to load session: " ++ err
Right sd -> load_ssn now ps pwt sd
where
load_ssn now ps pwt SessionDescriptor{..} =
load_pwd ps $
L.set pw_text pwt $
L.over pw_sessions (Map.insert _sd_name ssn) $
L.set pw_isOneShot ios $
pw
where
pw = maybe pw0 id $ Map.lookup pnm $ _ps_map ps
pw0 =
Password
{ _pw_name = pnm
, _pw_text = pwt
, _pw_sessions = Map.empty
, _pw_isOneShot = ios
, _pw_primed = False
, _pw_setup = now
}
ssn =
Session
{ _ssn_name = _sd_name
, _ssn_password = pwt
, _ssn_isOneShot = ios
, _ssn_setup = now
}
ios = _sd_isOneShot
load_pwd ps pw = return $ Just $ L.over ps_map (Map.insert pnm pw) ps
pnm = pwName p
psComment :: PW p => PMConfig p -> PasswordStoreComment -> IO ()
psComment pmc cmt = wrap pmc $ \ps -> return $ Just $ L.set ps_comment cmt ps
collect :: PW p => PMConfig p -> CollectConfig p -> IO ()
collect pmc CollectConfig{..} = wrap_ pmc $ \ps -> do
mapM_ (clct pmc ps) _cc_active
return $ Just $ L.over ps_map (Map.map (L.set pw_primed False)) ps
where
clct :: PW p => PMConfig p -> PasswordStore -> p -> IO ()
clct _ ps p = case Map.lookup (pwName p) $ _ps_map ps of
Just pw | is_primed pw -> set_env (enVar p) (_pw_text pw)
_ -> return ()
wrap_ = if _cc_optional then wrap_def else wrap
prime :: PW p => PMConfig p -> Bool -> Maybe p -> IO ()
prime pmc u Nothing = wrap pmc $ \ps -> return $ Just $ L.over ps_map (Map.map (L.set pw_primed $ not u) ) ps
prime pmc u (Just p) = wrap pmc $ \ps -> return $ Just $ L.over ps_map (Map.adjust (L.set pw_primed $ not u) (pwName p)) ps
select :: PW p => PMConfig p -> Maybe p -> SessionName -> IO ()
select pmc mb snm = wrap pmc $ \ps -> f ps <$> lookup_session mb snm ps
where
f ps (p,pw,ssn) = Just $ L.over ps_map (Map.insert (pwName p) (upd pw ssn)) ps
upd pw Session{..} =
L.set pw_text _ssn_password $
L.set pw_isOneShot _ssn_isOneShot $
L.set pw_primed False $
pw
deletePassword :: PW p => PMConfig p -> p -> IO ()
deletePassword pmc p = wrap pmc $ \ps -> return $ Just $ L.over ps_map (Map.delete (pwName p)) ps
deleteSession :: PW p => PMConfig p -> Maybe p -> SessionName -> IO ()
deleteSession pmc mb snm = wrap pmc $ \ps -> do
trp <- lookup_session mb snm ps
chk trp
return $ f ps trp
where
chk (p,pw,ssn)
| Just ext <- isSession p
, Right sd <- ext $ _pw_text pw
, _sd_name sd /= _ssn_name ssn
= return ()
| otherwise = error "cannot delete this session (is it selected?)"
f ps (p,pw,_) = Just $ L.over ps_map (Map.insert (pwName p) (L.over pw_sessions (Map.delete snm) pw)) ps
status :: PW p => PMConfig p -> Bool -> IO ()
status pmc q = (if q then flip catch hdl else id) $ enquire pmc line
where
line ps = putStrLn $
"Logged in [" ++
unwords sns' ++ "/" ++ unwords pps' ++ "] (" ++
(T.unpack $ _PasswordStoreComment $ _ps_comment ps) ++ ")"
where
sns' = sns ++ ["+" ++ show (len pmc (lookup_sessions Nothing (const True) ps) length sns)]
pps' = pps ++ ["+" ++ show (Map.size (_ps_map ps) length pps)]
sns =
[ T.unpack $ _SessionName $ _sd_name sd
| pw <- Map.elems $ _ps_map ps
, let Password{..} = pw
, Just p <- [parsePwName _pw_name]
, Just prs <- [isSession $ cast_pmc pmc p]
, Right sd <- [prs _pw_text]
, is_primed pw
]
pps =
[ T.unpack $ _PasswordName $ _pw_name pw
| pw <- Map.elems $ _ps_map ps
, _pw_isOneShot pw && is_primed pw
]
len :: PMConfig p -> [(p,Password,Session)] -> Int
len _ = length
hdl (_::SomeException) = exitWith $ ExitFailure 1
passwords :: PW p => PMConfig p -> Bool -> IO ()
passwords pmc br = do
tz <- getCurrentTimeZone
enquire pmc $ \ps ->
putStr $ unlines $ map (fmt tz) $ pws ps
where
fmt :: PW p => TimeZone -> (p,Password) -> String
fmt tz (p,Password{..})
| br = nm_s
| otherwise = printf "%-12s %c %2s $%-18s %s %s" nm_s p_c sn_s ev_s su_s cmt
where
nm_s = T.unpack $ _PasswordName _pw_name
p_c = if _pw_isOneShot then prime_char _pw_primed else ' '
sn_s = case Map.size _pw_sessions of
0 -> ""
n -> show n
ev_s = T.unpack $ _EnvVar $ enVar p
su_s = pretty_setup tz _pw_setup
cmt = case summarize p of
"" -> ""
cs -> "# " ++ cs
pws ps =
[ (cast_pmc pmc p,pwd)
| p <- [minBound..maxBound]
, Just pwd <- [Map.lookup (pwName p) $ _ps_map ps]
]
sessions :: PW p
=> PMConfig p
-> Bool
-> Bool
-> Maybe p
-> IO ()
sessions pmc a b mb = do
tz <- getCurrentTimeZone
enquire pmc $ \ps ->
let trps = case a of
True -> [ trp | trp@(_,pw,_)<-trps_, active_session trp && is_primed pw]
False -> trps_
trps_ = lookup_sessions mb (const True) ps
in
putStr $ unlines $ map (fmt tz) trps
where
fmt tz trp@(_,Password{..},Session{..}) =
case b of
True -> printf "%s" sn_s
False ->
case sgl of
True -> printf "%-16s %c %s %s" sn_s p_c su_s a_s
False -> printf "%-12s %-16s %c %s %s" pn_s sn_s p_c su_s a_s
where
pn_s = T.unpack $ _PasswordName _pw_name
sn_s = T.unpack $ _SessionName _ssn_name
p_c = if _ssn_isOneShot then prime_char False else ' '
su_s = pretty_setup tz _ssn_setup
a_s = if active_session trp then "[ACTIVE]" else "" :: String
sgl = length [ () | p<-[minBound..maxBound], isJust $ isSession $ cast_pmc pmc p ] == 1
infoPassword :: PW p
=> PMConfig p
-> Bool
-> p
-> IO ()
infoPassword pmc sh_s p = do
doc <- infoPassword_ pmc sh_s p
putStr $ P.displayS (P.renderPretty 0.75 120 doc) ""
infoPassword_ :: PW p => PMConfig p -> Bool -> p -> IO P.Doc
infoPassword_ pmc sh_s p = do
tz <- getCurrentTimeZone
enquire pmc $ \ps ->
return $ maybe P.empty (mk tz) $ Map.lookup pnm $ _ps_map ps
where
mk tz pw@Password{..} =
heading P.<$$> P.indent 4 (
sssions P.<>
primed P.<$$>
evar P.<$$>
loaded P.<$$>
secret P.<>
P.empty P.<$$>
descr
) P.<$$>
P.empty
where
heading = P.bold $ P.string $ T.unpack $ _PasswordName pnm
sssions = case isSession p of
Nothing -> P.empty
Just xt -> (line "sessions" $ fmt_sns xt) P.<$$> P.empty
primed = line "primed" $ if is_primed pw then "yes" else "no"
evar = line "env var" $ T.unpack $ _EnvVar $ enVar p
loaded = line "loaded" $ pretty_setup tz $ _pw_setup
descr = P.string $ describe p
secret = case sh_s of
True -> (line "secret" $ T.unpack $ _PasswordText _pw_text) P.<$$> P.empty
False -> P.empty
fmt_sns xt = sn ++ " / " ++ unwords (map (T.unpack . _SessionName) $ filter fl sns)
where
sn = either (\s->"<<"++s++">>") (T.unpack . _SessionName . _sd_name ) ei
fl = either (\_ _->False) (\sd sn'->_sd_name sd/=sn') ei
ei = xt _pw_text
sns = Map.keys _pw_sessions
line :: String -> String -> P.Doc
line nm vl = P.bold(P.string $ ljust 8 nm) P.<> P.string " : " P.<>
P.hang 8 (P.string vl)
pnm = pwName p
ljust n s = s ++ replicate (max 0 (nlength s)) ' '
dump :: PW p => PMConfig p -> Bool -> IO ()
dump pmc inc_ssns = enquire pmc dmp >> prime pmc True Nothing
where
dmp ps@PasswordStore{..} = putStr $ format_dump (_pmc_dump_prefix pmc) _ps_comment al_l al_s
where
al_l =
[ (p,_pw_text pw)
| p <- [minBound..maxBound]
, Just pw <- [Map.lookup (pwName $ cast_pmc pmc p) _ps_map]
, isNothing $ isSession p
, is_primed pw
] ++
[ (p,_ssn_password ssn)
| inc_ssns
, (p,_,ssn) <- lookup_sessions Nothing (const True) ps
]
al_s =
[ (p,_sd_name sd)
| inc_ssns
, p <- [minBound..maxBound]
, Just pw <- [Map.lookup (pwName $ cast_pmc pmc p) _ps_map]
, Just ext <- [isSession p]
, Right sd <- [ext $ _pw_text pw]
]
collectShell :: PW p => PMConfig p -> IO ()
collectShell pmc = collect pmc defaultCollectConfig >> _pmc_shell pmc
is_primed :: Password -> Bool
is_primed Password{..} = not _pw_isOneShot || _pw_primed
lookup_session :: PW p => Maybe p -> SessionName -> PasswordStore -> IO (p,Password,Session)
lookup_session mb snm ps =
case lookup_sessions mb (==snm) ps of
[] -> err "session not loaded"
[r] -> return r
_ -> err "matches multiple sessions"
where
err msg = ssn_error $ "lookup_session: " ++ T.unpack(_SessionName snm) ++ ": " ++ msg
lookup_sessions :: PW p => Maybe p -> (SessionName->Bool) -> PasswordStore -> [(p,Password,Session)]
lookup_sessions mb f ps =
[ (p,pw,ssn)
| p <- [minBound..maxBound]
, maybe True (p==) mb
, isJust $ isSession p
, let pnm = pwName p
, Just pw <- [Map.lookup pnm $ _ps_map ps]
, ssn <- filter (f . _ssn_name) $ Map.elems $ _pw_sessions pw
]
active_session :: PW p => (p,Password,Session) -> Bool
active_session (p,Password{..},Session{..}) = not $ null
[ ()
| Just ext <- [isSession p]
, Right sd <- [ext _pw_text]
, _sd_name sd == _ssn_name
]
get_pw :: PW p => PMConfig p -> IO PasswordText
get_pw pmc = do
hSetEcho stdin False
putStr "Password: "
hFlush stdout
pw <- getLine
putChar '\n'
hSetEcho stdin True
return $ hashMasterPassword pmc pw
prime_char :: Bool -> Char
prime_char is_p = if is_p then '+' else '-'
format_dump :: PW p
=> String
-> PasswordStoreComment
-> [(p,PasswordText)]
-> [(p,SessionName)]
-> String
format_dump pfx ps_cmt al_l al_s =
unlines $
(printf "%s comment %s ;" pfx $ esc $ T.unpack $ _PasswordStoreComment ps_cmt) :
[ printf "%s load %-12s %-20s %-30s ;" pfx pnm_s ptx_s $ cmt_s p
| (p,ptx) <- al_l
, let pnm_s = T.unpack $ _PasswordName $ pwName p
, let ptx_s = T.unpack $ _PasswordText ptx
] ++
[ printf "%s select -p %s %s ;" pfx pnm_s snm_s
| (p,snm) <- al_s
, let pnm_s = T.unpack $ _PasswordName $ pwName p
, let snm_s = T.unpack $ _SessionName snm
]
where
cmt_s p = case summarize p of
"" -> ""
s -> "# " ++ esc s
esc s = '\'' : foldr tr "\'" s
where
tr '\'' t = '\\' : '\'' : t
tr c t = c : t
wrap_def :: PW p => PMConfig p -> (PasswordStore -> IO (Maybe PasswordStore)) -> IO ()
wrap_def pmc f = maybe (return ()) (wrap' pmc f) =<< get_key' pmc
wrap :: PW p => PMConfig p -> (PasswordStore -> IO (Maybe PasswordStore)) -> IO ()
wrap pmc f = get_key pmc >>= wrap' pmc f
wrap' :: PW p => PMConfig p -> (PasswordStore -> IO (Maybe PasswordStore)) -> AESKey -> IO ()
wrap' pmc f aek = do
pws <- load_ps pmc aek
mb <- f pws
maybe (return ()) (save_ps pmc aek) mb
enquire :: PW p => PMConfig p -> (PasswordStore -> IO a) -> IO a
enquire pmc f = do
aek <- get_key pmc
load_ps pmc aek >>= f
password_valid :: PW p => PMConfig p -> AESKey -> IO Bool
password_valid pmc aek = catch ld hd
where
ld = const True <$> load_ps pmc aek
hd (_::SomeException) = return False
load_ps :: PW p => PMConfig p -> AESKey -> IO PasswordStore
load_ps pmc aek = do
aed <- load_ps' pmc
case decodeWithErrs $ BL.fromChunks [_Binary $ _ClearText $ decryptAES aek aed] of
Right pws -> return pws
Left ers -> error $ prettyJSONErrorPositions ers
save_ps :: PW p => PMConfig p -> AESKey -> PasswordStore -> IO ()
save_ps pmc aek pws = do
iv <- random_bytes sizeAesIV IV
save_ps' pmc $ encryptAES aek iv $ ClearText $ Binary $ BL.toStrict $ A.encode pws
load_ps' :: PW p => PMConfig p -> IO AESSecretData
load_ps' PMConfig{..} = flip catch hdl $ do
(iv,ct) <- B.splitAt (_Octets sizeAesIV) <$> B.readFile _pmc_location
return
AESSecretData
{ _asd_iv = IV $ Binary iv
, _asd_secret_data = SecretData $ Binary ct
}
where
hdl (_::SomeException) = error _pmc_keystore_msg
random_bytes :: Octets -> (Binary->a) -> IO a
random_bytes sz f = f . Binary . fst . generateCPRNG (_Octets sz) <$> newCPRNG
save_ps' :: PW p => PMConfig p -> AESSecretData -> IO ()
save_ps' PMConfig{..} AESSecretData{..} = B.writeFile _pmc_location $ B.concat [iv_bs,ct_bs]
where
iv_bs = _Binary $ _IV _asd_iv
ct_bs = _Binary $ _SecretData _asd_secret_data
get_key :: PW p => PMConfig p -> IO AESKey
get_key pmc@PMConfig{..} = get_key' pmc >>= maybe (not_logged_in_err pmc) return
not_logged_in_err :: PW p => PMConfig p -> IO a
not_logged_in_err pmc@PMConfig{..} = do
ex <- isStorePresent pmc
error $ if ex then _pmc_password_msg else _pmc_keystore_msg
get_key' :: PW p => PMConfig p -> IO (Maybe AESKey)
get_key' PMConfig{..} = fmap mk_aek' <$> E.lookupEnv var
where
var = T.unpack $ _EnvVar _pmc_env_var
mk_aek :: PasswordText -> AESKey
mk_aek = mk_aek' . T.unpack . _PasswordText
mk_aek' :: String -> AESKey
mk_aek' = AESKey . Binary . either err id . B64.decode . B.pack
where
err = error "bad format for the master password"
pretty_setup :: TimeZone -> UTCTime -> String
pretty_setup tz = formatTime defaultTimeLocale "%F %H:%M" . utcToZonedTime tz
set_env :: EnvVar -> PasswordText -> IO ()
set_env (EnvVar ev) (PasswordText pt) = setEnv (T.unpack ev) (T.unpack pt)
ssn_error :: String -> a
ssn_error msg = error $ "session manager error: " ++ msg
data PMCommand p
= PMCD_version
| PMCD_setup Bool (Maybe PasswordText)
| PMCD_login Bool (Maybe PasswordText)
| PMCD_load p (Maybe PasswordText)
| PMCD_comment PasswordStoreComment
| PMCD_prime Bool p
| PMCD_prime_all Bool
| PMCD_select (Maybe p) SessionName
| PMCD_delete_password p
| PMCD_delete_session (Maybe p) SessionName
| PMCD_status Bool
| PMCD_passwords Bool
| PMCD_sessions Bool Bool (Maybe p)
| PMCD_info Bool p
| PMCD_dump Bool
| PMCD_collect
| PMCD_sample_script
deriving (Show)
parse_command :: PW p => PMConfig p -> [String] -> IO (PMCommand p)
parse_command pmc = run_parse $ command_info pmc
command_info :: PW p => PMConfig p -> ParserInfo (PMCommand p)
command_info pmc =
O.info (helper <*> command_parser pmc)
( fullDesc
<> progDesc "a simple password manager"
<> header "pm - sub-command for managing the password store"
<> footer "'ks COMMAND --help' to get help on each command")
command_parser :: PW p => PMConfig p -> Parser (PMCommand p)
command_parser pmc =
subparser $ f $ g
$ command "version" pi_version
<> command "setup" pi_setup
<> command "login" pi_login
<> command "load" pi_load
<> command "comment" pi_comment
<> command "prime" pi_prime
<> command "prime-all" pi_prime_all
<> command "select" pi_select
<> command "delete-password" pi_delete_password
<> command "delete-session" pi_delete_session
<> command "status" pi_status
<> command "passwords" pi_passwords
<> command "sessions" pi_sessions
<> command "info" pi_info
<> command "collect" pi_collect
where
s = command "sample-load-script" pi_sample_script
d = command "dump" pi_dump
f = case _pmc_sample_script pmc of
Nothing -> id
Just _ -> (<> s)
g = case _pmc_allow_dumps pmc of
True -> (<> d)
False -> id
pi_version :: ParserInfo (PMCommand p)
pi_version =
h_info
(helper <*> pure PMCD_version)
(progDesc "report the version of this package")
pi_setup :: ParserInfo (PMCommand p)
pi_setup =
h_info
(helper <*> (PMCD_setup <$> p_no_login_sw <*> optional p_password_text))
(progDesc "setup the password store")
pi_login :: ParserInfo (PMCommand p)
pi_login =
h_info
(helper <*> (PMCD_login <$> p_loop_sw <*> optional p_password_text))
(progDesc "login to the password manager")
pi_load :: PW p => ParserInfo (PMCommand p)
pi_load =
h_info
(helper <*> (PMCD_load <$> p_pw_id <*> optional p_password_text) <* optional p_load_comment)
(progDesc "load a password into the store")
pi_comment :: PW p => ParserInfo (PMCommand p)
pi_comment =
h_info
(helper <*> (PMCD_comment <$> p_ps_comment))
(progDesc "load a password into the store")
pi_prime :: PW p => ParserInfo (PMCommand p)
pi_prime =
h_info
(helper <*> (PMCD_prime <$> p_unprime_sw <*> p_pw_id))
(progDesc "(un) prime a password for use")
pi_prime_all :: ParserInfo (PMCommand p)
pi_prime_all =
h_info
(helper <*> (PMCD_prime_all <$> p_unprime_sw))
(progDesc "(un)prime all of the passwords")
pi_select :: PW p => ParserInfo (PMCommand p)
pi_select =
h_info
(helper <*> (PMCD_select <$> optional p_pw_id_opt <*> p_session_name))
(progDesc "select a client session")
pi_delete_password :: PW p => ParserInfo (PMCommand p)
pi_delete_password =
h_info
(helper <*> (PMCD_delete_password <$> p_pw_id))
(progDesc "select a client session")
pi_delete_session :: PW p => ParserInfo (PMCommand p)
pi_delete_session =
h_info
(helper <*> (PMCD_delete_session <$> optional p_pw_id_opt <*> p_session_name))
(progDesc "delete a client session")
pi_status :: ParserInfo (PMCommand p)
pi_status =
h_info
(helper <*> (PMCD_status <$> p_quiet_sw))
(progDesc "report the status of the password manager")
pi_passwords :: ParserInfo (PMCommand p)
pi_passwords =
h_info
(helper <*> (PMCD_passwords <$> p_brief_sw))
(progDesc "list the passwords")
pi_sessions :: PW p => ParserInfo (PMCommand p)
pi_sessions =
h_info
(helper <*> (PMCD_sessions <$> p_active_sw <*> p_brief_sw <*> optional p_pw_id))
(progDesc "list the sessions")
pi_info :: PW p => ParserInfo (PMCommand p)
pi_info =
h_info
(helper <*> (PMCD_info <$> p_secret_sw <*> p_pw_id))
(progDesc "print out the info on a password, including desriptive text")
pi_dump :: PW p => ParserInfo (PMCommand p)
pi_dump =
h_info
(helper <*> (PMCD_dump <$> p_sessions_sw))
(progDesc "dump the passwords on the output as a load script")
pi_collect :: PW p => ParserInfo (PMCommand p)
pi_collect =
h_info
(helper <*> (pure PMCD_collect))
(progDesc "collect the passwords and launch an interacive shell")
pi_sample_script :: ParserInfo (PMCommand p)
pi_sample_script =
h_info
(helper <*> (pure PMCD_sample_script))
(progDesc "print a sample script to define keystore passwords in the environment (PM edition)")
p_no_login_sw :: Parser Bool
p_no_login_sw =
switch
(short 'n' <>
long "no-login" <>
help "do not launch an interactive shell")
p_loop_sw :: Parser Bool
p_loop_sw =
switch
(short 'l' <>
long "loop" <>
help "on failure prompt for a new password and try again")
p_quiet_sw :: Parser Bool
p_quiet_sw =
switch
(short 'q' <>
long "quiet" <>
help "don't print anything but report with error codes (0=>logged in)")
p_brief_sw :: Parser Bool
p_brief_sw =
switch
(short 'b' <>
long "brief" <>
help "list the identifiers only")
p_active_sw :: Parser Bool
p_active_sw =
switch
(short 'a' <>
long "active" <>
help "list the active sessions only")
p_unprime_sw :: Parser Bool
p_unprime_sw =
switch
(short 'u' <>
long "unprime" <>
help "clear the prime status")
p_secret_sw :: Parser Bool
p_secret_sw =
switch
(short 's' <>
long "secret" <>
help "show the secret password")
p_sessions_sw :: Parser Bool
p_sessions_sw =
switch
(long "sessions" <>
help "include the sessions")
p_pw_id :: PW p => Parser p
p_pw_id =
argument (parsePwName . PasswordName . T.pack)
$ metavar "PASSWORD-ID"
<> help "a password ID"
p_pw_id_opt :: PW p => Parser p
p_pw_id_opt =
nullOption
$ long "id"
<> short 'p'
<> metavar "PASSWORD-ID"
<> reader (maybe (fail "password-id not recognised") return . parsePwName . PasswordName . T.pack)
<> help "a password ID"
p_password_text :: Parser PasswordText
p_password_text =
argument (Just . PasswordText . T.pack)
$ metavar "PASSWORD-TEXT"
<> help "the text of the password"
p_session_name :: Parser SessionName
p_session_name =
argument (Just . SessionName . T.pack)
$ metavar "SESSION"
<> help "a session name"
p_load_comment :: Parser ()
p_load_comment = const () <$> optional (p_hash <* p_comment)
p_ps_comment :: Parser PasswordStoreComment
p_ps_comment = PasswordStoreComment . T.pack <$> p_comment
p_hash :: Parser ()
p_hash = argument (\s->if s=="#" then Just () else Nothing) $ metavar "#"
p_comment :: Parser String
p_comment = unwords <$> many p_word
p_word :: Parser String
p_word = argument Just $ metavar "WORD"
h_info :: Parser a -> InfoMod a -> ParserInfo a
h_info pr = O.info (helper <*> pr)
run_parse :: ParserInfo a -> [String] -> IO a
run_parse pinfo args =
case execParserPure (prefs idm) pinfo args of
Success a -> return a
Failure failure -> do
progn <- E.getProgName
let (msg, exit) = execFailure failure progn
case exit of
ExitSuccess -> putStrLn msg
_ -> hPutStrLn stderr msg
exitWith exit
CompletionInvoked compl -> do
progn <- E.getProgName
msg <- execCompletion compl progn
putStr msg
exitWith ExitSuccess