diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -66,3 +66,8 @@ 0.5.0.4 Chris Dornan 2014-08-24 * improve diagnostics for internally used Sections.keySection * add roateIfChanged to Sections (squashes vacuous rotations) + +0.5.1.0 Chris Dornan 2014-09-08 + * fix the repo location in the cabal file + * fix smart rotate to not rotate keys it cannot access + * add password manager diff --git a/examples/deploy/Deploy/Command.hs b/examples/deploy/Deploy/Command.hs --- a/examples/deploy/Deploy/Command.hs +++ b/examples/deploy/Deploy/Command.hs @@ -24,16 +24,18 @@ = Create | Rotate (Maybe HostID) (Maybe SectionID) (Maybe KeyID) | RotateSmart (Maybe HostID) (Maybe SectionID) (Maybe KeyID) - | Deploy (Maybe FilePath) HostID + | Deploy Bool (Maybe FilePath) HostID + | Client | Sign | Verify | ListHosts - | InfoKey (Maybe KeyID ) - | InfoSection (Maybe SectionID) + | InfoKey (Maybe KeyID ) + | InfoSection (Maybe SectionID) | SecretScript | PublicScript | SampleScript - | KS [String] + | KS [String] + | PM [String] deriving (Show) parseCLI :: IO CLI @@ -41,6 +43,7 @@ args <- getArgs case span is_flg args of (flgs,"ks":args') -> runParse (pi_cli $ p_ks args') flgs + (flgs,"pm":args') -> runParse (pi_cli $ p_pm args') flgs _ -> runParse (pi_cli p_cli ) args pi_cli :: Parser CLI -> ParserInfo CLI @@ -52,6 +55,9 @@ p_ks :: [String] -> Parser CLI p_ks args = CLI <$> paramsParser <*> pure (KS args) +p_pm :: [String] -> Parser CLI +p_pm args = CLI <$> paramsParser <*> pure (PM args) + p_cli :: Parser CLI p_cli = CLI <$> paramsParser <*> p_command @@ -62,6 +68,7 @@ <> command "rotate" (pi_rotate_key False) <> command "rotate-smart" (pi_rotate_key True ) <> command "deploy" pi_deploy + <> command "client" pi_client <> command "sign" pi_sign <> command "verify" pi_verify <> command "list-hosts" pi_list_hosts @@ -69,8 +76,9 @@ <> command "info-section" pi_info_section <> command "secret-script" pi_secret_script <> command "public-script" pi_public_script - <> command "sample-script" pi_sample_script + <> command "sample-load-script" pi_sample_script <> command "ks" pi_ks_args + <> command "pm" pi_pm_args pi_create :: ParserInfo Command pi_create = @@ -91,10 +99,18 @@ pi_deploy :: ParserInfo Command pi_deploy = h_info - (helper <*> (Deploy <$> optional p_out <*> p_host_arg)) - (progDesc $ "deploy a configuration file for s host " ++ + (helper <*> (Deploy <$> p_shell_flg <*> optional p_out <*> p_host_arg)) + (progDesc $ "deploy a configuration file for a host " ++ "(here merely generating the JSON configuration file)") +pi_client :: ParserInfo Command +pi_client = + h_info + (helper <*> (pure Client)) + (progDesc $ "run a mock client " ++ + "(here merely displays the session token)") + + pi_sign :: ParserInfo Command pi_sign = h_info @@ -122,7 +138,7 @@ pi_info_section :: ParserInfo Command pi_info_section = h_info - (helper <*> (InfoSection <$> optional p_section)) + (helper <*> (InfoSection <$> optional p_a_section)) (progDesc "get the gen on the keystore sections") pi_secret_script :: ParserInfo Command @@ -146,9 +162,21 @@ pi_ks_args :: ParserInfo Command pi_ks_args = h_info - (helper <*> (KS <$> many p_ks_arg)) + (helper <*> (KS <$> many p_arg)) (progDesc "run a ks command (see 'ks --help' for details)") +pi_pm_args :: ParserInfo Command +pi_pm_args = + h_info + (helper <*> (KS <$> many p_arg)) + (progDesc "run a pm command (see 'pm --help' for details)") + +p_shell_flg :: Parser Bool +p_shell_flg = + switch + (long "shell" <> + help "launch a shell with the deploy passwords setup in their environment variables") + p_host_arg :: Parser HostID p_host_arg = argument decode @@ -171,26 +199,32 @@ <> reader (maybe (fail "section not recognised") return . decode) <> help "a section ID" +p_a_section :: Parser SectionID +p_a_section = + argument decode + $ metavar "SECTION" + <> help "a section ID" + p_key :: Parser KeyID p_key = nullOption - $ long "key" - <> metavar "KEY" + $ long "key" + <> metavar "KEY" <> reader (maybe (fail "key not recognised") return . decode) - <> help "a key ID" + <> help "a key ID" p_out :: Parser FilePath p_out = strOption - $ long "out" - <> metavar "FILE" - <> help "output file" + $ long "out" + <> metavar "FILE" + <> help "output file" -p_ks_arg :: Parser String -p_ks_arg = +p_arg :: Parser String +p_arg = argument Just - $ metavar "KS-ARG" - <> help "a ks command argument" + $ metavar "ARG" + <> help "a sub-command argument" h_info :: Parser a -> InfoMod a -> ParserInfo a h_info pr = info (helper <*> pr) diff --git a/examples/deploy/Deploy/HostSectionKey.hs b/examples/deploy/Deploy/HostSectionKey.hs --- a/examples/deploy/Deploy/HostSectionKey.hs +++ b/examples/deploy/Deploy/HostSectionKey.hs @@ -36,6 +36,7 @@ | S_us_deploy | S_us_staging | S_dev + | S_session deriving (Show, Ord, Eq, Bounded, Enum) dev, staging, deploy, admin :: SectionID -> Bool @@ -106,6 +107,7 @@ S_us_deploy -> [S_us_admin ] S_us_staging -> [S_us_deploy ] S_dev -> [S_eu_staging,S_us_staging] + S_session -> [S_dev ] key_is_host_indexed :: KeyID -> Maybe (HostID->Bool) key_is_host_indexed k = @@ -193,6 +195,7 @@ S_us_deploy -> "has access to all of the keys needed for the 'us' live server deployment" S_us_staging -> "has access to all of the keys needed for the 'us' staging server deployment" S_dev -> "contains all of the keys needed to deploy a development server" + S_session -> "this section does not contain any keys (the section is needed for the password manager)" is_ssl :: HostID -> Bool is_ssl h = @@ -202,3 +205,48 @@ H_live_us -> True H_staging_us -> True H_dev -> False + + +-- +-- Password Manager Definitions +-- + +instance PW SectionID where + + pwName = PasswordName . T.pack . encode + + isSession sid = case sid of + S_session -> Just extract_ssn + _ -> Nothing + + isOneShot sid = case sid of + S_top -> True + S_eu_admin -> True + S_eu_deploy -> True + S_us_admin -> True + S_us_deploy -> True + _ -> False + + summarize s = + case s of + S_top -> "top key: accesses everything" + S_signing -> "keystore signing key" + S_eu_admin -> "eu admin keys" + S_eu_deploy -> "eu deploy keys" + S_eu_staging -> "eu staging deployment keys" + S_us_admin -> "us admin keys" + S_us_deploy -> "us deploy keys" + S_us_staging -> "us staging keys" + S_dev -> "dev deployment keys" + S_session -> "client sessions tokens" + + describe = describe_section + +extract_ssn :: PasswordText -> Either String SessionDescriptor +extract_ssn (PasswordText pwt) = Right $ + SessionDescriptor + { _sd_name = snm + , _sd_isOneShot = snm=="master" + } + where + snm = SessionName $ T.takeWhile (/= ':') pwt diff --git a/examples/deploy/deploy.hs b/examples/deploy/deploy.hs --- a/examples/deploy/deploy.hs +++ b/examples/deploy/deploy.hs @@ -9,11 +9,15 @@ import Deploy.Command import Deploy.HostSectionKey import Data.KeyStore +import Data.API.Types import Data.KeyStore as KS import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Text as T import qualified Data.Text.IO as T import System.IO +import System.Environment +import System.Process import Control.Applicative import Control.Exception @@ -22,18 +26,38 @@ ks_fp = "deploy-keystore.json" ks_mac_fp = "deploy-keystore.hash" +pmc :: PMConfig SectionID +pmc = + PMConfig + { _pmc_location = "pwstore.dat" + , _pmc_env_var = "DEPLOY_MASTER" + , _pmc_keystore_msg = "keystore not found (use 'deploy pm setup' to set one up)" + , _pmc_password_msg = "not logged into the password manager (use 'deploy pm login')" + , _pmc_shell = interactive_shell + , _pmc_hash_descr = defaultHashDescription $ Salt $ Binary "MX#0YoSCt8RcWm&E" + , _pmc_allow_dumps = True + , _pmc_dump_prefix = dump_pfx + , _pmc_sample_script = Just $ defaultSampleScript (PW_ :: PW_ SectionID) dump_pfx + } + where + dump_pfx = "deploy pm" + main :: IO () main = do CLI{..} <- parseCLI let cp0 = cli_params cp = cp0 { cp_store = cp_store cp0 <|> Just ks_fp } case cli_command of - Create -> initialise cp no_keys - ListHosts -> mapM_ (putStrLn . encode) $ [minBound..maxBound :: HostID] - SampleScript -> mapM_ sample_ln [minBound..maxBound] - KS args -> KS.cli' (Just cp) args - _ -> - do ic <- instanceCtx cp + Create -> collect pmc create_cc >> initialise cp no_keys + ListHosts -> mapM_ (putStrLn . encode) $ [minBound..maxBound :: HostID] + SampleScript -> mapM_ sample_ln [minBound..maxBound] + KS args -> collect pmc deploy_cc >> KS.cli' (Just cp) args + PM args -> passwordManager pmc args + _ -> + do case cli_command of + Client -> collect pmc client_cc + _ -> collect pmc deploy_cc + ic <- instanceCtx cp let ic_ro = ic { ic_ctx_params = cp {cp_readonly = cp_readonly cp <|> Just True} } case cli_command of Sign -> return () @@ -42,7 +66,9 @@ Create -> error "main: Initialise" Rotate mbh mbs mbk -> rotate ic $ key_prededicate mbh mbs mbk RotateSmart mbh mbs mbk -> rotateIfChanged ic $ key_prededicate mbh mbs mbk - Deploy mb hst -> deploy ic_ro hst >>= write mb + Deploy False mb hst -> deploy ic_ro hst >>= write mb + Deploy True _ _ -> interactive_shell + Client -> lookupEnv "KEY_pw_session" >>= putStrLn . ("session-token=>" ++) . maybe "NONE" id Sign -> sign_ks ic_ro Verify -> T.putStrLn "the keystore matches the signature" ListHosts -> error "main: ListHosts" @@ -52,8 +78,14 @@ PublicScript -> publicKeySummary ic sections ks_mac_fp >>= T.putStr SampleScript -> error "main: SampleScript" KS _ -> error "main: KS" + PM _ -> error "main: PM" verify_ks False ic_ro +create_cc, deploy_cc, client_cc :: CollectConfig SectionID +create_cc = CollectConfig True [minBound..maxBound] +deploy_cc = CollectConfig True $ filter (/=S_session) [minBound..maxBound] +client_cc = CollectConfig False [S_session] + sign_ks :: IC -> IO () sign_ks ic = signKeystore ic sections >>= B.writeFile ks_mac_fp @@ -76,9 +108,17 @@ key_prededicate = keyPrededicate sample_ln :: SectionID -> IO () -sample_ln s = putStrLn $ "export " ++ "KEY_pw_" ++ s_ ++ "=pw_" ++ s_ ++ ";" +sample_ln s = putStrLn $ "export " ++ v_ ++ "=secret-" ++ s_ ++ ";" where + v_ = T.unpack $ _EnvVar $ enVar s s_ = encode s + +interactive_shell :: IO () +interactive_shell = do + sh <- maybe "/bin/bash" id <$> lookupEnv "SHELL" + putStrLn $ "launching password-manager shell => " ++ sh + callProcess sh ["-i"] + putStrLn "password-manager shell done" write :: Maybe FilePath -> LBS.ByteString -> IO () write = maybe LBS.putStrLn LBS.writeFile diff --git a/keystore.cabal b/keystore.cabal --- a/keystore.cabal +++ b/keystore.cabal @@ -1,5 +1,5 @@ Name: keystore -Version: 0.5.0.4 +Version: 0.5.1.0 Synopsis: Managing stores of secret things Homepage: http://github.com/cdornan/keystore Author: Chris Dornan @@ -88,9 +88,9 @@ * /External Crypto Operations/: keys in the keystore can be used to sign or encrypt external obejcts (provided they can be loaded into memory). . - /The Onion/ + /The Layers/ . - Perhaps apropriately, the keystore package has several layers. Most users + The keystore package has several layers. Most users will probably need only the top "batteries-included" layer: . * @Data.KeyStore.Sections@: this provides a high-level model that allows @@ -101,6 +101,10 @@ and editing your keystores. It can also be embedded into your own deployment app. See the @deploy@ example for details. . + * @Data.KeyStore.PasswordManager@ provides a password manager which each + user can use to setup their own local password store for holding the + deployment passwords and session tokens used to autheticate the server. + . * @Data.KeyStore.IO@: this library provides general programatic access to a keystore through @IO@ primitives. See the source code for the @Sections@ for an example of this module in use. @@ -116,20 +120,13 @@ . See the bottom on GitHub home page for launch instructions for the deploy example. - . - /0.5 Migration instructions/ - . - The formation of the names used in 'Data.Keystore.Sections' derived keystores - has changed to fix an issue (#3) that barred hosts, sections and key identifiers - from being prefixes of each other. See the changelog for details, especially - on how to ensure that an existing Sections-based keystore gets migrated properly. Extra-source-files: changelog Cabal-version: >= 1.14 Source-repository head type: git - location: https://github.com/iconnect/keystore + location: https://github.com/cdornan/keystore flag hpc default: False @@ -153,16 +150,21 @@ Data.KeyStore.KS.KS Data.KeyStore.KS.Opt Data.KeyStore.KS.Packet + Data.KeyStore.PasswordManager Data.KeyStore.Sections Data.KeyStore.Types Data.KeyStore.Types.E Data.KeyStore.Types.NameAndSafeguard + Data.KeyStore.Types.PasswordStoreModel + Data.KeyStore.Types.PasswordStoreSchema Data.KeyStore.Types.Schema + Data.KeyStore.Version Build-depends: api-tools >= 0.4 , asn1-types >= 0.2.0 , asn1-encoding >= 0.8.0 , + ansi-wl-pprint >= 0.6.7 , crypto-pubkey >= 0.2.1 , crypto-random >= 0.0.7 , aeson >= 0.6.2 , @@ -178,10 +180,11 @@ lens >= 3.9.2 , mtl >= 2 , old-locale >= 1.0.0.5 , - optparse-applicative >= 0.9.0 , + optparse-applicative >= 0.9.0 && <0.10 , pbkdf >= 1.1.1.0 , regex-compat-tdfa >= 0.95.1 , safe >= 0.3.3 , + setenv >= 0.1 , text >= 0.11.3 , time >= 1.4 , unordered-containers >= 0.2.3.0 , @@ -190,7 +193,7 @@ Default-Language: Haskell2010 GHC-Options: - -fwarn-tabs + -Wall -fno-warn-warnings-deprecations Executable ks @@ -205,7 +208,7 @@ keystore GHC-Options: - -fwarn-tabs + -Wall -fno-warn-warnings-deprecations Executable deploy Hs-Source-Dirs: examples/deploy @@ -220,6 +223,8 @@ Deploy.HostSectionKey Build-depends: + api-tools >= 0.4 , + ansi-wl-pprint >= 0.6.7.1 , aeson >= 0.6.2 , base > 4 && < 5 , bytestring >= 0.9 , @@ -228,9 +233,11 @@ keystore , mtl >= 2 , optparse-applicative >= 0.9.0 , + process >= 1.2.0.0 , raw-strings-qq >= 1.0.2 , text >= 0.11 , unordered-containers >= 0.2.3.0 + GHC-Options: - -fwarn-tabs + -Wall -fno-warn-warnings-deprecations diff --git a/src/Data/KeyStore.hs b/src/Data/KeyStore.hs --- a/src/Data/KeyStore.hs +++ b/src/Data/KeyStore.hs @@ -2,8 +2,10 @@ ( module Data.KeyStore.CLI , module Data.KeyStore.IO , module Data.KeyStore.Sections + , module Data.KeyStore.PasswordManager ) where -import Data.KeyStore.Sections import Data.KeyStore.CLI import Data.KeyStore.IO +import Data.KeyStore.Sections +import Data.KeyStore.PasswordManager diff --git a/src/Data/KeyStore/CLI.hs b/src/Data/KeyStore/CLI.hs --- a/src/Data/KeyStore/CLI.hs +++ b/src/Data/KeyStore/CLI.hs @@ -10,6 +10,7 @@ import Data.KeyStore.IO import Data.KeyStore.KS.Opt import Data.KeyStore.CLI.Command +import Data.KeyStore.Version import qualified Data.Text.IO as T import qualified Data.ByteString.Char8 as B import Control.Applicative @@ -17,9 +18,6 @@ import System.Exit -version :: String -version = "0.5.0.4" - cli :: IO () cli = parseCLI >>= command Nothing @@ -80,7 +78,7 @@ - oops = error "command: this ic should ne be used" + oops = error "command: this ic should not be used" create :: IC -> Name diff --git a/src/Data/KeyStore/KS/Crypto.hs b/src/Data/KeyStore/KS/Crypto.hs --- a/src/Data/KeyStore/KS/Crypto.hs +++ b/src/Data/KeyStore/KS/Crypto.hs @@ -5,7 +5,9 @@ {-# LANGUAGE BangPatterns #-} module Data.KeyStore.KS.Crypto - ( defaultEncryptedCopyKS + ( sizeAesIV + , sizeOAE + , defaultEncryptedCopyKS , saveKS , restoreKS , mkAESKeyKS @@ -28,6 +30,7 @@ , randomAESKeyKS , randomIVKS , hashKS + , defaultHashParams , defaultHashParamsKS , hashKS_ , generateKeysKS @@ -61,9 +64,9 @@ import Crypto.Cipher.AES -size_aes_iv, size_oae :: Octets -size_aes_iv = 16 -size_oae = 256 +sizeAesIV, sizeOAE :: Octets +sizeAesIV = 16 +sizeOAE = 256 -- @@ -193,8 +196,8 @@ decodeRSASecretData_ :: B.ByteString -> E RSASecretData decodeRSASecretData_ dat0 = - do (eky,dat1) <- slice size_oae dat0 - (iv ,edat) <- slice size_aes_iv dat1 + do (eky,dat1) <- slice sizeOAE dat0 + (iv ,edat) <- slice sizeAesIV dat1 return RSASecretData { _rsd_encrypted_key = RSAEncryptedKey $ Binary eky @@ -280,7 +283,7 @@ randomAESKeyKS cip = randomBytes (keyWidth cip) (AESKey . Binary) randomIVKS :: KS IV -randomIVKS = randomBytes size_aes_iv (IV . Binary) +randomIVKS = randomBytes sizeAesIV (IV . Binary) -- @@ -290,6 +293,9 @@ hashKS :: ClearText -> KS Hash hashKS ct = flip hashKS_ ct <$> defaultHashParamsKS + +defaultHashParams :: HashDescription +defaultHashParams = trun defaultHashParamsKS defaultHashParamsKS :: KS HashDescription defaultHashParamsKS = diff --git a/src/Data/KeyStore/PasswordManager.hs b/src/Data/KeyStore/PasswordManager.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/PasswordManager.hs @@ -0,0 +1,1019 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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 System.Environment +import System.Exit +import System.IO +import System.Locale +import qualified Options.Applicative as O +import Options.Applicative + + +-- | The password manager is used for storing locally the passwords and session +-- tokens of a single user. The password used to encode the store is stored in +-- an environment variable and the passwords and tokens are stored in a file. +-- The file and and environment cariable are specified in the 'PWConfig' record. +-- (The attributes of each password and session list, including the environment +-- variables that they are communicated through, is statically specified +-- with the PW class below.) + +data PMConfig p = + PMConfig + { _pmc_location :: FilePath -- ^ file in which to store the encrypted passords + , _pmc_env_var :: EnvVar -- ^ the environmant variable containing the master password used to secure the store + , _pmc_keystore_msg :: String -- ^ error message to be used on failure to locate the keystore + , _pmc_password_msg :: String -- ^ error message to be used on failure to locate the master password + , _pmc_shell :: IO () -- ^ for firing up an interactive shell on successful login + , _pmc_hash_descr :: HashDescription + -- ^ for generating has descriptions (can use 'defaultHashDescription' here) + , _pmc_allow_dumps :: Bool -- ^ must be true to enable 'dump' commands + , _pmc_dump_prefix :: String -- ^ the prefix string to be used in making up the commands from dump scripts + , _pmc_sample_script :: Maybe String -- ^ the sample script + } + +-- | The PW class provides all of the information on the bounded enumeration type used to identify the passwords +class (Bounded p,Enum p,Eq p, Ord p,Show p) => PW p where + -- | the name by which the password is known + pwName :: p -> PasswordName + pwName = PasswordName . T.pack . show + -- | parse a PasswordName into a p + parsePwName :: PasswordName -> Maybe p + parsePwName = \pnm -> listToMaybe [ p | p<-[minBound..maxBound], pwName p == pnm ] + -- | whether the passwords is a session and if so a function for extracting the session name from the secret password text + isSession :: p -> Maybe (PasswordText -> Either String SessionDescriptor) + isSession = const Nothing + -- | whether the password is a one-shot password, needing to be primed to be used + isOneShot :: p -> Bool + isOneShot = const False + -- | the environment variable where the password is expected to be found by the client/deployment scripts + enVar :: p -> EnvVar + enVar = EnvVar . (T.append "KEY_pw_") . _PasswordName . pwName + -- | a brief description of the password in a few words + summarize :: p -> String + summarize _ = "" + -- | a description of the password + describe :: p -> String + describe p = (T.unpack $ _PasswordName $ pwName p) ++ ": description to follow" + +-- | we resort to phantom types when we have no other way of passing PW into a +-- function (see 'defaultSampleScript') +data PW_ p = PW_ + +cast_pmc :: PMConfig p -> p -> p +cast_pmc _ p = p + +cast_pw :: PW_ p -> p -> p +cast_pw _ p = p + +-- each session is named and may be a one-shot session +data SessionDescriptor = + SessionDescriptor + { _sd_name :: SessionName + , _sd_isOneShot :: Bool + } + deriving (Show) + +-- | the client calls 'collect' to bind the passwords into the environment +data CollectConfig p = + CollectConfig + { _cc_optional :: Bool -- ^ if True , collect will not report an error if the master password is missing + , _cc_active :: [p] -- ^ the list of active passwords for this collection + } + +-- | raise an error if not logged in and collect all of the passwords +defaultCollectConfig :: PW p => CollectConfig p +defaultCollectConfig = + CollectConfig + { _cc_optional = True + , _cc_active = [minBound..maxBound] + } + +-- | the password manager CLI: it just needs the config and command line +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 + +-- | a sample 'HashDescription' generator to help with setting up 'PMConfig' +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 + } + +-- | sample sample-script generator to help with setting up 'PMConfig' +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" + +-- | hashing the master password to create the private key for securing the store +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 + +-- | bind the master password in the environment +bindMasterPassword :: PW p => PMConfig p -> PasswordText -> IO () +bindMasterPassword PMConfig{..} = set_env _pmc_env_var + +-- | create an empty passowrd store; if the boolean flag is False then +-- an interactive shell is fired up with access to the new store; +-- if no password is specified then one is read from stdin +setup :: PW p + => PMConfig p + -> Bool -- ^ => don't fire up an interactive shell with access to the new store + -> Maybe PasswordText -- ^ the master password + -> IO () +setup pmc no_li mb_pwt = do + -- check there isn't a store there already + ex <- doesFileExist _pmc_location + when ex $ error $ "password store already exists in: " ++ _pmc_location + -- get a password from stdin if we have not been passed one + pwt <- maybe (get_pw pmc) return mb_pwt + -- need creation time and comment + now <- getCurrentTime + let ps = + PasswordStore + { _ps_comment = PasswordStoreComment $ T.pack $ "Created at " ++ show now + , _ps_map = Map.empty + , _ps_setup = now + } + -- write out the new store + save_ps pmc (mk_aek pwt) ps + when (not no_li) $ login pmc False $ Just pwt + where + PMConfig{..} = pmc + +-- | launch an interactive shell with access to the password store; if the bool +-- boolean flag is True then it will loop asking for the passwoord until the +-- correct password is typed (or an error ocurrs, possibly from a SIGint); +-- if no 'PasswordText' is specified then one will be read from stdin +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 + +-- | is this the correct master password? +passwordValid :: PW p => PMConfig p -> PasswordText -> IO Bool +passwordValid pmc = password_valid pmc . mk_aek + +-- | is the password store there? +isStorePresent :: PW p => PMConfig p -> IO Bool +isStorePresent PMConfig{..} = doesFileExist _pmc_location + +-- | are we currently logged in? +amLoggedIn :: PW p => PMConfig p -> IO Bool +amLoggedIn pmc = get_key pmc >>= password_valid pmc + +-- | is the password/session bound to a value in the store? +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 + +-- | loads a password into the store; if this is a session password and the +-- boolean ss is True then the session will be reset to this password also; +-- if no 'PasswordText' is specified then one will be read from stdin +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 + +-- | set the comment for the password store +psComment :: PW p => PMConfig p -> PasswordStoreComment -> IO () +psComment pmc cmt = wrap pmc $ \ps -> return $ Just $ L.set ps_comment cmt ps + +-- | collect the available passwords listed in 'CollectConfig' from the store +-- and bind them in their designated environmants variables +collect :: PW p => PMConfig p -> CollectConfig p -> IO () +collect pmc CollectConfig{..} = wrap_ pmc $ \ps -> do + -- set up the environment + mapM_ (clct pmc ps) _cc_active + -- now clear down all of the primed passwords + 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 a one-shot password so that it will be availabe on the next collection (probably for a deployment); +-- if no password is specified then they are all primed +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 a different session for use +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 + +-- | delete a password from the store +deletePassword :: PW p => PMConfig p -> p -> IO () +deletePassword pmc p = wrap pmc $ \ps -> return $ Just $ L.over ps_map (Map.delete (pwName p)) ps + +-- | delete a session from the store +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 + + +-- | print a status line; if @q@ is @True@ then don't output anything and exit +-- with fail code 1 if not logged in +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 + +-- | list the passwords, one per line; if @a@ is set then all passwords will be listed, +-- otherwise just the primed passwords will be listed +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] + ] + +-- | list the sessions, one per line; if @p@ is specified then all of the +-- sessions are listed for that password +sessions :: PW p + => PMConfig p + -> Bool -- ^ list active sessions only + -> Bool -- ^ list only the session identifiers + -> Maybe p -- ^ if specified, then only the sessions on this password + -> 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 + +-- | print the info, including the text descriton, for an individual passowrd +infoPassword :: PW p + => PMConfig p + -> Bool -- ^ True => show the password secret text + -> p -- ^ the password to show + -> IO () +infoPassword pmc sh_s p = do + doc <- infoPassword_ pmc sh_s p + putStr $ P.displayS (P.renderPretty 0.75 120 doc) "" + +-- | get the info on a password +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 (n-length s)) ' ' + +-- | dump the store in a s script that can be used to reload it +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] + ] + +-- | collect the passowrds, bthem into the environmant and launch an interacive shell +collectShell :: PW p => PMConfig p -> IO () +collectShell pmc = collect pmc defaultCollectConfig >> _pmc_shell pmc + +-- | check whether a password is primed for use +is_primed :: Password -> Bool +is_primed Password{..} = not _pw_isOneShot || _pw_primed + +-- | lookup a session in a password store, possibly specifying the password it belogs to; exactly +-- one session must be found, otherwise an error is generated +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 all of the sessions in a password store +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 + ] + +-- | read a passord from stdin and hash it +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 + +-- | use a '+' to represent a primed one-shot password,'-' otherwise +prime_char :: Bool -> Char +prime_char is_p = if is_p then '+' else '-' + +-- | make up a script for loading a password store +format_dump :: PW p + => String -- ^ the prefix for each script command line + -> PasswordStoreComment -- ^ the store comment + -> [(p,PasswordText)] -- ^ the passwords to load + -> [(p,SessionName)] -- ^ the sessions to select + -> 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' <$> 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 + + +-- +-- The Command Line Parser +-- + + +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 <- getProgName + let (msg, exit) = execFailure failure progn + case exit of + ExitSuccess -> putStrLn msg + _ -> hPutStrLn stderr msg + exitWith exit + CompletionInvoked compl -> do + progn <- getProgName + msg <- execCompletion compl progn + putStr msg + exitWith ExitSuccess diff --git a/src/Data/KeyStore/Sections.hs b/src/Data/KeyStore/Sections.hs --- a/src/Data/KeyStore/Sections.hs +++ b/src/Data/KeyStore/Sections.hs @@ -332,7 +332,7 @@ where oops dg = error $ "key_section: " ++ encode h ++ ": " ++ encode k ++ ": " ++ show dg --- | Rerurn the section that a host sores a given key in, returning a +-- | Return the section that a host stores a given key in, returning a -- failure diagnostic if the host does not keep such a key in the given -- 'Section' model. keySection :: Sections h s k => h -> k -> Retrieve s @@ -352,10 +352,12 @@ -- iff ch then compare the new value with the old ok <- case ch of True -> do - -- if key has not changed then squash the rotation + -- if key has not changed, or the secret text is not available + -- then squash the rotation mbkds <- map key2KeyData <$> locateKeys ic (mks k) g_nm case mbkds of - Just kd':_ | kd==kd' -> return False + Just kd':_ | kd==kd' -> return False -- the key has not changes + Nothing :_ -> return False -- secret not accessible to compare _ -> return True False -> return True diff --git a/src/Data/KeyStore/Types/PasswordStoreModel.hs b/src/Data/KeyStore/Types/PasswordStoreModel.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Types/PasswordStoreModel.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.KeyStore.Types.PasswordStoreModel where + +import Data.KeyStore.Types.PasswordStoreSchema +import qualified Data.Map as Map +import Data.API.Tools +import Data.API.JSON + + +$(generate passwordStoreSchema) + + +-- The PasswordStre and SessionMap association lists are represented internally +-- with maps. + + +type PasswordMap = Map.Map PasswordName Password + +inj_pwmap :: REP__PasswordMap -> ParserWithErrs PasswordMap +inj_pwmap (REP__PasswordMap as) = + return $ Map.fromList [ (_npa_name,_npa_password) | NamePasswordAssoc{..}<-as ] + +prj_pwmap :: PasswordMap -> REP__PasswordMap +prj_pwmap mp = REP__PasswordMap [ NamePasswordAssoc nme pwd | (nme,pwd)<-Map.toList mp ] + + +type SessionMap = Map.Map SessionName Session + +inj_snmap :: REP__SessionMap -> ParserWithErrs SessionMap +inj_snmap (REP__SessionMap as) = + return $ Map.fromList [ (_spa_name,_spa_session) | SessionPasswordAssoc{..}<-as ] + +prj_snmap :: SessionMap -> REP__SessionMap +prj_snmap mp = REP__SessionMap [ SessionPasswordAssoc snm ssn | (snm,ssn)<-Map.toList mp ] + + +$(generateAPITools passwordStoreSchema + [ enumTool + , jsonTool + , lensTool + ]) diff --git a/src/Data/KeyStore/Types/PasswordStoreSchema.hs b/src/Data/KeyStore/Types/PasswordStoreSchema.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Types/PasswordStoreSchema.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.KeyStore.Types.PasswordStoreSchema + ( passwordStoreSchema + , passwordStoreChangelog + ) where + +import Data.API.Parse +import Data.API.Types +import Data.API.Changes + + +passwordStoreSchema :: API +passwordStoreChangelog :: APIChangelog +(passwordStoreSchema, passwordStoreChangelog) = [apiWithChangelog| + +ps :: PasswordStore + = record + comment :: PasswordStoreComment + map :: PasswordMap + setup :: utc + +pm :: PasswordMap + // the password map, represented internally with a Map + // from PasswordName to Password + = record + map :: [NamePasswordAssoc] + with inj_pwmap, prj_pwmap + +npa :: NamePasswordAssoc + = record + name :: PasswordName + password :: Password + +pw :: Password + // passwords may be simple, or be a collection of 'sessions', + // one of which is selected + = record + name :: PasswordName + text :: PasswordText + sessions :: SessionMap + isOneShot :: Bool + primed :: boolean + setup :: utc + +smp :: SessionMap + // collections of sessions are represented internally as a Map + // from SessionName to PasswordText + = record + map :: [SessionPasswordAssoc] + with inj_snmap, prj_snmap + +spa :: SessionPasswordAssoc + = record + name :: SessionName + session :: Session + +ssn :: Session + // a session just consists of a password and the stup time + = record + name :: SessionName + password :: PasswordText + isOneShot :: Bool + setup :: utc + +pwsc :: PasswordStoreComment + // a short comment on the PasswordStore + = basic string + +pnm :: PasswordName + // used to identify a password in the store + = basic string + +ptx :: PasswordText + // used to contain the secret text of a Password + = basic string + +snm :: SessionName + // used to identify the different sessions in a session password + = basic string + +changes + +// Initial version +version "0.0.0.1" + +|] diff --git a/src/Data/KeyStore/Version.hs b/src/Data/KeyStore/Version.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Version.hs @@ -0,0 +1,9 @@ +module Data.KeyStore.Version where + +version :: String +version = show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d + where + (a,b,c,d) = versionTuple + +versionTuple :: (Int,Int,Int,Int) +versionTuple = (0,5,1,0)