diff --git a/examples/deploy/deploy.hs b/examples/deploy/deploy.hs new file mode 100644 --- /dev/null +++ b/examples/deploy/deploy.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Deploy.Deploy +import Deploy.Command +import Deploy.HostSectionKey +import Data.KeyStore +import Data.KeyStore as KS +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Text.IO as T +import System.Directory +import System.IO +import Control.Applicative +import Control.Exception + + +ks_fp, ks_mac_fp :: FilePath +ks_fp = "deploy-keystore.json" +ks_mac_fp = "deploy-keystore.hash" + +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 cp0 no_keys + SampleScript -> mapM_ sample_ln [minBound..maxBound] + KS args -> KS.cli' Nothing args + _ -> + do ic <- load cp + let ic_ro = ic { ic_ctx_params = cp {cp_readonly = cp_readonly cp <|> Just True} } + case cli_command of + Sign -> return () + _ -> verify_ks True ic_ro + case cli_command of + Create -> error "main: Initialise" + Rotate mbh mbs mbk -> rotate ic $ key_prededicate mbh mbs mbk + Deploy mb hst -> deploy ic_ro hst >>= write mb + Sign -> sign_ks ic_ro + Verify -> T.putStrLn "the keystore matches the signature" + InfoKey mbk -> T.putStr $ keyHelp mbk + InfoSection mbs -> sectionHelp mbs >>= T.putStr + SecretScript -> secretKeySummary ic sections >>= T.putStr + PublicScript -> publicKeySummary ic sections ks_mac_fp >>= T.putStr + SampleScript -> error "main: SampleScript" + KS _ -> error "main: KS" + verify_ks False ic_ro + +load :: CtxParams -> IO IC +load cp = + do ok <- doesFileExist $ maybe ks_fp id $ cp_store cp + case ok of + True -> instanceCtx cp + False -> error "keystore not present" + +sign_ks :: IC -> IO () +sign_ks ic = signKeystore ic sections >>= B.writeFile ks_mac_fp + +verify_ks :: Bool -> IC -> IO () +verify_ks fatal ic = chk =<< catch (B.readFile ks_mac_fp >>= verifyKeystore ic) hdl + where + chk True = return () + chk False | fatal = error msg + | otherwise = hPutStrLn stderr msg + + hdl (se :: SomeException) = + error $ "failure during keystore verification: " ++ show se + + msg = "the signature does not match the keystore" + +no_keys :: KeyPredicate HostID SectionID KeyID +no_keys = noKeys + +key_prededicate :: Maybe HostID -> Maybe SectionID -> Maybe KeyID -> KeyPredicate HostID SectionID KeyID +key_prededicate = keyPrededicate + +sample_ln :: SectionID -> IO () +sample_ln s = putStrLn $ "export " ++ "KEY_pw_" ++ s_ ++ "=pw_" ++ s_ + where + s_ = encode s + +write :: Maybe FilePath -> LBS.ByteString -> IO () +write = maybe LBS.putStr LBS.writeFile diff --git a/examples/psd/psd.hs b/examples/psd/psd.hs deleted file mode 100644 --- a/examples/psd/psd.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Data.KeyStore -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as B -import System.Directory -import System.FilePath -import Control.Applicative - - -ic :: IC -ic = instanceCtx_ $ CtxParams (Just ex_ks) True True - -ex_dir :: FilePath -ex_dir = "examples/psd" - -ex_ini_stgs :: FilePath -ex_ini_stgs = ex_dir defaultSettingsFilePath - -ex_ks :: FilePath -ex_ks = ex_dir defaultKeyStoreFilePath - - - -{--------------------------- -export KEY_pw_devel=pw_devel -export KEY_pw_stage=pw_stage -export KEY_pw_prodn=pw_prodn ----------------------------} - - -main :: IO () -main = - do ok <- doesFileExist ex_ks - case ok of - True -> - putStrLn "keystore present.\n" - False -> - do putStrLn "creating keystore.\n" - stgs <- readSettings ex_ini_stgs - newKeyStore ex_ks stgs - mk_level production_level Nothing - mk_level staging_level (Just production_level) - mk_level development_level (Just staging_level) - map _key_name <$> keys ic >>= mapM_ (info ic) - - -rm_psd :: IO () -rm_psd = removeFile ex_ks - - -production_level, staging_level, development_level :: Level -production_level = Level "production" "prodn" -staging_level = Level "staging" "stage" -development_level = Level "development" "devel" - -data Level - = Level - { lvl_name :: String - , lvl_kname_prefix :: String - } - deriving (Show) - -lvl_config :: Level -> FilePath -lvl_config lvl = ex_dir lvl_kname_prefix lvl defaultSettingsFilePath - -add_secrets :: String -> FilePath -> IO () -add_secrets nm_s fp = - do add_secret production_level nm_s fp - add_secret staging_level nm_s fp - add_secret development_level nm_s fp - -add_dvl_secret :: String -> FilePath -> IO () -add_dvl_secret = add_secret development_level - -add_dvl_secret_ :: String -> B.ByteString -> IO () -add_dvl_secret_ = add_secret_ development_level - -add_secret :: Level -> String -> FilePath -> IO () -add_secret lvl nm_s fp = B.readFile fp >>= add_secret_ lvl nm_s - -add_secret_ :: Level -> String -> B.ByteString -> IO () -add_secret_ lvl nm_s bs = createKey ic nm cmt ide Nothing (Just bs) - where - nm = kname lvl nm_s - cmt = Comment $ T.pack $ "secret " ++ nm_s ++ " for " ++ lvl_name lvl - ide = "" - -mk_level :: Level -> (Maybe Level) -> IO () -mk_level lvl mb = - do add_password lvl - add_save_key lvl - add_trigger lvl - maybe (return ()) (backup_password lvl) mb - -add_password :: Level -> IO () -add_password lvl = createKey ic nm cmt ide (Just ev) Nothing - where - cmt = Comment $ T.pack $ "password for " ++ lvl_name lvl - ide = "" - ev = env_var nm - - nm = pw_kname lvl - -add_save_key :: Level -> IO () -add_save_key lvl = createRSAKeyPair ic nm cmt ide [pw_sg] - where - nm = save_kname lvl - cmt = Comment $ T.pack $ "save key for " ++ lvl_name lvl - ide = "" - pw_sg = safeguard [pw_kname lvl] - -add_trigger :: Level -> IO () -add_trigger lvl = addTrigger ic tid pat fp - where - tid = TriggerID $ T.pack $ lvl_name lvl - pat = kpattern lvl - fp = lvl_config lvl - -backup_password :: Level -> Level -> IO () -backup_password lvl lvl' = secureKey ic (pw_kname lvl) sg - where - sg = safeguard [save_kname lvl'] - -pw_kname :: Level -> Name -pw_kname lvl = name' $ "pw_" ++ lvl_kname_prefix lvl - -save_kname :: Level -> Name -save_kname lvl = name' $ "save_" ++ lvl_kname_prefix lvl - -kname :: Level -> String -> Name -kname lvl nm_s = name' $ lvl_kname_prefix lvl ++ "_" ++ nm_s - -kpattern :: Level -> Pattern -kpattern lvl = pattern $ "^" ++ lvl_kname_prefix lvl ++ "_.*" - -env_var :: Name -> EnvVar -env_var = EnvVar . T.pack . ("KEY_" ++) . _name - -subdir :: Level -> FilePath -> FilePath -subdir lvl fp = lvl_kname_prefix lvl fp - -name' :: String -> Name -name' = either (error.show) id . name diff --git a/keystore.cabal b/keystore.cabal --- a/keystore.cabal +++ b/keystore.cabal @@ -1,5 +1,5 @@ Name: keystore -Version: 0.1.1.0 +Version: 0.2.0.0 Synopsis: Managing stores of secret things Homepage: http://github.com/cdornan/keystore Author: Chris Dornan @@ -33,21 +33,21 @@ Exposed-modules: Data.KeyStore Data.KeyStore.CLI - Data.KeyStore.Configuration - Data.KeyStore.CPRNG + Data.KeyStore.CLI.Command Data.KeyStore.IO - Data.KeyStore.KeyStore + Data.KeyStore.IO.IC Data.KeyStore.KS - Data.KeyStore.Opt - Data.KeyStore.Packet + Data.KeyStore.KS.Configuration + Data.KeyStore.KS.CPRNG + Data.KeyStore.KS.Crypto + Data.KeyStore.KS.KS + Data.KeyStore.KS.Opt + Data.KeyStore.KS.Packet + Data.KeyStore.Sections Data.KeyStore.Types Data.KeyStore.Types.E - Data.KeyStore.Types.Schema Data.KeyStore.Types.NameAndSafeguard - - Other-modules: - Data.KeyStore.Command - Data.KeyStore.Crypto + Data.KeyStore.Types.Schema Build-depends: api-tools >= 0.2 , @@ -56,7 +56,7 @@ crypto-pubkey >= 0.2.1 , crypto-random >= 0.0.7 , aeson >= 0.6.2 , - aeson-pretty <= 0.7 , + aeson-pretty >= 0.7 , attoparsec >= 0.10.4.0 , base >= 4 , base64-bytestring >= 1.0 , @@ -67,7 +67,7 @@ directory >= 1.2 , filepath >= 1.3 , mtl >= 2 , - optparse-applicative >= 0.7.0.2 && < 0.8 , + optparse-applicative >= 0.9.0 , pbkdf >= 1.1.1.0 , safe >= 0.3.3 , text >= 0.11 , @@ -93,7 +93,7 @@ Executable ks - Hs-Source-Dirs: main + Hs-Source-Dirs: main Main-is: ks.hs @@ -106,20 +106,25 @@ GHC-Options: -fwarn-tabs -Executable psd - Hs-Source-Dirs: examples/psd +Executable deploy + Hs-Source-Dirs: examples/deploy - Main-is: psd.hs + Main-is: deploy.hs Default-Language: Haskell2010 Build-depends: + aeson >= 0.6.2 , base > 4 && < 5 , bytestring >= 0.9 , directory >= 1.0 , filepath >= 1.1 , keystore , - text >= 0.11 + mtl >= 2 , + optparse-applicative >= 0.9.0 , + raw-strings-qq >= 1.0.2 , + text >= 0.11 , + unordered-containers >= 0.2.3.0 GHC-Options: -fwarn-tabs diff --git a/main/ks.hs b/main/ks.hs --- a/main/ks.hs +++ b/main/ks.hs @@ -1,4 +1,4 @@ -import Data.KeyStore.CLI +import Data.KeyStore main :: IO () main = cli diff --git a/src/Data/KeyStore.hs b/src/Data/KeyStore.hs --- a/src/Data/KeyStore.hs +++ b/src/Data/KeyStore.hs @@ -1,402 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | This module provide an IO-based API. The /ks/ executable provides --- some keystore management functions that can be used from the shell --- and "Data.KeyStore.KeyStore" provides the underlying functional model. - module Data.KeyStore - ( readSettings - , CtxParams(..) - , IC(..) - , module Data.KeyStore.Types - , defaultSettingsFilePath - , settingsFilePath - , defaultKeyStoreFilePath - , defaultCtxParams - , instanceCtx - , instanceCtx_ - , newKeyStore - , listSettings - , settings - , updateSettings - , listTriggers - , triggers - , addTrigger - , rmvTrigger - , createRSAKeyPair - , createKey - , adjustKey - , rememberKey - , rememberKey_ - , secureKey - , loadKey - , showIdentity - , showComment - , showDate - , showHash - , showHashComment - , showHashSalt - , showPublic - , showSecret - , keys - , list - , info - , deleteKeys - , encrypt - , encrypt_ - , encrypt__ - , decrypt - , decrypt_ - , decrypt__ - , sign - , sign_ - , verify - , verify_ - , run - ) where - -import Data.KeyStore.IO -import qualified Data.KeyStore.KeyStore as KS -import qualified Data.KeyStore.Crypto as C -import Data.KeyStore.KS -import Data.KeyStore.Types -import Data.API.Types -import Data.IORef -import Data.Aeson -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.ByteString.Base64 as B64 -import qualified Data.Map as Map -import Data.Time -import Text.Printf -import Control.Applicative -import qualified Control.Exception as X -import Control.Lens -import Control.Monad -import System.IO -import System.Locale - - --- | Generate a new keystore located in the given file with the given global --- settings. -newKeyStore :: FilePath -> Settings -> IO () -newKeyStore str_fp stgs = - do ei <- X.try $ B.readFile str_fp :: IO (Either X.SomeException B.ByteString) - either (const $ return ()) (const $ errorIO "keystore file exists") ei - g <- newGenerator - let state = - State - { st_keystore = emptyKeyStore $ defaultConfiguration stgs - , st_cprng = g - } - LBS.writeFile str_fp $ KS.keyStoreBytes $ st_keystore state - --- | Given 'CtcParams' describing the location of the keystore, etc., generate --- an IC for use in the following keystore access functions that will allow --- context to be cached between calls to these access functions. -instanceCtx :: CtxParams -> IO IC -instanceCtx cp = - do ctx_st <- get $ instanceCtx_ cp - IC cp . Just <$> newIORef ctx_st - --- | This functional method will generate an IC that will not cache any --- state between calls. -instanceCtx_ :: CtxParams -> IC -instanceCtx_ cp = IC cp Nothing - --- | List the JSON settings on stdout. -listSettings :: IC -> IO () -listSettings ic = settings ic >>= LBS.putStrLn . encode - --- | Return the settings associated with the keystore. -settings :: IC -> IO Settings -settings ic = run ic $ _cfg_settings <$> getConfig - --- | Update the global settings of a keystore from the given JSON settings. -updateSettings :: IC -> FilePath -> IO () -updateSettings ic fp = - do bs <- LBS.readFile fp - stgs <- e2io $ KS.settingsFromBytes bs - run ic $ modConfig $ over cfg_settings $ const stgs - --- | List the triggers set up in the keystore on stdout. -listTriggers :: IC -> IO () -listTriggers ic = triggers ic >>= putStr . unlines . map fmt - where - fmt Trigger{..} = printf "%-12s : %12s => %s" id_s pat_s stgs_s - where - id_s = T.unpack $ _TriggerID _trg_id - pat_s = _pat_string _trg_pattern - stgs_s = LBS.unpack $ encode $ Object $ _Settings _trg_settings - --- | Returns the striggers setup on the keystore. -triggers :: IC -> IO [Trigger] -triggers ic = run ic $ Map.elems . _cfg_triggers <$> getConfig - --- | Set up a named trigger on a keystore that will fire when a key matches the --- given pattern establishing the JSON-encoded settings in the named file. -addTrigger :: IC -> TriggerID -> Pattern -> FilePath -> IO () -addTrigger ic tid pat fp = - do bs <- LBS.readFile fp - stgs <- e2io $ KS.settingsFromBytes bs - run ic $ modConfig $ over cfg_triggers $ Map.insert tid $ Trigger tid pat stgs - --- | Remove the named trigger from the keystore. -rmvTrigger :: IC -> TriggerID -> IO () -rmvTrigger ic tid = run ic $ modConfig $ over cfg_triggers $ Map.delete tid - --- | Create an RSA key pair, encoding the private key in the named Safeguards. -createRSAKeyPair :: IC -> Name -> Comment -> Identity -> [Safeguard] -> IO () -createRSAKeyPair ic nm cmt ide sgs = run ic $ KS.createRSAKeyPair nm cmt ide sgs - --- | Create a symmetric key, possibly auto-loaded from an environment variable. -createKey :: IC - -> Name - -> Comment - -> Identity - -> Maybe EnvVar - -> Maybe B.ByteString - -> IO () -createKey ic nm cmt ide mb_ev mb_bs = - run ic $ KS.createKey nm cmt ide mb_ev (ClearText . Binary <$> mb_bs) - --- | Adjust a named key. -adjustKey :: IC -> Name -> (Key->Key) -> IO () -adjustKey ic nm adj = run ic $ adjustKeyKS nm adj - --- | Load a named key from the named file. -rememberKey :: IC -> Name -> FilePath -> IO () -rememberKey ic nm fp = B.readFile fp >>= rememberKey_ ic nm - --- | Load the named key. -rememberKey_ :: IC -> Name -> B.ByteString -> IO () -rememberKey_ ic nm bs = run ic $ KS.rememberKey nm $ ClearText $ Binary bs - --- | Encrypt and store the key with the named safeguard. -secureKey :: IC -> Name -> Safeguard -> IO () -secureKey ic nm nms = run ic $ KS.secureKey nm nms - --- | Try and retrieve the secret text for a given key. -loadKey :: IC -> Name -> IO Key -loadKey ic nm = run ic $ KS.loadKey nm - --- | Return the identity of a key. -showIdentity :: IC -> Bool -> Name -> IO B.ByteString -showIdentity ic = show_it' ic "identity" (Just . _key_identity) (B.pack . T.unpack . _Identity) - --- | Return the comment associated with a key. -showComment :: IC -> Bool -> Name -> IO B.ByteString -showComment ic = show_it' ic "comment" (Just . _key_comment) (B.pack . T.unpack . _Comment ) - --- | Return the creation UTC of a key. -showDate :: IC -> Bool -> Name -> IO B.ByteString -showDate ic = show_it' ic "date" (Just . _key_created_at) (B.pack . formatTime defaultTimeLocale fmt) - where - fmt = "%F-%TZ" - --- | Return the hash of a key. -showHash :: IC -> Bool -> Name -> IO B.ByteString -showHash ic = show_it ic "hash" (fmap _hash_hash . _key_hash) _HashData - --- | Return the hash comment of a key/ -showHashComment :: IC -> Bool -> Name -> IO B.ByteString -showHashComment ic = show_it' ic "hash" _key_hash cmt - where - cmt = B.pack . T.unpack . _Comment . _hashd_comment . _hash_description - --- | Retuen the hash salt of a key. -showHashSalt :: IC -> Bool -> Name -> IO B.ByteString -showHashSalt ic = show_it ic "hash" (fmap (_hashd_salt . _hash_description) . _key_hash) _Salt - --- | (For public key pairs only) return the public key. -showPublic :: IC -> Bool -> Name -> IO B.ByteString -showPublic ic = show_it ic "public" (fmap C.encodePublicKeyDER . _key_public) _ClearText - --- | Return the secret text of a key (will be the private key for a public key pair). -showSecret :: IC -> Bool -> Name -> IO B.ByteString -showSecret ic = show_it ic "secret" _key_clear_text _ClearText - -show_it :: IC - -> String - -> (Key->Maybe a) - -> (a->Binary) - -> Bool - -> Name - -> IO B.ByteString -show_it ic lbl prj_1 prj_2 aa nm = show_it' ic lbl prj_1 (_Binary . prj_2) aa nm - -show_it' :: IC - -> String - -> (Key->Maybe a) - -> (a->B.ByteString) - -> Bool - -> Name - -> IO B.ByteString -show_it' ic lbl prj_1 prj_2 aa nm = - do key <- loadKey ic nm - case prj_2 <$> prj_1 key of - Nothing -> errorIO $ printf "%s: %s not present" (_name nm) lbl - Just bs -> return $ armr bs - where - armr = if aa then B64.encode else id - --- | List a summary of all of the keys on stdout. -list :: IC -> IO () -list ic = run ic $ KS.list - --- Summarize a single key on stdout. -info :: IC -> Name -> IO () -info ic nm = run ic $ KS.info nm - --- | Return all of the keys in the keystore. -keys :: IC -> IO [Key] -keys ic = Map.elems . _ks_keymap <$> get_keystore ic - --- | Delete a list of keys from the keystore. -deleteKeys :: IC -> [Name] -> IO () -deleteKeys ic nms = run ic $ deleteKeysKS nms - --- Encrypt a file with a named key. -encrypt :: IC -> Name -> FilePath -> FilePath -> IO () -encrypt ic nm s_fp d_fp = - do bs <- B.readFile s_fp - bs' <- encrypt_ ic nm bs - B.writeFile d_fp bs' - --- | Encrypt a 'B.ByteString' with a named key. -encrypt_ :: IC -> Name -> B.ByteString -> IO B.ByteString -encrypt_ ic nm bs = _Binary . _EncryptionPacket <$> - (run ic $ KS.encryptWithRSAKey nm $ ClearText $ Binary bs) - --- | Encrypt a 'B.ByteString' with a named key to produce a 'RSASecretData'. - -encrypt__ :: IC -> Name -> B.ByteString -> IO RSASecretData -encrypt__ ic nm bs = run ic $ KS.encryptWithRSAKey_ nm $ ClearText $ Binary bs - - --- | Decrypt a file with the named key (whose secret text must be accessible). -decrypt :: IC -> FilePath -> FilePath -> IO () -decrypt ic s_fp d_fp = - do bs <- B.readFile s_fp - bs' <- decrypt_ ic bs - B.writeFile d_fp bs' - --- | Decrypt a 'B.ByteString' with the named key --- (whose secret text must be accessible). -decrypt_ :: IC -> B.ByteString -> IO B.ByteString -decrypt_ ic bs = _Binary . _ClearText <$> - (run ic $ KS.decryptWithRSAKey $ EncryptionPacket $ Binary bs) - --- | Decrypt a 'B.ByteString' from a 'RSASecretData' with the named key --- (whose secret text must be accessible). -decrypt__ :: IC -> Name -> RSASecretData -> IO B.ByteString -decrypt__ ic nm rsd = _Binary . _ClearText <$> (run ic $ KS.decryptWithRSAKey_ nm rsd) - --- | Sign a file with the named key (whose secret text must be accessible) --- to produce a detached signature in the named file. -sign :: IC -> Name -> FilePath -> FilePath -> IO () -sign ic nm s_fp d_fp = - do bs <- B.readFile s_fp - bs' <- sign_ ic nm bs - B.writeFile d_fp bs' - --- | Sign a 'B.ByteString' with the named key (whose secret text must be accessible) --- to produce a detached signature. -sign_ :: IC -> Name -> B.ByteString -> IO B.ByteString -sign_ ic nm m_bs = _Binary . _SignaturePacket <$> - (run ic $ KS.signWithRSAKey nm $ ClearText $ Binary m_bs) - --- | Verify that a signature for a file via the named public key. -verify :: IC -> FilePath -> FilePath -> IO Bool -verify ic m_fp s_fp = - do m_bs <- B.readFile m_fp - s_bs <- B.readFile s_fp - ok <- verify_ ic m_bs s_bs - case ok of - True -> return () - False -> report "signature does not match the data" - return ok - --- | Verify that a signature for a 'B.ByteString' via the named public key. -verify_ :: IC -> B.ByteString -> B.ByteString -> IO Bool -verify_ ic m_bs s_bs = - run ic $ KS.verifyWithRSAKey (ClearText $ Binary m_bs) - (SignaturePacket $ Binary s_bs) - --- | Run a KS function in an IO context, dealing with keystore updates, output, --- debug logging and errors. -run :: IC -> KS a -> IO a -run ic p = - do (ctx,st0) <- get ic - st1 <- scan_env ctx st0 - let (e,st2,les) = run_ ctx st1 p - r <- e2io e - mapM_ (logit ctx) les - st' <- backup_env ctx st2 - put ic ctx st' - return r - -scan_env :: Ctx -> State -> IO State -scan_env ctx st0 = - do (ks,les) <- scanEnv ks0 - mapM_ (logit ctx) les - return st0 { st_keystore = ks } - where - ks0 = st_keystore st0 - -backup_env :: Ctx -> State -> IO State -backup_env ctx st0 = - do mapM_ (logit ctx) les' - e2io e - return st' - where - (e,st',les') = run_ ctx st0 KS.backupKeys - --- | Keystore session context, created at the start of a session and passed --- to the keystore access functions. - -data IC = - IC { ic_ctx_params :: CtxParams - , ic_cache :: Maybe (IORef (Ctx,State)) - } - -get_keystore :: IC -> IO KeyStore -get_keystore ic = st_keystore <$> get_state ic - -get_state :: IC -> IO State -get_state ic = snd <$> get ic - -get :: IC -> IO (Ctx,State) -get IC{..} = - case ic_cache of - Nothing -> determineCtx ic_ctx_params - Just rf -> readIORef rf - -put :: IC -> Ctx -> State -> IO () -put IC{..} ctx st = - do maybe (return ()) (flip writeIORef (ctx,st)) ic_cache - when (not $ cp_readonly ic_ctx_params) $ - LBS.writeFile (ctx_store ctx) $ KS.keyStoreBytes $ st_keystore st - -report :: String -> IO () -report = hPutStrLn stderr - - - - - - - - - - - - - - - + ( module Data.KeyStore.CLI + , module Data.KeyStore.IO + , module Data.KeyStore.Sections + ) where +import Data.KeyStore.Sections +import Data.KeyStore.CLI +import Data.KeyStore.IO 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 @@ -1,9 +1,16 @@ {-# LANGUAGE RecordWildCards #-} -module Data.KeyStore.CLI (cli) where +module Data.KeyStore.CLI + ( cli + , cli' + , paramsParser + , runParse + ) where -import Data.KeyStore.Command -import Data.KeyStore +import Data.KeyStore.IO +import Data.KeyStore.KS.Opt +import Data.KeyStore.CLI.Command +import qualified Data.Text.IO as T import qualified Data.ByteString.Char8 as B import Control.Applicative import Control.Monad @@ -11,52 +18,70 @@ version :: String -version = "0.1.0.0" +version = "0.2.0.0" cli :: IO () -cli = parseCommand >>= command +cli = parseCLI >>= command Nothing -command :: Command -> IO () -command Command{..} = +cli' :: Maybe CtxParams -> [String] -> IO () +cli' mb args = parseCLI' args >>= command mb + +command :: Maybe CtxParams -> CLI -> IO () +command mb_cp CLI{..} = do ic <- - case cmd_sub of - Version -> - return $ instanceCtx_ cp - Initialise _ -> - return $ instanceCtx_ cp - _ -> instanceCtx cp - case cmd_sub of - Version -> putStrLn version - Initialise fp -> newKeyStore fp defaultSettings - UpdateSettings fp -> updateSettings ic fp - AddTrigger ti pt fp -> addTrigger ic ti pt fp - RmvTrigger ti -> rmvTrigger ic ti - Create nm cmt ide mbe mbf sgs -> create ic nm cmt ide mbe mbf sgs - CreateKeyPair nm cmt ide sgs -> createRSAKeyPair ic nm cmt ide sgs - Secure nm mbf sgs -> secure ic nm mbf sgs - List -> list ic - Info nms -> info_cli ic nms - ShowIdentity aa nm -> pr $ showIdentity ic aa nm - ShowComment aa nm -> pr $ showComment ic aa nm - ShowDate aa nm -> pr $ showDate ic aa nm - ShowHash aa nm -> pr $ showHash ic aa nm - ShowHashComment aa nm -> pr $ showHashComment ic aa nm - ShowHashSalt aa nm -> pr $ showHashSalt ic aa nm - ShowPublic aa nm -> pr $ showPublic ic aa nm - ShowSecret aa nm -> pr $ showSecret ic aa nm - Encrypt nm sfp dfp -> encrypt ic nm sfp dfp - Decrypt sfp dfp -> decrypt ic sfp dfp - Sign nm sfp dfp -> sign ic nm sfp dfp - Verify sfp dfp -> verify_cli ic sfp dfp - Delete nms -> deleteKeys ic nms + case cli_command of + Version -> return oops + Initialise _ -> return oops + _ -> instanceCtx cp + let ic_ro = ro ic + case cli_command of + Version -> putStrLn version + Keystore -> putStrLn $ maybe defaultKeyStoreFilePath id $ cp_store cp + Initialise fp -> newKeyStore fp defaultSettings + UpdateSettings fp -> updateSettings ic fp + ListSettings -> listSettings ic + ListSettingOpts mb -> pt $ listSettingsOpts mb + AddTrigger ti re fp -> addTrigger ic ti re fp + RmvTrigger ti -> rmvTrigger ic ti + ListTriggers -> listTriggers ic + Create nm cmt ide mbe mbf sgs -> create ic nm cmt ide mbe mbf sgs + CreateKeyPair nm cmt ide sgs -> createRSAKeyPair ic nm cmt ide sgs + Secure nm mbf sgs -> secure ic nm mbf sgs + List -> list ic_ro + Info nms -> info ic_ro nms + ShowIdentity aa nm -> pr $ showIdentity ic_ro aa nm + ShowComment aa nm -> pr $ showComment ic_ro aa nm + ShowDate aa nm -> pr $ showDate ic_ro aa nm + ShowHash aa nm -> pr $ showHash ic_ro aa nm + ShowHashComment aa nm -> pr $ showHashComment ic_ro aa nm + ShowHashSalt aa nm -> pr $ showHashSalt ic_ro aa nm + ShowPublic aa nm -> pr $ showPublic ic_ro aa nm + ShowSecret aa nm -> pr $ showSecret ic_ro aa nm + Encrypt nm sfp dfp -> encrypt ic_ro nm sfp dfp + Decrypt sfp dfp -> decrypt ic_ro sfp dfp + Sign nm sfp dfp -> sign ic nm sfp dfp + Verify sfp dfp -> verify_cli ic_ro sfp dfp + Delete nms -> deleteKeys ic nms where - pr p = p >>= B.putStrLn - cp = CtxParams - { cp_store = cmd_store - , cp_debug = cmd_debug - , cp_readonly = cmd_readonly - } + pr p = p >>= B.putStrLn + pt = T.putStrLn + ro ic = ic { ic_ctx_params = + cli_params { cp_readonly = cp_readonly cp <|> Just True } } + + cp = + CtxParams + { cp_store = cp_store cp_ <|> cp_store cli_params + , cp_debug = cp_debug cp_ <|> cp_debug cli_params + , cp_readonly = cp_readonly cp_ <|> cp_readonly cli_params + } + where + cp_ = maybe defaultCtxParams id mb_cp + + + + oops = error "command: this ic should ne be used" + create :: IC -> Name -> Comment @@ -76,8 +101,8 @@ Just fp -> rememberKey ic nm fp mapM_ (secureKey ic nm) secs -info_cli :: IC -> [Name] -> IO () -info_cli ic = mapM_ $ info ic +info :: IC -> [Name] -> IO () +info ic = mapM_ $ keyInfo ic verify_cli :: IC -> FilePath -> FilePath -> IO () verify_cli ic m_fp s_fp = diff --git a/src/Data/KeyStore/CLI/Command.hs b/src/Data/KeyStore/CLI/Command.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/CLI/Command.hs @@ -0,0 +1,467 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.KeyStore.CLI.Command + ( CLI(..) + , Command(..) + , parseCLI + , parseCLI' + , cliInfo + , cliParser + , paramsParser + , runParse + ) + where + +import Data.KeyStore.KS.Opt +import Data.KeyStore.Types +import Data.KeyStore.IO.IC +import Data.String +import Text.Regex +import qualified Data.Text as T +import Options.Applicative +import System.Environment +import System.Exit +import System.IO + + +data CLI = + CLI + { cli_params :: CtxParams + , cli_command :: Command + } + deriving (Show) + +data Command + = Version + | Keystore + | Initialise FilePath + | UpdateSettings FilePath + | ListSettings + | ListSettingOpts (Maybe OptEnum) + | AddTrigger TriggerID Pattern FilePath + | RmvTrigger TriggerID + | ListTriggers + | Create Name Comment Identity (Maybe EnvVar) (Maybe FilePath) [Safeguard] + | CreateKeyPair Name Comment Identity [Safeguard] + | Secure Name (Maybe FilePath) [Safeguard] + | List + | Info [Name] + | ShowIdentity Bool Name + | ShowComment Bool Name + | ShowDate Bool Name + | ShowHash Bool Name + | ShowHashComment Bool Name + | ShowHashSalt Bool Name + | ShowPublic Bool Name + | ShowSecret Bool Name + | Encrypt Name FilePath FilePath + | Decrypt FilePath FilePath + | Sign Name FilePath FilePath + | Verify FilePath FilePath + | Delete [Name] + deriving (Show) + +parseCLI :: IO CLI +parseCLI = getArgs >>= parseCLI' + +parseCLI' :: [String] -> IO CLI +parseCLI' = runParse cliInfo + +cliInfo :: ParserInfo CLI +cliInfo = + info (helper <*> cliParser) + ( fullDesc + <> progDesc "for storing secret things" + <> header "ks - key store management" + <> footer "'ks COMMAND --help' to get help on each command") + +cliParser :: Parser CLI +cliParser = + CLI + <$> paramsParser + <*> p_command + +paramsParser :: Parser CtxParams +paramsParser = + CtxParams + <$> optional p_store + <*> optional (p_debug_flg <|> p_no_debug_flg ) + <*> optional (p_readonly_flg <|> p_writeback_flg) + +p_store :: Parser FilePath +p_store = + strOption + $ long "store" + <> metavar "FILE" + <> help "the file containing the key store" + +p_debug_flg :: Parser Bool +p_debug_flg = + flag' True + $ long "debug" + <> short 'd' + <> help "enable debug logging" + +p_no_debug_flg :: Parser Bool +p_no_debug_flg = + flag' False + $ long "no-debug" + <> short 'q' + <> help "disable debug logging" + +p_readonly_flg :: Parser Bool +p_readonly_flg = + flag' True + $ long "readonly" + <> short 'r' + <> help "disable updating of keystore" + +p_writeback_flg :: Parser Bool +p_writeback_flg = + flag' False + $ long "writeback" + <> short 'w' + <> help "write back the keystore" + +p_command :: Parser Command +p_command = + subparser + $ command "version" pi_version + <> command "keystore" pi_keystore + <> command "initialise" pi_initialise + <> command "update-settings" pi_update_settings + <> command "list-settings" pi_list_settings + <> command "list-setting-opts" pi_list_setting_opts + <> command "add-trigger" pi_add_trigger + <> command "rmv-trigger" pi_rmv_trigger + <> command "list-triggers" pi_list_triggers + <> command "create" pi_create + <> command "create-key-pair" pi_create_key_pair + <> command "secure" pi_secure + <> command "list" pi_list + <> command "info" pi_info + <> command "show-identity" pi_show_identity + <> command "show-comment" pi_show_comment + <> command "show-date" pi_show_date + <> command "show-hash" pi_show_hash + <> command "show-hash-comment" pi_show_hash_comment + <> command "show-hash-salt" pi_show_hash_salt + <> command "show-public" pi_show_public + <> command "show-secret" pi_show_secret + <> command "encrypt" pi_encrypt + <> command "decrypt" pi_decrypt + <> command "sign" pi_sign + <> command "verify" pi_verify + <> command "delete" pi_delete + +pi_version + , pi_keystore + , pi_initialise + , pi_update_settings + , pi_list_settings + , pi_list_setting_opts + , pi_add_trigger + , pi_rmv_trigger + , pi_list_triggers + , pi_create + , pi_create_key_pair + , pi_secure + , pi_list + , pi_info + , pi_show_identity + , pi_show_comment + , pi_show_date + , pi_show_hash + , pi_show_hash_comment + , pi_show_hash_salt + , pi_show_public + , pi_show_secret + , pi_encrypt + , pi_decrypt + , pi_sign + , pi_verify + , pi_delete :: ParserInfo Command + +pi_version = + h_info + (helper <*> pure Version) + (progDesc "report the version of this package") + +pi_keystore = + h_info + (helper <*> pure Keystore) + (progDesc "list the details of the keystore") + +pi_initialise = + h_info + (helper <*> + (Initialise + <$> p_file "FILE" "home of the new keystore")) + (progDesc "initialise a new key store") + +pi_update_settings = + h_info + (helper <*> + (UpdateSettings + <$> p_file "JSON-SETTINGS-FILE" "new settings")) + (progDesc "update the keystore settings") + +pi_list_settings = + h_info + (helper <*> + (pure ListSettings)) + (progDesc "dump the keystore settings on stdout") + +pi_list_setting_opts = + h_info + (helper <*> + (ListSettingOpts + <$> optional p_opt)) + (progDesc "list the settings options") + +pi_add_trigger = + h_info + (helper <*> + (AddTrigger + <$> p_trigger_id + <*> p_pattern + <*> p_file "JSON-SETTINGS-FILE" "conditional settings")) + (progDesc "add trigger") + +pi_rmv_trigger = + h_info + (helper <*> + (RmvTrigger + <$> p_trigger_id)) + (progDesc "remove trigger") + +pi_list_triggers = + h_info + (helper <*> + (pure ListTriggers)) + (progDesc "remove trigger") + +pi_create = + h_info + (helper <*> + (Create + <$> p_name + <*> p_comment + <*> p_identity + <*> optional p_env_var + <*> optional p_key_text + <*> many p_safeguard)) + (progDesc "create a key") + +pi_create_key_pair = + h_info + (CreateKeyPair + <$> p_name + <*> p_comment + <*> p_identity + <*> many p_safeguard) + (progDesc "create an RSA key pair") + +pi_secure = + h_info + (Secure + <$> p_name + <*> optional p_key_text + <*> many p_safeguard) + (progDesc "insert an encrypted copy of the named secret key") + +pi_list = + h_info + (pure List) + (progDesc "list individual keys or all keys in the store") + +pi_info = + h_info + (Info + <$> many p_name) + (progDesc "list individual keys or all keys in the store") + +pi_show_identity = + h_info + (ShowIdentity + <$> p_armour + <*> p_name) + (progDesc "show the hash of the secret text") + +pi_show_comment = + h_info + (ShowComment + <$> p_armour + <*> p_name) + (progDesc "show the hash of the secret text") + +pi_show_date = + h_info + (ShowDate + <$> p_armour + <*> p_name) + (progDesc "show the hash of the secret text") + +pi_show_hash = + h_info + (ShowHash + <$> p_armour + <*> p_name) + (progDesc "show the hash of the secret text") + +pi_show_hash_comment = + h_info + (ShowHashComment + <$> p_armour + <*> p_name) + (progDesc "show the hash of the secret text") + +pi_show_hash_salt = + h_info + (ShowHashSalt + <$> p_armour + <*> p_name) + (progDesc "show the hash of the secret text") + +pi_show_public = + h_info + (ShowPublic + <$> p_armour + <*> p_name) + (progDesc "show the public key (DER format)") + +pi_show_secret = + h_info + (ShowSecret + <$> p_armour + <*> p_name) + (progDesc "show the secret text") + +pi_encrypt = + h_info + (Encrypt + <$> p_name + <*> p_file "INPUT-FILE" "file to encrypt" + <*> p_file "OUTPUT-FILE" "encrypted file") + (progDesc "encrypt a file with a named public key") + +pi_decrypt = + h_info + (Decrypt + <$> p_file "INPUT-FILE" "file to decrypt" + <*> p_file "OUTPUT-FILE" "decrypted file") + (progDesc "decrypt a file with the private key") + +pi_sign = + h_info + (Sign + <$> p_name + <*> p_file "INPUT-FILE" "file to sign" + <*> p_file "OUTPUT-FILE" "file to place the signature") + (progDesc "sign a file with a named private key") + +pi_verify = + h_info + (Verify + <$> p_file "INPUT-FILE" "file that was signed" + <*> p_file "SIGNATURE-FILE" "signature to verify") + (progDesc "verify a file with the public key") + +pi_delete = + h_info + (Delete + <$> many p_name) + (progDesc "delete one or more (unused) keys") + +p_trigger_id :: Parser TriggerID +p_trigger_id = + argument (Just . TriggerID . T.pack) + $ metavar "TRIGGER" + <> help "name of the triggered settings" + +p_pattern :: Parser Pattern +p_pattern = + argument (Just . mk) + $ metavar "REGEX" + <> help "POSIX regular expression for selecting matching keys" + where + mk s = Pattern s $ mkRegex s + +p_name :: Parser Name +p_name = + argument (either (const Nothing) Just . name) + $ metavar "NAME" + <> help "name of the key" + +p_comment :: Parser Comment +p_comment = + argument (Just . Comment . T.pack) + $ metavar "COMMENT" + <> help "comment text" + +p_identity :: Parser Identity +p_identity = fmap (maybe "" id) $ optional $ + argument (Just . Identity . T.pack) + $ metavar "KEY-IDENTITY" + <> help "identity of the key" + +p_env_var :: Parser EnvVar +p_env_var = + argument (Just . fromString) + $ metavar "ENV-VAR" + <> help "environment variable to hold the key's value" + +p_safeguard :: Parser Safeguard +p_safeguard = + nullOption + $ long "safeguard" + <> reader (either (const $ fail msg) return . parseSafeguard) + <> metavar "SAFEGUARD" + <> help "keys used to encrypt the secret key" + where + msg = "bad safeguard syntax" + +p_key_text :: Parser FilePath +p_key_text = + strOption + $ long "key-file" + <> metavar "FILE" + <> help "secret key file" + +p_file :: String -> String -> Parser FilePath +p_file mtv hlp = + argument Just + $ metavar mtv + <> help hlp + +p_armour :: Parser Bool +p_armour = + switch + $ long "base-64" + <> help "base-64 encode the result" + +p_opt :: Parser OptEnum +p_opt = + argument (parseOpt . T.pack) + $ metavar "SETTING-OPT" + <> help "name of a keystore setting option" + +h_info :: Parser a -> InfoMod a -> ParserInfo a +h_info pr = info (helper <*> pr) + +runParse :: ParserInfo a -> [String] -> IO a +runParse 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/CPRNG.hs b/src/Data/KeyStore/CPRNG.hs deleted file mode 100644 --- a/src/Data/KeyStore/CPRNG.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.KeyStore.CPRNG - ( CPRNG - , newCPRNG - , testCPRNG - , generateCPRNG - ) where - -import Crypto.Random -import Control.Applicative -import qualified Data.ByteString as B - - -newtype CPRNG - = CPRNG { _CPRNG :: SystemRNG } - deriving (CPRG) - - -newCPRNG :: IO CPRNG -newCPRNG = cprgCreate <$> createEntropyPool - -testCPRNG :: CPRNG -testCPRNG = cprgSetReseedThreshold 0 $ - cprgCreate $ createTestEntropyPool "Data.CertStore.Tools" - -generateCPRNG :: Int -> CPRNG -> (B.ByteString,CPRNG) -generateCPRNG = cprgGenerate diff --git a/src/Data/KeyStore/Command.hs b/src/Data/KeyStore/Command.hs deleted file mode 100644 --- a/src/Data/KeyStore/Command.hs +++ /dev/null @@ -1,383 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.KeyStore.Command - ( Command(..) - , SubCommand(..) - , parseCommand - ) - where - -import Options.Applicative -import Data.KeyStore.Types -import Data.String -import Text.Regex -import qualified Data.Text as T - - -data Command = - Command - { cmd_store :: Maybe FilePath - , cmd_debug :: Bool - , cmd_readonly :: Bool - , cmd_sub :: SubCommand - } - -data SubCommand - = Version - | Initialise FilePath - | UpdateSettings FilePath - | AddTrigger TriggerID Pattern FilePath - | RmvTrigger TriggerID - | Create Name Comment Identity (Maybe EnvVar) (Maybe FilePath) [Safeguard] - | CreateKeyPair Name Comment Identity [Safeguard] - | Secure Name (Maybe FilePath) [Safeguard] - | List - | Info [Name] - | ShowIdentity Bool Name - | ShowComment Bool Name - | ShowDate Bool Name - | ShowHash Bool Name - | ShowHashComment Bool Name - | ShowHashSalt Bool Name - | ShowPublic Bool Name - | ShowSecret Bool Name - | Encrypt Name FilePath FilePath - | Decrypt FilePath FilePath - | Sign Name FilePath FilePath - | Verify FilePath FilePath - | Delete [Name] - deriving (Show) - -parseCommand :: IO Command -parseCommand = execParser opts - where - opts = - info (helper <*> (p_version <|> p_command)) - ( fullDesc - <> progDesc "for storing secret things" - <> header "ks - key store management" - <> footer "'ks COMMAND --help' to get help on each command") - -p_version :: Parser Command -p_version = - flag' (Command Nothing False False Version) - $ long "version" - <> help "display the version" - - -p_command :: Parser Command -p_command = - Command - <$> optional p_store - <*> p_debug_flg - <*> p_readonly_flg - <*> p_sub_command - -p_store :: Parser FilePath -p_store = - strOption - $ long "store" - <> metavar "FILE" - <> help "the file containing the key store" - -p_debug_flg :: Parser Bool -p_debug_flg = - switch - $ long "debug" - <> short 'd' - <> help "enable debug logging" - -p_readonly_flg :: Parser Bool -p_readonly_flg = - switch - $ long "readonly" - <> short 'r' - <> help "disable updating of keystore" - -p_sub_command :: Parser SubCommand -p_sub_command = - subparser - $ command "version" pi_version - <> command "initialise" pi_initialise - <> command "update-settings" pi_update_settings - <> command "add-trigger" pi_add_trigger - <> command "rmv-trigger" pi_rmv_trigger - <> command "create" pi_create - <> command "create-key-pair" pi_create_key_pair - <> command "secure" pi_secure - <> command "list" pi_list - <> command "info" pi_info - <> command "show-identity" pi_show_identity - <> command "show-comment" pi_show_comment - <> command "show-date" pi_show_date - <> command "show-hash" pi_show_hash - <> command "show-hash-comment" pi_show_hash_comment - <> command "show-hash-salt" pi_show_hash_salt - <> command "show-public" pi_show_public - <> command "show-secret" pi_show_secret - <> command "encrypt" pi_encrypt - <> command "decrypt" pi_decrypt - <> command "sign" pi_sign - <> command "verify" pi_verify - <> command "delete" pi_delete - -pi_version - , pi_initialise - , pi_update_settings - , pi_add_trigger - , pi_rmv_trigger - , pi_create - , pi_create_key_pair - , pi_secure - , pi_list - , pi_info - , pi_show_identity - , pi_show_comment - , pi_show_date - , pi_show_hash - , pi_show_hash_comment - , pi_show_hash_salt - , pi_show_public - , pi_show_secret - , pi_encrypt - , pi_decrypt - , pi_sign - , pi_verify - , pi_delete :: ParserInfo SubCommand - -pi_version = - h_info - (pure Version) - (progDesc "initialise a new key store") - -pi_initialise = - h_info - (helper <*> - (Initialise - <$> p_file "FILE" "home of the new keystore")) - (progDesc "initialise a new key store") - -pi_update_settings = - h_info - (helper <*> - (UpdateSettings - <$> p_file "JSON-SETTINGS-FILE" "new settings")) - (progDesc "update settings") - -pi_add_trigger = - h_info - (helper <*> - (AddTrigger - <$> p_trigger_id - <*> p_pattern - <*> p_file "JSON-SETTINGS-FILE" "conditional settings")) - (progDesc "add trigger") - -pi_rmv_trigger = - h_info - (helper <*> - (RmvTrigger - <$> p_trigger_id)) - (progDesc "remove trigger") - -pi_create = - h_info - (helper <*> - (Create - <$> p_name - <*> p_comment - <*> p_identity - <*> optional p_env_var - <*> optional p_key_text - <*> many p_safeguard)) - (progDesc "create a key") - -pi_create_key_pair = - h_info - (CreateKeyPair - <$> p_name - <*> p_comment - <*> p_identity - <*> many p_safeguard) - (progDesc "create an RSA key pair") - -pi_secure = - h_info - (Secure - <$> p_name - <*> optional p_key_text - <*> many p_safeguard) - (progDesc "insert an encrypted copy of the named secret key") - -pi_list = - h_info - (pure List) - (progDesc "list individual keys or all keys in the store") - -pi_info = - h_info - (Info - <$> many p_name) - (progDesc "list individual keys or all keys in the store") - -pi_show_identity = - h_info - (ShowIdentity - <$> p_armour - <*> p_name) - (progDesc "show the hash of the secret text") - -pi_show_comment = - h_info - (ShowComment - <$> p_armour - <*> p_name) - (progDesc "show the hash of the secret text") - -pi_show_date = - h_info - (ShowDate - <$> p_armour - <*> p_name) - (progDesc "show the hash of the secret text") - -pi_show_hash = - h_info - (ShowHash - <$> p_armour - <*> p_name) - (progDesc "show the hash of the secret text") - -pi_show_hash_comment = - h_info - (ShowHashComment - <$> p_armour - <*> p_name) - (progDesc "show the hash of the secret text") - -pi_show_hash_salt = - h_info - (ShowHashSalt - <$> p_armour - <*> p_name) - (progDesc "show the hash of the secret text") - -pi_show_public = - h_info - (ShowPublic - <$> p_armour - <*> p_name) - (progDesc "show the public key (DER format)") - -pi_show_secret = - h_info - (ShowSecret - <$> p_armour - <*> p_name) - (progDesc "show the secret text") - -pi_encrypt = - h_info - (Encrypt - <$> p_name - <*> p_file "INPUT-FILE" "file to encrypt" - <*> p_file "OUTPUT-FILE" "encrypted file") - (progDesc "encrypt a file with a named public key") - -pi_decrypt = - h_info - (Decrypt - <$> p_file "INPUT-FILE" "file to decrypt" - <*> p_file "OUTPUT-FILE" "decrypted file") - (progDesc "decrypt a file with the private key") - -pi_sign = - h_info - (Sign - <$> p_name - <*> p_file "INPUT-FILE" "file to sign" - <*> p_file "OUTPUT-FILE" "file to place the signature") - (progDesc "sign a file with a named private key") - -pi_verify = - h_info - (Verify - <$> p_file "INPUT-FILE" "file that was signed" - <*> p_file "SIGNATURE-FILE" "signature to verify") - (progDesc "verify a file with the public key") - -pi_delete = - h_info - (Delete - <$> many p_name) - (progDesc "delete one or more (unused) keys") - -p_trigger_id :: Parser TriggerID -p_trigger_id = - argument (Just . TriggerID . T.pack) - $ metavar "TRIGGER" - <> help "name of the triggered settings" - -p_pattern :: Parser Pattern -p_pattern = - argument (Just . mk) - $ metavar "REGEX" - <> help "POSIX regular expression for selecting matching keys" - where - mk s = Pattern s $ mkRegex s - -p_name :: Parser Name -p_name = - argument (either (const Nothing) Just . name) - $ metavar "NAME" - <> help "name of the key" - -p_comment :: Parser Comment -p_comment = - argument (Just . Comment . T.pack) - $ metavar "COMMENT" - <> help "comment text" - -p_identity :: Parser Identity -p_identity = fmap (maybe "" id) $ optional $ - argument (Just . Identity . T.pack) - $ metavar "KEY-IDENTITY" - <> help "identity of the key" - -p_env_var :: Parser EnvVar -p_env_var = - argument (Just . fromString) - $ metavar "ENV-VAR" - <> help "environment variable to hold the key's value" - -p_safeguard :: Parser Safeguard -p_safeguard = - nullOption - $ long "safeguard" - <> reader (either (const $ fail msg) return . parseSafeguard) - <> metavar "SAFEGUARD" - <> help "keys used to encrypt the secret key" - where - msg = "bad safeguard syntax" - -p_key_text :: Parser FilePath -p_key_text = - strOption - $ long "key-file" - <> metavar "FILE" - <> help "secret key file" - -p_file :: String -> String -> Parser FilePath -p_file mtv hlp = - argument Just - $ metavar mtv - <> help hlp - -p_armour :: Parser Bool -p_armour = - switch - $ long "base-64" - <> help "base-64 encode the result" - -h_info :: Parser a -> InfoMod a -> ParserInfo a -h_info pr = info (helper <*> pr) diff --git a/src/Data/KeyStore/Configuration.hs b/src/Data/KeyStore/Configuration.hs deleted file mode 100644 --- a/src/Data/KeyStore/Configuration.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Data.KeyStore.Configuration where - -import Data.KeyStore.Types -import Data.Monoid -import qualified Data.Map as Map -import Data.Maybe -import Text.Regex - - -configurationSettings :: Configuration -> Settings -configurationSettings = _cfg_settings - -trigger :: Name -> Configuration -> Settings -> E Settings -trigger nm cfg stgs0 = - case checkSettingsCollisions stgs of - [] -> Right stgs - sids -> Left $ strMsg $ "settings collided in triggers: " - ++ nm_s ++ ": " ++ show(map _SettingID sids) - ++ "\n\n" ++ show (stgs0 : t_stgss) - where - stgs = mconcat $ stgs0 : t_stgss - - t_stgss = [ _trg_settings | Trigger{..}<-Map.elems $ _cfg_triggers cfg, - mtch _trg_pattern ] - - mtch pat = isJust $ matchRegex (_pat_regex pat) nm_s - - nm_s = _name nm diff --git a/src/Data/KeyStore/Crypto.hs b/src/Data/KeyStore/Crypto.hs deleted file mode 100644 --- a/src/Data/KeyStore/Crypto.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE BangPatterns #-} - -module Data.KeyStore.Crypto where - -import Data.KeyStore.KS -import Data.KeyStore.Opt -import Data.KeyStore.Types -import Data.API.Types -import qualified Data.ASN1.Encoding as A -import qualified Data.ASN1.BinaryEncoding as A -import qualified Data.ASN1.Types as A -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.ByteString.Char8 as B -import Control.Applicative -import Crypto.PubKey.RSA -import qualified Crypto.PubKey.RSA.OAEP as OAEP -import qualified Crypto.PubKey.RSA.PSS as PSS -import Crypto.PubKey.HashDescr -import Crypto.PubKey.MaskGenFunction -import Crypto.Cipher.AES - - -size_aes_iv, size_oae :: Octets -size_aes_iv = 16 -size_oae = 256 - - --- --- smoke tests --- - -test :: Bool -test = test_oaep && test_pss - -test_oaep :: Bool -test_oaep = trun $ - do (puk,prk) <- generateKeys - tm' <- encrypt puk tm >>= decrypt prk - return $ tm' == tm - where - tm = ClearText $ Binary "test message" - -test_pss :: Bool -test_pss = trun $ - do (puk,prk) <- generateKeys - sig <- sign prk tm - return $ verify puk tm sig && not (verify puk tm' sig) - where - tm = ClearText $ Binary "hello" - tm' = ClearText $ Binary "gello" - - --- --- defaultEncryptedCopy --- - -defaultEncryptedCopy :: Safeguard -> KS EncrypedCopy -defaultEncryptedCopy sg = - do ciphr <- lookupOpt opt__crypt_cipher - prf <- lookupOpt opt__crypt_prf - itrns <- lookupOpt opt__crypt_iterations - st_sz <- lookupOpt opt__crypt_salt_octets - slt <- randomBytes st_sz (Salt . Binary) - return - EncrypedCopy - { _ec_safeguard = sg - , _ec_cipher = ciphr - , _ec_prf = prf - , _ec_iterations = itrns - , _ec_salt = slt - , _ec_secret_data = ECD_no_data void_ - } - - --- --- saving and restoring secret copies --- - -save :: EncryptionKey -> ClearText -> KS EncrypedCopyData -save ek ct = - case ek of - EK_public puk -> ECD_rsa <$> encrypt puk ct - EK_private _ -> errorKS "Crypto.Save: saving with private key" - EK_symmetric aek -> ECD_aes <$> encryptAES aek ct - EK_none _ -> ECD_clear <$> return ct - -restore :: EncrypedCopyData -> EncryptionKey -> KS ClearText -restore ecd ek = - case (ecd,ek) of - (ECD_rsa rsd,EK_private prk) -> decrypt prk rsd - (ECD_aes asd,EK_symmetric aek) -> return $ decryptAES aek asd - (ECD_clear ct ,EK_none _ ) -> return ct - (ECD_no_data _ ,_ ) -> errorKS "restore: no data!" - _ -> errorKS "unexpected EncrypedCopy/EncryptionKey combo" - - --- --- making up an AESKey from a list of source texts --- - -mkAESKey :: EncrypedCopy -> [ClearText] -> KS AESKey -mkAESKey _ [] = error "mkAESKey: no texts" -mkAESKey EncrypedCopy{..} cts = p2 <$> lookupOpt opt__crypt_cipher - where - p2 ciphr = pbkdf _ec_prf ct _ec_salt _ec_iterations (keyWidth ciphr) $ AESKey . Binary - - ct = ClearText $ Binary $ B.concat $ map (_Binary._ClearText) cts - - --- --- encrypting & decrypting --- - -encrypt :: PublicKey -> ClearText -> KS RSASecretData -encrypt pk ct = - do cip <- lookupOpt opt__crypt_cipher - aek <- randomAESKey cip - rek <- encryptRSA pk aek - asd <- encryptAES aek ct - return - RSASecretData - { _rsd_encrypted_key = rek - , _rsd_aes_secret_data = asd - } - -decrypt :: PrivateKey -> RSASecretData -> KS ClearText -decrypt pk dat = e2ks $ decrypt_ pk dat - -decrypt_ :: PrivateKey -> RSASecretData -> E ClearText -decrypt_ pk RSASecretData{..} = - do aek <- decryptRSA_ pk _rsd_encrypted_key - return $ decryptAES aek _rsd_aes_secret_data - - --- --- Serializing RSASecretData --- - -encodeRSASecretData :: RSASecretData -> RSASecretBytes -encodeRSASecretData RSASecretData{..} = - RSASecretBytes $ Binary $ - B.concat - [ _Binary $ _RSAEncryptedKey _rsd_encrypted_key - , _Binary $ _IV _asd_iv - , _Binary $ _SecretData _asd_secret_data - ] - where - AESSecretData{..} = _rsd_aes_secret_data - -decodeRSASecretData :: RSASecretBytes -> KS RSASecretData -decodeRSASecretData (RSASecretBytes dat) = e2ks $ decodeRSASecretData_ $ _Binary dat - -decodeRSASecretData_ :: B.ByteString -> E RSASecretData -decodeRSASecretData_ dat0 = - do (eky,dat1) <- slice size_oae dat0 - (iv ,edat) <- slice size_aes_iv dat1 - return - RSASecretData - { _rsd_encrypted_key = RSAEncryptedKey $ Binary eky - , _rsd_aes_secret_data = - AESSecretData - { _asd_iv = IV $ Binary iv - , _asd_secret_data = SecretData $ Binary edat - } - } - where - slice sz bs = - case B.length bs >= _Octets sz of - True -> Right $ B.splitAt (_Octets sz) bs - False -> Left $ strMsg "decrypt: not enough bytes" - - --- --- RSA encrypting & decrypting --- - -encryptRSA :: PublicKey -> AESKey -> KS RSAEncryptedKey -encryptRSA pk (AESKey (Binary dat)) = - RSAEncryptedKey . Binary <$> randomRSA (\g->OAEP.encrypt g oaep pk dat) - -decryptRSA :: PrivateKey -> RSAEncryptedKey -> KS AESKey -decryptRSA pk rek = either throwKS return $ decryptRSA_ pk rek - -decryptRSA_ :: PrivateKey -> RSAEncryptedKey -> E AESKey -decryptRSA_ pk rek = - rsa2e $ fmap (AESKey . Binary) $ - OAEP.decrypt Nothing oaep pk $ _Binary $ _RSAEncryptedKey rek - -oaep :: OAEP.OAEPParams -oaep = - OAEP.OAEPParams - { OAEP.oaepHash = hashFunction hashDescrSHA512 - , OAEP.oaepMaskGenAlg = mgf1 - , OAEP.oaepLabel = Nothing - } - - --- --- signing & verifying --- - -sign :: PrivateKey -> ClearText -> KS RSASignature -sign pk dat = - RSASignature . Binary <$> - randomRSA (\g->PSS.sign g Nothing pssp pk $ _Binary $ _ClearText dat) - -verify :: PublicKey -> ClearText -> RSASignature -> Bool -verify pk (ClearText (Binary dat)) (RSASignature (Binary sig)) = PSS.verify pssp pk dat sig - -pssp :: PSS.PSSParams -pssp = PSS.defaultPSSParams $ hashFunction hashDescrSHA512 - - --- --- AES encrypting/decrypting --- - - -encryptAES :: AESKey -> ClearText -> KS AESSecretData -encryptAES aek ct = - do iv <- randomIV - return $ encryptAES_ aek iv ct - -encryptAES_ :: AESKey -> IV -> ClearText -> AESSecretData -encryptAES_ (AESKey (Binary ky)) (IV (Binary iv)) (ClearText (Binary dat)) = - AESSecretData - { _asd_iv = IV $ Binary iv - , _asd_secret_data = SecretData $ Binary $ encryptCTR (initAES ky) iv dat - } - -decryptAES :: AESKey -> AESSecretData -> ClearText -decryptAES aek AESSecretData{..} = - ClearText $ Binary $ - encryptCTR (initAES $ _Binary $ _AESKey aek ) - (_Binary $ _IV _asd_iv ) - (_Binary $ _SecretData _asd_secret_data) - -randomAESKey :: Cipher -> KS AESKey -randomAESKey cip = randomBytes (keyWidth cip) (AESKey . Binary) - -randomIV :: KS IV -randomIV = randomBytes size_aes_iv (IV . Binary) - - --- --- hashing --- - - -hash :: ClearText -> KS Hash -hash ct = flip hash_ ct <$> defaultHashParams - -defaultHashParams :: KS HashDescription -defaultHashParams = - do h_cmt <- lookupOpt opt__hash_comment - h_prf <- lookupOpt opt__hash_prf - itrns <- lookupOpt opt__hash_iterations - hs_wd <- lookupOpt opt__hash_width_octets - st_wd <- lookupOpt opt__hash_salt_octets - st <- randomBytes st_wd (Salt . Binary) - return $ hashd h_cmt h_prf itrns hs_wd st_wd st - where - hashd h_cmt h_prf itrns hs_wd st_wd st = - HashDescription - { _hashd_comment = h_cmt - , _hashd_prf = h_prf - , _hashd_iterations = itrns - , _hashd_width_octets = hs_wd - , _hashd_salt_octets = st_wd - , _hashd_salt = st - } - -hash_ :: HashDescription -> ClearText -> Hash -hash_ hd@HashDescription{..} ct = - Hash - { _hash_description = hd - , _hash_hash = pbkdf _hashd_prf ct _hashd_salt _hashd_iterations - _hashd_width_octets (HashData . Binary) - } - ---randomSalt :: KS Salt ---randomSalt = randomBytes size_salt Salt - --- --- Generating a private/public key pair --- - -default_e :: Integer -default_e = 0x10001 - -default_key_size :: Int -default_key_size = 2048 `div` 8 - -generateKeys :: KS (PublicKey,PrivateKey) -generateKeys = generateKeys_ default_key_size - -generateKeys_ :: Int -> KS (PublicKey,PrivateKey) -generateKeys_ ksz = randomKS $ \g->generate g ksz default_e - - --- --- Encoding & decoding private & public keys --- - -decodePrivateKeyDER :: ClearText -> E PrivateKey -decodePrivateKeyDER = decodeDER . _Binary . _ClearText - -decodePublicKeyDER :: ClearText -> E PublicKey -decodePublicKeyDER = decodeDER . _Binary . _ClearText - -encodePrivateKeyDER :: PrivateKey -> ClearText -encodePrivateKeyDER = ClearText . Binary . encodeDER - -encodePublicKeyDER :: PublicKey -> ClearText -encodePublicKeyDER = ClearText . Binary . encodeDER - -decodeDER :: A.ASN1Object a => B.ByteString -> E a -decodeDER bs = - case A.decodeASN1 A.DER $ lzy bs of - Left err -> Left $ strMsg $ show err - Right as -> - case A.fromASN1 as of - Left err -> Left $ strMsg $ show err - Right pr -> - case pr of - (pk,[]) -> return pk - _ -> Left $ strMsg "residual data" - where - lzy = LBS.pack . B.unpack - -encodeDER :: A.ASN1Object a => a -> B.ByteString -encodeDER = egr . A.encodeASN1 A.DER . flip A.toASN1 [] - where - egr = B.pack . LBS.unpack - - - --- --- Helpers --- - -rsa2e :: Either Error a -> E a -rsa2e = either (Left . rsaError) Right diff --git a/src/Data/KeyStore/IO.hs b/src/Data/KeyStore/IO.hs --- a/src/Data/KeyStore/IO.hs +++ b/src/Data/KeyStore/IO.hs @@ -1,215 +1,388 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | This module provide an IO-based API. The /ks/ executable provides +-- some keystore management functions that can be used from the shell +-- and "Data.KeyStore.KeyStore" provides the underlying functional model. + module Data.KeyStore.IO ( readSettings , CtxParams(..) - , defaultCtxParams + , IC(..) + , module Data.KeyStore.Types + , module Data.KeyStore.KS.KS + , keyStoreBytes + , keyStoreFromBytes + , settingsFromBytes , defaultSettingsFilePath , settingsFilePath , defaultKeyStoreFilePath - , determineCtx - , establishState - , newGenerator - , readKeyStore - , scanEnv - , errorIO - , logit + , defaultCtxParams + , instanceCtx + , instanceCtx_ + , newKeyStore + , listSettings + , settings + , updateSettings + , listTriggers + , triggers + , addTrigger + , addTrigger' + , rmvTrigger + , createRSAKeyPair + , createKey + , adjustKey + , rememberKey + , rememberKey_ + , secureKey + , loadKey + , showIdentity + , showComment + , showDate + , showHash + , showHashComment + , showHashSalt + , showPublic + , showSecret + , keys + , list + , keyInfo + , deleteKeys + , encrypt + , encrypt_ + , encrypt__ + , decrypt + , decrypt_ + , decrypt__ + , sign + , sign_ + , verify + , verify_ + , run ) where -import Data.KeyStore.KeyStore -import Data.KeyStore.Configuration +import Data.KeyStore.IO.IC import Data.KeyStore.KS -import Data.KeyStore.Opt +import Data.KeyStore.KS.KS import Data.KeyStore.Types -import Data.KeyStore.CPRNG import Data.API.Types +import Data.IORef import Data.Aeson -import Data.Text as T -import qualified Data.Map as Map -import qualified Data.ByteString.Base64 as B64 +import qualified Data.Text as T import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Maybe +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Map as Map import Data.Time -import qualified Control.Exception as X +import Text.Printf import Control.Applicative -import System.Environment -import System.Directory -import System.FilePath +import qualified Control.Exception as X +import Control.Lens +import Control.Monad import System.IO -import Safe +import System.Locale --- | The parameters used to set up a KeyStore session. -data CtxParams - = CtxParams - { cp_store :: Maybe FilePath -- ^ location of any explictlt specified keystore file - , cp_debug :: Bool -- ^ whether debug output has been enabled or noe - , cp_readonly :: Bool -- ^ True => do not update keystore - } - deriving (Show) +-- | Generate a new keystore located in the given file with the given global +-- settings. +newKeyStore :: FilePath -> Settings -> IO () +newKeyStore str_fp stgs = + do ei <- X.try $ B.readFile str_fp :: IO (Either X.SomeException B.ByteString) + either (const $ return ()) (const $ errorIO "keystore file exists") ei + g <- newGenerator + let state = + State + { st_keystore = emptyKeyStore $ defaultConfiguration stgs + , st_cprng = g + } + LBS.writeFile str_fp $ keyStoreBytes $ st_keystore state --- | Suitable default 'CtxParams'. -defaultCtxParams :: CtxParams -defaultCtxParams = - CtxParams - { cp_store = Nothing - , cp_debug = False - , cp_readonly = False - } +-- | Given 'CtxParams' describing the location of the keystore, etc., generate +-- an IC for use in the following keystore access functions that will allow +-- context to be cached between calls to these access functions. +instanceCtx :: CtxParams -> IO IC +instanceCtx cp = + do ctx_st <- get $ instanceCtx_ cp + IC cp . Just <$> newIORef ctx_st --- | The default place for keystore settings (settings). -defaultSettingsFilePath :: FilePath -defaultSettingsFilePath = settingsFilePath "settings" +-- | This functional method will generate an IC that will not cache any +-- state between calls. +instanceCtx_ :: CtxParams -> IC +instanceCtx_ cp = IC cp Nothing --- | Add the standard file extension to a base name (.json). -settingsFilePath :: String -> FilePath -settingsFilePath base = base ++ ".json" +-- | List the JSON settings on stdout. +listSettings :: IC -> IO () +listSettings ic = settings ic >>= LBS.putStrLn . encode . _Settings +-- | Return the settings associated with the keystore. +settings :: IC -> IO Settings +settings ic = run ic $ _cfg_settings <$> getConfig --- | The default file for a keystore (keystore.json). -defaultKeyStoreFilePath :: FilePath -defaultKeyStoreFilePath = "keystore.json" +-- | Update the global settings of a keystore from the given JSON settings. +updateSettings :: IC -> FilePath -> IO () +updateSettings ic fp = + do bs <- LBS.readFile fp + stgs <- e2io $ settingsFromBytes bs + run ic $ modConfig $ over cfg_settings $ const stgs --- | Determine the 'Ctx' and keystore 'State' from 'CtxParams' -determineCtx :: CtxParams -> IO (Ctx,State) -determineCtx CtxParams{..} = - do str_fp_ <- - case cp_store of - Nothing -> - do mb_ev_pth <- lookupEnv "KEYSTORE" - case mb_ev_pth of - Nothing -> - do pth <- mk_path - lu_path defaultKeyStoreFilePath pth $ - errorIO "keystore not found" - Just str_fp -> return str_fp - Just str_fp -> return str_fp - cwd <- getCurrentDirectory - now <- getCurrentTime - let str_fp = cwd str_fp_ - ctx0 = Ctx - { ctx_now = now - , ctx_store = str_fp - , ctx_settings = defaultSettings - } - ks <- readKeyStore ctx0 - g <- newGenerator - let st = - State - { st_keystore = ks - , st_cprng = g - } - sdbg = setSettingsOpt opt__debug_enabled cp_debug - stg = sdbg $ configurationSettings $ _ks_config ks - ctx = ctx0 { ctx_settings = stg } - return (ctx,st) +-- | List the triggers set up in the keystore on stdout. +listTriggers :: IC -> IO () +listTriggers ic = triggers ic >>= putStr . unlines . map fmt + where + fmt Trigger{..} = printf "%-12s : %12s => %s" id_s pat_s stgs_s + where + id_s = T.unpack $ _TriggerID _trg_id + pat_s = _pat_string _trg_pattern + stgs_s = LBS.unpack $ encode $ Object $ _Settings _trg_settings --- | Set up the keystore state. -establishState :: Ctx -> IO State -establishState ctx = - do ks <- readKeyStore ctx - g <- newGenerator - return - State - { st_keystore = ks - , st_cprng = g - } +-- | Returns the striggers setup on the keystore. +triggers :: IC -> IO [Trigger] +triggers ic = run ic $ Map.elems . _cfg_triggers <$> getConfig -newGenerator :: IO CPRNG -newGenerator = newCPRNG +-- | addTrigger' cariant that erads the setting from a file. +addTrigger :: IC -> TriggerID -> Pattern -> FilePath -> IO () +addTrigger ic tid pat fp = + do bs <- LBS.readFile fp + stgs <- e2io $ settingsFromBytes bs + addTrigger' ic tid pat stgs -readKeyStore :: Ctx -> IO KeyStore -readKeyStore ctx = ioE $ keyStoreFromBytes <$> LBS.readFile (ctx_store ctx) +-- | Set up a named trigger on a keystore that will fire when a key matches the +-- given pattern establishing the settings. +addTrigger' :: IC -> TriggerID -> Pattern -> Settings -> IO () +addTrigger' ic tid pat stgs = + run ic $ modConfig $ over cfg_triggers $ Map.insert tid $ Trigger tid pat stgs -scanEnv :: KeyStore -> IO (KeyStore,[LogEntry]) -scanEnv ks = getCurrentTime >>= \now -> scanEnv' now ks +-- | Remove the named trigger from the keystore. +rmvTrigger :: IC -> TriggerID -> IO () +rmvTrigger ic tid = run ic $ modConfig $ over cfg_triggers $ Map.delete tid -scanEnv' :: UTCTime -> KeyStore -> IO (KeyStore,[LogEntry]) -scanEnv' now ks = s_e <$> mapM lu k_evs +-- | Create an RSA key pair, encoding the private key in the named Safeguards. +createRSAKeyPair :: IC -> Name -> Comment -> Identity -> [Safeguard] -> IO () +createRSAKeyPair ic nm cmt ide sgs = run ic $ createRSAKeyPairKS nm cmt ide sgs + +-- | Create a symmetric key, possibly auto-loaded from an environment variable. +createKey :: IC + -> Name + -> Comment + -> Identity + -> Maybe EnvVar + -> Maybe B.ByteString + -> IO () +createKey ic nm cmt ide mb_ev mb_bs = + run ic $ createKeyKS nm cmt ide mb_ev (ClearText . Binary <$> mb_bs) + +-- | Adjust a named key. +adjustKey :: IC -> Name -> (Key->Key) -> IO () +adjustKey ic nm adj = run ic $ adjustKeyKS nm adj + +-- | Load a named key from the named file. +rememberKey :: IC -> Name -> FilePath -> IO () +rememberKey ic nm fp = B.readFile fp >>= rememberKey_ ic nm + +-- | Load the named key. +rememberKey_ :: IC -> Name -> B.ByteString -> IO () +rememberKey_ ic nm bs = run ic $ rememberKeyKS nm $ ClearText $ Binary bs + +-- | Encrypt and store the key with the named safeguard. +secureKey :: IC -> Name -> Safeguard -> IO () +secureKey ic nm nms = run ic $ secureKeyKS nm nms + +-- | Try and retrieve the secret text for a given key. +loadKey :: IC -> Name -> IO Key +loadKey ic nm = run ic $ loadKeyKS nm + +-- | Return the identity of a key. +showIdentity :: IC -> Bool -> Name -> IO B.ByteString +showIdentity ic = show_it' ic "identity" (Just . _key_identity) (B.pack . T.unpack . _Identity) + +-- | Return the comment associated with a key. +showComment :: IC -> Bool -> Name -> IO B.ByteString +showComment ic = show_it' ic "comment" (Just . _key_comment) (B.pack . T.unpack . _Comment ) + +-- | Return the creation UTC of a key. +showDate :: IC -> Bool -> Name -> IO B.ByteString +showDate ic = show_it' ic "date" (Just . _key_created_at) (B.pack . formatTime defaultTimeLocale fmt) where - lu (key,EnvVar enm) = fmap ((,) key) <$> lookupEnv (T.unpack enm) + fmt = "%F-%TZ" - s_e mbs = - case e of - Left _ -> error "scanEnv: unexpected error" - Right _ -> (st_keystore st',les) - where - (e,st',les) = run_ ctx st0 $ mapM_ s_e' $ catMaybes mbs +-- | Return the hash of a key. +showHash :: IC -> Bool -> Name -> IO B.ByteString +showHash ic = show_it ic "hash" (fmap _hash_hash . _key_hash) _HashData - s_e' (key,sv) = - case _key_is_binary key of - False -> s_e'' key $ B.pack sv - True -> - case B64.decode $ B.pack sv of - Left _ -> putStrKS $ _name(_key_name key) ++ ": " ++ T.unpack enm ++ ": base-64 decode failure" - Right bs -> s_e'' key bs - where - EnvVar enm = fromJustNote "scan_env" $ _key_env_var key +-- | Return the hash comment of a key/ +showHashComment :: IC -> Bool -> Name -> IO B.ByteString +showHashComment ic = show_it' ic "hash" _key_hash cmt + where + cmt = B.pack . T.unpack . _Comment . _hashd_comment . _hash_description - s_e'' Key{..} bs = - do btw $ _name _key_name ++ " loaded\n" - _ <- rememberKey _key_name (ClearText $ Binary bs) - return () +-- | Retuen the hash salt of a key. +showHashSalt :: IC -> Bool -> Name -> IO B.ByteString +showHashSalt ic = show_it ic "hash" (fmap (_hashd_salt . _hash_description) . _key_hash) _Salt - k_evs = [ (key,ev) | key<-Map.elems mp, Just ev<-[_key_env_var key], - isNothing(_key_clear_text key) ] +-- | (For public key pairs only) return the public key. +showPublic :: IC -> Bool -> Name -> IO B.ByteString +showPublic ic = show_it ic "public" (fmap encodePublicKeyDER . _key_public) _ClearText - mp = _ks_keymap ks +-- | Return the secret text of a key (will be the private key for a public key pair). +showSecret :: IC -> Bool -> Name -> IO B.ByteString +showSecret ic = show_it ic "secret" _key_clear_text _ClearText - ctx = - Ctx - { ctx_now = now - , ctx_store = "" - , ctx_settings = defaultSettings - } +show_it :: IC + -> String + -> (Key->Maybe a) + -> (a->Binary) + -> Bool + -> Name + -> IO B.ByteString +show_it ic lbl prj_1 prj_2 aa nm = show_it' ic lbl prj_1 (_Binary . prj_2) aa nm - st0 = - State - { st_cprng = testCPRNG - , st_keystore = ks - } +show_it' :: IC + -> String + -> (Key->Maybe a) + -> (a->B.ByteString) + -> Bool + -> Name + -> IO B.ByteString +show_it' ic lbl prj_1 prj_2 aa nm = + do key <- loadKey ic nm + case prj_2 <$> prj_1 key of + Nothing -> errorIO $ printf "%s: %s not present" (_name nm) lbl + Just bs -> return $ armr bs + where + armr = if aa then B64.encode else id --- | Read the JSON-encoded KeyStore settings from the named file. -readSettings :: FilePath -> IO Settings -readSettings fp = - do lbs <- LBS.readFile fp - case eitherDecode lbs of - Left msg -> errorIO msg - Right val -> - case val of - Object hm -> return $ Settings hm - _ -> errorIO "JSON object expected in the configuration file" +-- | List a summary of all of the keys on stdout. +list :: IC -> IO () +list ic = run ic $ listKS -errorIO :: String -> IO a -errorIO msg = e2io $ Left $ strMsg msg +-- Summarize a single key on stdout. +keyInfo :: IC -> Name -> IO () +keyInfo ic nm = run ic $ keyInfoKS nm -ioE :: IO (E a) -> IO a -ioE p = p >>= either X.throw return +-- | Return all of the keys in the keystore. +keys :: IC -> IO [Key] +keys ic = Map.elems . _ks_keymap <$> get_keystore ic -logit :: Ctx -> LogEntry -> IO () -logit ctx LogEntry{..} = - case dbg || not le_debug of - True -> hPutStr h $ pfx ++ le_message - False -> return () +-- | Delete a list of keys from the keystore. +deleteKeys :: IC -> [Name] -> IO () +deleteKeys ic nms = run ic $ deleteKeysKS nms + +-- Encrypt a file with a named key. +encrypt :: IC -> Name -> FilePath -> FilePath -> IO () +encrypt ic nm s_fp d_fp = + do bs <- B.readFile s_fp + bs' <- encrypt_ ic nm bs + B.writeFile d_fp bs' + +-- | Encrypt a 'B.ByteString' with a named key. +encrypt_ :: IC -> Name -> B.ByteString -> IO B.ByteString +encrypt_ ic nm bs = _Binary . _EncryptionPacket <$> + (run ic $ encryptWithRSAKeyKS nm $ ClearText $ Binary bs) + +-- | Encrypt a 'B.ByteString' with a named key to produce a 'RSASecretData'. + +encrypt__ :: IC -> Name -> B.ByteString -> IO RSASecretData +encrypt__ ic nm bs = run ic $ encryptWithRSAKeyKS_ nm $ ClearText $ Binary bs + + +-- | Decrypt a file with the named key (whose secret text must be accessible). +decrypt :: IC -> FilePath -> FilePath -> IO () +decrypt ic s_fp d_fp = + do bs <- B.readFile s_fp + bs' <- decrypt_ ic bs + B.writeFile d_fp bs' + +-- | Decrypt a 'B.ByteString' with the named key +-- (whose secret text must be accessible). +decrypt_ :: IC -> B.ByteString -> IO B.ByteString +decrypt_ ic bs = _Binary . _ClearText <$> + (run ic $ decryptWithRSAKeyKS $ EncryptionPacket $ Binary bs) + +-- | Decrypt a 'B.ByteString' from a 'RSASecretData' with the named key +-- (whose secret text must be accessible). +decrypt__ :: IC -> Name -> RSASecretData -> IO B.ByteString +decrypt__ ic nm rsd = _Binary . _ClearText <$> (run ic $ decryptWithRSAKeyKS_ nm rsd) + +-- | Sign a file with the named key (whose secret text must be accessible) +-- to produce a detached signature in the named file. +sign :: IC -> Name -> FilePath -> FilePath -> IO () +sign ic nm s_fp d_fp = + do bs <- B.readFile s_fp + bs' <- sign_ ic nm bs + B.writeFile d_fp bs' + +-- | Sign a 'B.ByteString' with the named key (whose secret text must be accessible) +-- to produce a detached signature. +sign_ :: IC -> Name -> B.ByteString -> IO B.ByteString +sign_ ic nm m_bs = _Binary . _SignaturePacket <$> + (run ic $ signWithRSAKeyKS nm $ ClearText $ Binary m_bs) + +-- | Verify that a signature for a file via the named public key. +verify :: IC -> FilePath -> FilePath -> IO Bool +verify ic m_fp s_fp = + do m_bs <- B.readFile m_fp + s_bs <- B.readFile s_fp + ok <- verify_ ic m_bs s_bs + case ok of + True -> return () + False -> report "signature does not match the data" + return ok + +-- | Verify that a signature for a 'B.ByteString' via the named public key. +verify_ :: IC -> B.ByteString -> B.ByteString -> IO Bool +verify_ ic m_bs s_bs = + run ic $ verifyWithRSAKeyKS (ClearText $ Binary m_bs) + (SignaturePacket $ Binary s_bs) + +-- | Run a KS function in an IO context, dealing with keystore updates, output, +-- debug logging and errors. +run :: IC -> KS a -> IO a +run ic p = + do (ctx,st0) <- get ic + st1 <- scan_env ctx st0 + let msg = "[Keystore: " ++ ctx_store ctx ++"]\n" + (e,st2,les) = run_ ctx st1 $ debugLog msg >> p + r <- e2io e + mapM_ (logit ctx) les + st' <- backup_env ctx st2 + put ic ctx st' + return r + +scan_env :: Ctx -> State -> IO State +scan_env ctx st0 = + do (ks,les) <- scanEnv ks0 + mapM_ (logit ctx) les + return st0 { st_keystore = ks } where - dbg = getSettingsOpt opt__debug_enabled $ ctx_settings ctx - pfx = if le_debug then "(debug) " else "" - h = if le_debug then stderr else stdout + ks0 = st_keystore st0 -lu_path :: FilePath -> [FilePath] -> IO FilePath -> IO FilePath -lu_path _ [] nope = nope -lu_path fp (dp:dps) nope = - do fps <- getDirectoryContents dp `X.catch` \(_::X.SomeException) -> return [] - case fp `elem` fps of - True -> return $ dp fp - False -> lu_path fp dps nope +backup_env :: Ctx -> State -> IO State +backup_env ctx st0 = + do mapM_ (logit ctx) les' + e2io e + return st' + where + (e,st',les') = run_ ctx st0 backupKeysKS -mk_path :: IO [FilePath] -mk_path = - do mb <- lookupEnv "HOME" - return $ - [ "." ] ++ - [ hd ".keystore" | Just hd<-[mb] ] ++ - [ "/var/lib/keystore" ] +get_keystore :: IC -> IO KeyStore +get_keystore ic = st_keystore <$> get_state ic + +get_state :: IC -> IO State +get_state ic = snd <$> get ic + +get :: IC -> IO (Ctx,State) +get IC{..} = + case ic_cache of + Nothing -> determineCtx ic_ctx_params + Just rf -> readIORef rf + +put :: IC -> Ctx -> State -> IO () +put IC{..} ctx st = + do maybe (return ()) (flip writeIORef (ctx,st)) ic_cache + when (not $ maybe False id $ cp_readonly ic_ctx_params) $ + LBS.writeFile (ctx_store ctx) $ keyStoreBytes $ st_keystore st + +report :: String -> IO () +report = hPutStrLn stderr diff --git a/src/Data/KeyStore/IO/IC.hs b/src/Data/KeyStore/IO/IC.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/IO/IC.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.KeyStore.IO.IC + ( IC(..) + , CtxParams(..) + , defaultCtxParams + , defaultSettingsFilePath + , settingsFilePath + , defaultKeyStoreFilePath + , determineCtx + , establishState + , newGenerator + , readKeyStore + , readSettings + , scanEnv + , errorIO + , logit + ) where + +import Data.KeyStore.KS +import Data.KeyStore.Types +import Data.API.Types +import Data.Aeson +import Data.Text as T +import qualified Data.Map as Map +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe +import Data.Time +import Data.IORef +import qualified Control.Exception as X +import Control.Applicative +import System.Environment +import System.Directory +import System.FilePath +import System.IO +import Safe + + +data IC = + IC { ic_ctx_params :: CtxParams + , ic_cache :: Maybe (IORef (Ctx,State)) + } + +-- | The parameters used to set up a KeyStore session. +data CtxParams + = CtxParams + { cp_store :: Maybe FilePath -- ^ location of any explictlt specified keystore file + , cp_debug :: Maybe Bool -- ^ whether debug output has been specified enabled or not + , cp_readonly :: Maybe Bool -- ^ Just True => do not update keystore + } + deriving (Show) + +-- | Suitable default 'CtxParams'. +defaultCtxParams :: CtxParams +defaultCtxParams = + CtxParams + { cp_store = Nothing + , cp_debug = Nothing + , cp_readonly = Nothing + } + +-- | The default place for keystore settings (settings). +defaultSettingsFilePath :: FilePath +defaultSettingsFilePath = settingsFilePath "settings" + +-- | Add the standard file extension to a base name (.json). +settingsFilePath :: String -> FilePath +settingsFilePath base = base ++ ".json" + + +-- | The default file for a keystore (keystore.json). +defaultKeyStoreFilePath :: FilePath +defaultKeyStoreFilePath = "keystore.json" + +-- | Determine the 'Ctx' and keystore 'State' from 'CtxParams' +determineCtx :: CtxParams -> IO (Ctx,State) +determineCtx CtxParams{..} = + do str_fp_ <- + case cp_store of + Nothing -> + do mb_ev_pth <- lookupEnv "KEYSTORE" + case mb_ev_pth of + Nothing -> + do pth <- mk_path + lu_path defaultKeyStoreFilePath pth $ + errorIO "keystore not found" + Just str_fp -> return str_fp + Just str_fp -> return str_fp + cwd <- getCurrentDirectory + now <- getCurrentTime + let str_fp = cwd str_fp_ + ctx0 = Ctx + { ctx_now = now + , ctx_store = str_fp + , ctx_settings = defaultSettings + } + ks <- readKeyStore ctx0 + g <- newGenerator + let st = + State + { st_keystore = ks + , st_cprng = g + } + sdbg = setSettingsOpt opt__debug_enabled $ maybe False id cp_debug + stg = sdbg $ configurationSettings $ _ks_config ks + ctx = ctx0 { ctx_settings = stg } + return (ctx,st) + +-- | Set up the keystore state. +establishState :: Ctx -> IO State +establishState ctx = + do ks <- readKeyStore ctx + g <- newGenerator + return + State + { st_keystore = ks + , st_cprng = g + } + +newGenerator :: IO CPRNG +newGenerator = newCPRNG + +readKeyStore :: Ctx -> IO KeyStore +readKeyStore ctx = ioE $ keyStoreFromBytes <$> LBS.readFile (ctx_store ctx) + +scanEnv :: KeyStore -> IO (KeyStore,[LogEntry]) +scanEnv ks = getCurrentTime >>= \now -> scanEnv' now ks + +scanEnv' :: UTCTime -> KeyStore -> IO (KeyStore,[LogEntry]) +scanEnv' now ks = s_e <$> mapM lu k_evs + where + lu (key,EnvVar enm) = fmap ((,) key) <$> lookupEnv (T.unpack enm) + + s_e mbs = + case e of + Left _ -> error "scanEnv: unexpected error" + Right _ -> (st_keystore st',les) + where + (e,st',les) = run_ ctx st0 $ mapM_ s_e' $ catMaybes mbs + + s_e' (key,sv) = + case _key_is_binary key of + False -> s_e'' key $ B.pack sv + True -> + case B64.decode $ B.pack sv of + Left _ -> putStrKS $ _name(_key_name key) ++ ": " ++ T.unpack enm ++ ": base-64 decode failure" + Right bs -> s_e'' key bs + where + EnvVar enm = fromJustNote "scan_env" $ _key_env_var key + + s_e'' Key{..} bs = + do btw $ _name _key_name ++ " loaded\n" + _ <- rememberKeyKS _key_name (ClearText $ Binary bs) + return () + + k_evs = [ (key,ev) | key<-Map.elems mp, Just ev<-[_key_env_var key], + isNothing(_key_clear_text key) ] + + mp = _ks_keymap ks + + ctx = + Ctx + { ctx_now = now + , ctx_store = "" + , ctx_settings = defaultSettings + } + + st0 = + State + { st_cprng = testCPRNG + , st_keystore = ks + } + +-- | Read the JSON-encoded KeyStore settings from the named file. +readSettings :: FilePath -> IO Settings +readSettings fp = + do lbs <- LBS.readFile fp + case eitherDecode lbs of + Left msg -> errorIO msg + Right val -> + case val of + Object hm -> return $ Settings hm + _ -> errorIO "JSON object expected in the configuration file" + +errorIO :: String -> IO a +errorIO msg = e2io $ Left $ strMsg msg + +ioE :: IO (E a) -> IO a +ioE p = p >>= either X.throw return + +logit :: Ctx -> LogEntry -> IO () +logit ctx LogEntry{..} = + case dbg || not le_debug of + True -> hPutStr h $ pfx ++ le_message + False -> return () + where + dbg = getSettingsOpt opt__debug_enabled $ ctx_settings ctx + pfx = if le_debug then "(debug) " else "" + h = if le_debug then stderr else stdout + +lu_path :: FilePath -> [FilePath] -> IO FilePath -> IO FilePath +lu_path _ [] nope = nope +lu_path fp (dp:dps) nope = + do fps <- getDirectoryContents dp `X.catch` \(_::X.SomeException) -> return [] + case fp `elem` fps of + True -> return $ dp fp + False -> lu_path fp dps nope + +mk_path :: IO [FilePath] +mk_path = + do mb <- lookupEnv "HOME" + return $ + [ "." ] ++ + [ hd ".keystore" | Just hd<-[mb] ] ++ + [ "/var/lib/keystore" ] diff --git a/src/Data/KeyStore/KS.hs b/src/Data/KeyStore/KS.hs --- a/src/Data/KeyStore/KS.hs +++ b/src/Data/KeyStore/KS.hs @@ -1,200 +1,470 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} module Data.KeyStore.KS - ( KS - , Ctx(..) - , State(..) - , LogEntry(..) - , withKey - , trun - , e2io - , e2ks - , run_ - , randomBytes - , currentTime - , putStrKS - , btw - , catchKS - , errorKS - , throwKS - , lookupOpt - , getSettings - , lookupKey - , insertNewKey - , insertKey - , adjustKeyKS - , deleteKeysKS - , randomRSA - , randomKS - , getKeymap - , getConfig - , modConfig + ( keyStoreBytes + , keyStoreFromBytes + , settingsFromBytes + , createRSAKeyPairKS + , encryptWithRSAKeyKS + , encryptWithRSAKeyKS_ + , decryptWithRSAKeyKS + , decryptWithRSAKeyKS_ + , signWithRSAKeyKS + , verifyWithRSAKeyKS + , encryptWithKeysKS + , decryptWithKeysKS + , createKeyKS + , backupKeysKS + , rememberKeyKS + , secureKeyKS + , getKeysKS + , listKS + , keyInfoKS + , loadKeyKS + , loadEncryptionKeyKS + , module Data.KeyStore.KS.Crypto + , module Data.KeyStore.KS.KS + , module Data.KeyStore.KS.Opt + , module Data.KeyStore.KS.Configuration + , module Data.KeyStore.KS.CPRNG ) where -import Data.KeyStore.Configuration -import Data.KeyStore.Opt +import Data.KeyStore.KS.Packet +import Data.KeyStore.KS.Crypto +import Data.KeyStore.KS.KS +import Data.KeyStore.KS.Opt +import Data.KeyStore.KS.Configuration +import Data.KeyStore.KS.CPRNG import Data.KeyStore.Types -import Data.KeyStore.CPRNG -import Crypto.PubKey.RSA +import Data.API.JSON +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map -import qualified Data.ByteString as B -import Data.Typeable +import qualified Data.Text as T +import Data.Maybe +import Data.List import Data.Time +import Text.Printf import Control.Applicative -import Control.Monad.RWS.Strict -import qualified Control.Monad.Error as E -import Control.Exception import Control.Lens +import Control.Monad -newtype KS a = KS { _KS :: E.ErrorT Reason (RWS Ctx [LogEntry] State) a } - deriving (Functor, Applicative, Monad, E.MonadError Reason) +------------------------------------------------------------------------------- +-- | Encode a key store as a JSON ByteString (discarding any cached cleartext +-- copies of secrets it may have) +keyStoreBytes :: KeyStore -> LBS.ByteString +keyStoreBytes = encode . cln + where + cln ks = + ks { _ks_keymap = cleanKeyMap $ _ks_keymap ks + } -data Ctx - = Ctx - { ctx_now :: UTCTime - , ctx_store :: FilePath - , ctx_settings :: Settings - } - deriving (Typeable,Show) -data State - = State - { st_keystore :: KeyStore - , st_cprng :: CPRNG - } - deriving (Typeable) +------------------------------------------------------------------------------- +-- Parse a key store from a JSON ByteString. +keyStoreFromBytes :: LBS.ByteString -> E KeyStore +keyStoreFromBytes = chk . either (const Nothing) Just . decodeWithErrs + where + chk Nothing = Left $ strMsg "failed to decode keystore file" + chk (Just ks) = Right ks -data LogEntry - = LogEntry - { le_debug :: Bool - , le_message :: String - } - deriving (Show) -withKey :: Name -> KS a -> KS a -withKey nm p = - do ctx <- KS ask - st <- KS get - let cfg = _ks_config $ st_keystore st - stgs = _cfg_settings cfg - stgs' <- e2ks $ trigger nm cfg stgs - case run_ ctx {ctx_settings=stgs'} st p of - (e,st',les) -> - do KS $ put st' - KS $ tell les - either throwKS return e +------------------------------------------------------------------------------- +-- Parse key store settings from a JSON ByteString. +settingsFromBytes :: LBS.ByteString -> E Settings +settingsFromBytes = chk . either (const Nothing) Just . decodeWithErrs + where + chk (Just(Object fm)) = Right $ Settings fm + chk _ = Left $ strMsg "failed to decode JSON settings" -trun :: KS a -> a -trun p = - case run_ (Ctx u "keystore.json" defaultSettings) s p of - (Left e,_,_) -> error $ show e - (Right x,_,_) -> x + +------------------------------------------------------------------------------- +-- Create a random RSA key pair under a name in the key store, +-- safeguarding it zero, one or more times. +createRSAKeyPairKS :: Name -> Comment -> Identity -> [Safeguard] -> KS () +createRSAKeyPairKS nm cmt ide nmz = + do _ <- createKeyKS nm cmt ide Nothing Nothing + (puk,prk) <- generateKeysKS + adjustKeyKS nm (add_puk puk) + rememberKeyKS nm $ encodePrivateKeyDER prk + mapM_ (secureKeyKS nm) nmz where - s = State - { st_cprng = testCPRNG - , st_keystore = emptyKeyStore $ defaultConfiguration defaultSettings + add_puk puk key = key { _key_public = Just puk } + + +------------------------------------------------------------------------------- +-- | Encrypt a clear text message with a name RSA key pair. +encryptWithRSAKeyKS :: Name -> ClearText -> KS EncryptionPacket +encryptWithRSAKeyKS nm ct = + encocdeEncryptionPacket (safeguard [nm]) . + encodeRSASecretData <$> encryptWithRSAKeyKS_ nm ct + +encryptWithRSAKeyKS_ :: Name -> ClearText -> KS RSASecretData +encryptWithRSAKeyKS_ nm ct = + do scd <- _ec_secret_data <$> encryptWithKeysKS (safeguard [nm]) ct + case scd of + ECD_rsa rsd -> return rsd + _ -> errorKS "RSA key expected" + + +------------------------------------------------------------------------------- +-- | Decrypt an RSA-encrypted message (the RSA secret key named in the message +-- must be available.) +decryptWithRSAKeyKS :: EncryptionPacket -> KS ClearText +decryptWithRSAKeyKS ep = + do (sg,rsb) <- e2ks $ decocdeEncryptionPacketE ep + nm <- case safeguardKeys sg of + [nm] -> return nm + _ -> errorKS "expected a single (RSA) key in the safeguard" + rsd <- decodeRSASecretData rsb + decryptWithRSAKeyKS_ nm rsd + +decryptWithRSAKeyKS_ :: Name -> RSASecretData -> KS ClearText +decryptWithRSAKeyKS_ nm rsd = + do key <- loadKeyKS nm + case _key_clear_private key of + Nothing -> errorKS "could not load private key" + Just prk -> decryptKS prk rsd + + +------------------------------------------------------------------------------- +-- | Sign a message with a named RSA secret key (which must be available). +signWithRSAKeyKS :: Name -> ClearText -> KS SignaturePacket +signWithRSAKeyKS nm ct = + do key <- loadKeyKS nm + case _key_clear_private key of + Nothing -> errorKS "could not load private key" + Just prk -> encocdeSignaturePacket (safeguard [nm]) <$> signKS prk ct + + +------------------------------------------------------------------------------- +-- | Verify that an RSA signature of a message is correct. +verifyWithRSAKeyKS :: ClearText -> SignaturePacket -> KS Bool +verifyWithRSAKeyKS ct sp = + do (sg,rs) <- e2ks $ decocdeSignaturePacketE sp + nm <- case safeguardKeys sg of + [nm] -> return nm + _ -> errorKS "expected a single (RSA) key in the safeguard" + key <- lookupKey nm + case _key_public key of + Nothing -> errorKS "not an RSA key pair" + Just puk -> return $ verifyKS puk ct rs + + +------------------------------------------------------------------------------- +-- | Symetrically encrypt a message with a Safeguard (list of names private +-- keys). +encryptWithKeysKS :: Safeguard -> ClearText -> KS EncrypedCopy +encryptWithKeysKS nms ct = + do ec <- defaultEncryptedCopyKS nms + mb <- loadEncryptionKeyKS Encrypting ec + ek <- case mb of + Nothing -> errorKS "could not load keys" + Just ek -> return ek + ecd <- saveKS ek ct + return ec { _ec_secret_data = ecd } + + +------------------------------------------------------------------------------- +-- | Symetrically encrypt a message with a Safeguard (list of names private +-- keys). +decryptWithKeysKS :: EncrypedCopy -> KS ClearText +decryptWithKeysKS ec = + do mb <- loadEncryptionKeyKS Decrypting ec + ek <- case mb of + Nothing -> errorKS "could not load keys" + Just ek -> return ek + restoreKS (_ec_secret_data ec) ek + + +------------------------------------------------------------------------------- +-- | Create a private key. +createKeyKS :: Name -- ^ (unique) name of the new key + -> Comment -- ^ the comment string + -> Identity -- ^ the identity string + -> Maybe EnvVar -- ^ the environment variable used to hold a clear text copy + -> Maybe ClearText -- ^ (optionally) the clear test copy + -> KS () +createKeyKS nm cmt ide mb_ev mb_ct = withKey nm $ + do now <- currentTime + insertNewKey + Key + { _key_name = nm + , _key_comment = cmt + , _key_identity = ide + , _key_is_binary = False + , _key_env_var = mb_ev + , _key_hash = Nothing + , _key_public = Nothing + , _key_secret_copies = Map.empty + , _key_clear_text = Nothing + , _key_clear_private = Nothing + , _key_created_at = now } + maybe (return ()) (rememberKeyKS nm) mb_ct - u = read "2014-01-01 00:00:00" -e2io :: E a -> IO a -e2io = either throwIO return +------------------------------------------------------------------------------- +-- | Remember the secret text for a key -- will record the hash and encrypt +-- it with the configured safeguards, generating an error if any of the +-- safeguards are not available. +rememberKeyKS :: Name -> ClearText -> KS () +rememberKeyKS nm ct = + do btw $ "remembering " ++ show nm ++ "\n" + key0 <- lookupKey nm + let key1 = key0 { _key_clear_text = Just ct } + vfy <- lookupOpt opt__verify_enabled + key2 <- case vfy of + True -> verify_key key1 ct + False -> return key1 + key <- + case _key_hash key2 of + Nothing | isNothing $ _key_public key2 -> upd key2 <$> hashKS ct + _ -> return key2 + insertKey key + backupKeyKS nm + where + upd key hsh = + key { _key_hash = Just hsh + } -e2ks :: E a -> KS a -e2ks = either throwKS return -run_ :: Ctx -> State -> KS a -> (E a,State,[LogEntry]) -run_ c s p = runRWS (E.runErrorT (_KS p)) c s +------------------------------------------------------------------------------- +-- | Backup all of the keys in the store with their configured backup keys. +backupKeysKS :: KS () +backupKeysKS = getKeysKS >>= mapM_ (backupKeyKS . _key_name) -randomBytes :: Octets -> (B.ByteString->a) -> KS a -randomBytes (Octets sz) k = k <$> randomKS (generateCPRNG sz) -currentTime :: KS UTCTime -currentTime = ctx_now <$> KS ask +------------------------------------------------------------------------------- +-- | Backup a named key with its configured backup key. +backupKeyKS :: Name -> KS () +backupKeyKS nm = withKey nm $ + do nms <- lookupOpt opt__backup_keys + mapM_ backup nms + where + backup nm' = secure_key nm $ safeguard [nm'] -putStrKS :: String -> KS () -putStrKS msg = KS $ tell [LogEntry False msg] -btw :: String -> KS () -btw msg = KS $ tell [LogEntry True msg] +------------------------------------------------------------------------------- +-- | Primitive to make a cryptographic copy (i.e., a safeguard) of the +-- secret text of a key, storing it in the key (and doing nothing if the +-- that safeguard is already present). +secureKeyKS :: Name -> Safeguard -> KS () +secureKeyKS nm sg = withKey nm $ secure_key nm sg -catchKS :: KS a -> (Reason -> KS a) -> KS a -catchKS = E.catchError +secure_key :: Name -> Safeguard -> KS () +secure_key nm sg = + do btw $ "securing " ++ show nm ++ " with " ++ show sg ++ "\n" + key <- loadKeyKS nm + when (isNothing $ Map.lookup sg $ _key_secret_copies key) $ + do ct <- case _key_clear_text key of + Nothing -> errorKS $ _name nm ++ ": cannot load key" + Just ct -> return ct + ec0 <- defaultEncryptedCopyKS sg + mbk <- loadEncryptionKeyKS Encrypting ec0 + ek <- case mbk of + Nothing -> errorKS $ + printSafeguard sg ++ ": cannot load encryption keys" + Just ek -> return ek + ecd <- saveKS ek ct + let ec = ec0 { _ec_secret_data = ecd } + insertKey $ over key_secret_copies (Map.insert sg ec) key -errorKS :: String -> KS a -errorKS = throwKS . strMsg -throwKS :: Reason -> KS a -throwKS = E.throwError +------------------------------------------------------------------------------- +-- | List all of the keys in the store, one per line, on the output. +listKS :: KS () +listKS = + do nms <- map _key_name <$> getKeysKS + keys <- mapM loadKeyKS $ sort nms + putStrKS $ concat $ map (list_key False) keys -lookupOpt :: Opt a -> KS a -lookupOpt opt = getSettingsOpt opt <$> getSettings +-- | Print out the information of a particular key. +keyInfoKS :: Name -> KS () +keyInfoKS nm = + do key <- loadKeyKS nm + putStrKS $ list_key True key -getSettings :: KS Settings -getSettings = ctx_settings <$> KS ask +data Line + = LnHeader String + | LnDate UTCTime + | LnHash String + | LnCopiesHeader + | LnCopy String + deriving Show -lookupKey :: Name -> KS Key -lookupKey nm = - do mp <- getKeymap - maybe oops return $ Map.lookup nm mp +list_key :: Bool -> Key -> String +list_key True key@Key{..} = + unlines $ map fmt $ + [ LnHeader hdr ] ++ + [ LnDate _key_created_at ] ++ + [ LnHash hsh | Just hsh<-[mb_hsh] ] ++ + [ LnCopiesHeader ] ++ + [ LnCopy $ fmt_ec ec | ec<-Map.elems $ _key_secret_copies ] where - oops = errorKS $ _name nm ++ ": no such keystore key" + fmt ln = + case ln of + LnHeader s -> s + LnDate u -> fmt_ln 2 "Date:" $ show u + LnHash s -> fmt_ln 2 "Hash:" s + LnCopiesHeader -> fmt_ln 2 "Copies:" "" + LnCopy s -> fmt_ln_ 4 s -insertNewKey :: Key -> KS () -insertNewKey key = - do mp <- getKeymap - maybe (return ()) (const oops) $ Map.lookup nm mp - insertKey key + hdr = printf "%s: %s%s -- %s" nm sts ev cmt + where + nm = _name _key_name + sts = status key + ev = maybe "" (printf " ($%s)" . T.unpack . _EnvVar) _key_env_var + cmt = T.unpack $ _Comment _key_comment + mb_hsh = fmt_hsh <$> _key_hash + + fmt_ec EncrypedCopy{..} = printf "%s(%d*%s[%s])" ci is pf sg + where + ci = show _ec_cipher + Iterations is = _ec_iterations + pf = show _ec_prf + sg = printSafeguard _ec_safeguard + + fmt_hsh Hash{_hash_description=HashDescription{..}} = printf "%d*%s(%d):%d" is pf sw wd + where + Iterations is = _hashd_iterations + pf = show _hashd_prf + Octets sw = _hashd_salt_octets + Octets wd = _hashd_width_octets + + fmt_ln i s s' = fmt_ln_ i $ printf "%-8s %s" s s' + fmt_ln_ i s = replicate i ' ' ++ s +list_key False key@Key{..} = printf "%-40s : %s%s (%s)\n" nm sts ev ecs where - oops = errorKS $ _name nm ++ ": key already in use" + nm = _name _key_name + sts = status key + ev = maybe "" (printf " ($%s)" . T.unpack . _EnvVar) _key_env_var + ecs = intercalate "," $ map (printSafeguard . _ec_safeguard) $ + Map.elems _key_secret_copies - nm = _key_name key +status :: Key -> String +status Key{..} = [sts_t,sts_p] + where + sts_t = maybe '-' (const 'T') _key_clear_text + sts_p = maybe '-' (const 'P') _key_public -insertKey :: Key -> KS () -insertKey key = mod_keymap $ Map.insert (_key_name key) key -adjustKeyKS :: Name -> (Key->Key) -> KS () -adjustKeyKS nm adj = mod_keymap $ Map.adjust adj nm +------------------------------------------------------------------------------- +-- | Return all of the keys in the keystore. +getKeysKS :: KS [Key] +getKeysKS = Map.elems <$> getKeymap -deleteKeysKS :: [Name] -> KS () -deleteKeysKS nms = - do s <- KS get - let mp = _ks_keymap $ st_keystore s - mp' = foldr Map.delete mp nms - case Map.null $ Map.filter tst mp' of - True -> mod_keymap $ const mp' - False -> errorKS "cannot delete these keys because they are still being used" + +------------------------------------------------------------------------------- +-- | Try to load the secret copy into the key and return it. (No error is +-- raised if it failed to recover the secret.) +loadKeyKS :: Name -> KS Key +loadKeyKS = load_key [] + +load_key :: [Name] -> Name -> KS Key +load_key nm_s nm = + do key <- lookupKey nm + maybe (load_key' nm_s nm) (const $ return key) $ _key_clear_text key + +load_key' :: [Name] -> Name -> KS Key +load_key' nm_s nm = + do key0 <- lookupKey nm + let ld [] = return key0 + ld (sc:scs) = + do key <- load_key'' nm_s nm key0 sc + case _key_clear_text key of + Nothing -> ld scs + Just _ -> return key + ld $ Map.elems $ _key_secret_copies key0 + +load_key'' :: [Name] + -> Name + -> Key + -> EncrypedCopy + -> KS Key +load_key'' nm_s nm key@Key{..} ec = + case nm `elem` nm_s of + True -> return key + False -> + do mbk <- loadEncryptionKeyKS_ Decrypting (nm:nm_s) ec + case mbk of + Nothing -> return key + Just ek -> + do ct <- restoreKS (_ec_secret_data ec) ek + rememberKeyKS nm ct + lookupKey nm + + +------------------------------------------------------------------------------- +-- | Try to load an encryption or decryption key for an encrypted message. +loadEncryptionKeyKS :: Dirctn -> EncrypedCopy -> KS (Maybe EncryptionKey) +loadEncryptionKeyKS dir sc = loadEncryptionKeyKS_ dir [] sc + +loadEncryptionKeyKS_ :: Dirctn -> [Name] -> EncrypedCopy -> KS (Maybe EncryptionKey) +loadEncryptionKeyKS_ dir nms_s sc = + case nms of + [] -> return $ Just $ EK_none void_ + [nm] -> + do key <- lookupKey nm + maybe sym (asm dir nm) $ _key_public key + _ -> sym where - tst key = or [ any (`elem` safeguardKeys sg) nms | - sg<-Map.keys $ _key_secret_copies key ] + sym = + do keys <- mapM (load_key nms_s) nms + case all (isJust._key_clear_text) keys of + True -> Just . EK_symmetric <$> + (mkAESKeyKS sc $ catMaybes $ map _key_clear_text keys) + False -> return Nothing -randomRSA :: (CPRNG->(Either Error a,CPRNG)) -> KS a -randomRSA f = randomKS f >>= either (throwKS . rsaError) return + asm Encrypting _ puk = return $ Just $ EK_public puk + asm Decrypting nm _ = + do key <- load_key nms_s nm + case _key_clear_private key of + Nothing -> return Nothing + Just prk -> return $ Just $ EK_private prk -randomKS :: (CPRNG->(a,CPRNG)) -> KS a -randomKS f = KS $ - do s <- get - let (x,!g') = f $ st_cprng s - put s { st_cprng = g' } - return x + nms = safeguardKeys $ _ec_safeguard sc -getKeymap :: KS KeyMap -getKeymap = _ks_keymap.st_keystore <$> KS get -getConfig :: KS Configuration -getConfig = _ks_config.st_keystore <$> KS get +------------------------------------------------------------------------------- +verify_key :: Key -> ClearText -> KS Key +verify_key key@Key{..} ct = + case (_key_hash,_key_public) of + (Just hsh,_ ) -> + case verify_key_ hsh ct of + True -> return key { _key_clear_text = Just ct } + False -> errorKS "key failed to match hash" + (Nothing ,Just puk) -> + do prk <- e2ks $ verify_private_key_ puk ct + return + key { _key_clear_text = Just ct + , _key_clear_private = Just prk + } + _ -> return + key { _key_clear_text = Just ct + } -mod_keymap :: (KeyMap->KeyMap) -> KS () -mod_keymap upd = KS get >>= \st -> KS $ put - st - { st_keystore = over ks_keymap upd (st_keystore st) - } +verify_key_ :: Hash -> ClearText -> Bool +verify_key_ hsh ct = + _hash_hash(hashKS_ (_hash_description hsh) ct) == _hash_hash hsh -modConfig :: (Configuration->Configuration) -> KS () -modConfig upd = KS get >>= \st -> KS $ put - st - { st_keystore = over ks_config upd (st_keystore st) - } +verify_private_key_ :: PublicKey -> ClearText -> E PrivateKey +verify_private_key_ puk ct = + do prk <- decodePrivateKeyDERE ct + case puk==private_pub prk of + True -> return prk + False -> Left $ strMsg "private key mismatches public key" + + +------------------------------------------------------------------------------- +cleanKeyMap :: KeyMap -> KeyMap +cleanKeyMap mp = Map.map cln mp + where + cln key = + key { _key_clear_text = Nothing + , _key_clear_private = Nothing + } diff --git a/src/Data/KeyStore/KS/CPRNG.hs b/src/Data/KeyStore/KS/CPRNG.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/KS/CPRNG.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.KeyStore.KS.CPRNG + ( CPRNG + , newCPRNG + , testCPRNG + , generateCPRNG + ) where + +import Crypto.Random +import Control.Applicative +import qualified Data.ByteString as B + + +newtype CPRNG + = CPRNG { _CPRNG :: SystemRNG } + deriving (CPRG) + + +newCPRNG :: IO CPRNG +newCPRNG = cprgCreate <$> createEntropyPool + +testCPRNG :: CPRNG +testCPRNG = cprgSetReseedThreshold 0 $ + cprgCreate $ createTestEntropyPool "Data.CertStore.Tools" + +generateCPRNG :: Int -> CPRNG -> (B.ByteString,CPRNG) +generateCPRNG = cprgGenerate diff --git a/src/Data/KeyStore/KS/Configuration.hs b/src/Data/KeyStore/KS/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/KS/Configuration.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RecordWildCards #-} + +module Data.KeyStore.KS.Configuration where + +import Data.KeyStore.Types +import Data.Monoid +import qualified Data.Map as Map +import Data.Maybe +import Text.Regex + + +configurationSettings :: Configuration -> Settings +configurationSettings = _cfg_settings + +trigger :: Name -> Configuration -> Settings -> E Settings +trigger nm cfg stgs0 = + case checkSettingsCollisions stgs of + [] -> Right stgs + sids -> Left $ strMsg $ "settings collided in triggers: " + ++ nm_s ++ ": " ++ show(map _SettingID sids) + ++ "\n\n" ++ show (stgs0 : t_stgss) + where + stgs = mconcat $ stgs0 : t_stgss + + t_stgss = [ _trg_settings | Trigger{..}<-Map.elems $ _cfg_triggers cfg, + mtch _trg_pattern ] + + mtch pat = isJust $ matchRegex (_pat_regex pat) nm_s + + nm_s = _name nm diff --git a/src/Data/KeyStore/KS/Crypto.hs b/src/Data/KeyStore/KS/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/KS/Crypto.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} + +module Data.KeyStore.KS.Crypto + ( defaultEncryptedCopyKS + , saveKS + , restoreKS + , mkAESKeyKS + , encryptKS + , decryptKS + , decryptE + , encodeRSASecretData + , decodeRSASecretData + , decodeRSASecretData_ + , encryptRSAKS + , decryptRSAKS + , decryptRSAE + , oaep + , signKS + , verifyKS + , pssp + , encryptAESKS + , encryptAES + , decryptAES + , randomAESKeyKS + , randomIVKS + , hashKS + , defaultHashParamsKS + , hashKS_ + , generateKeysKS + , generateKeysKS_ + , decodePrivateKeyDERE + , decodePublicKeyDERE + , encodePrivateKeyDER + , encodePublicKeyDER + , decodeDERE + , encodeDER + -- testing + , test_crypto + ) where + + +import Data.KeyStore.KS.KS +import Data.KeyStore.KS.Opt +import Data.KeyStore.Types +import Data.API.Types +import qualified Data.ASN1.Encoding as A +import qualified Data.ASN1.BinaryEncoding as A +import qualified Data.ASN1.Types as A +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Char8 as B +import Control.Applicative +import Crypto.PubKey.RSA +import qualified Crypto.PubKey.RSA.OAEP as OAEP +import qualified Crypto.PubKey.RSA.PSS as PSS +import Crypto.PubKey.HashDescr +import Crypto.PubKey.MaskGenFunction +import Crypto.Cipher.AES + + +size_aes_iv, size_oae :: Octets +size_aes_iv = 16 +size_oae = 256 + + +-- +-- smoke tests +-- + +test_crypto :: Bool +test_crypto = test_oaep && test_pss + +test_oaep :: Bool +test_oaep = trun $ + do (puk,prk) <- generateKeysKS + tm' <- encryptKS puk tm >>= decryptKS prk + return $ tm' == tm + where + tm = ClearText $ Binary "test message" + +test_pss :: Bool +test_pss = trun $ + do (puk,prk) <- generateKeysKS + sig <- signKS prk tm + return $ verifyKS puk tm sig && not (verifyKS puk tm' sig) + where + tm = ClearText $ Binary "hello" + tm' = ClearText $ Binary "gello" + + +-- +-- defaultEncryptedCopy +-- + +defaultEncryptedCopyKS :: Safeguard -> KS EncrypedCopy +defaultEncryptedCopyKS sg = + do ciphr <- lookupOpt opt__crypt_cipher + prf <- lookupOpt opt__crypt_prf + itrns <- lookupOpt opt__crypt_iterations + st_sz <- lookupOpt opt__crypt_salt_octets + slt <- randomBytes st_sz (Salt . Binary) + return + EncrypedCopy + { _ec_safeguard = sg + , _ec_cipher = ciphr + , _ec_prf = prf + , _ec_iterations = itrns + , _ec_salt = slt + , _ec_secret_data = ECD_no_data void_ + } + + +-- +-- saving and restoring secret copies +-- + +saveKS :: EncryptionKey -> ClearText -> KS EncrypedCopyData +saveKS ek ct = + case ek of + EK_public puk -> ECD_rsa <$> encryptKS puk ct + EK_private _ -> errorKS "Crypto.Save: saving with private key" + EK_symmetric aek -> ECD_aes <$> encryptAESKS aek ct + EK_none _ -> ECD_clear <$> return ct + +restoreKS :: EncrypedCopyData -> EncryptionKey -> KS ClearText +restoreKS ecd ek = + case (ecd,ek) of + (ECD_rsa rsd,EK_private prk) -> decryptKS prk rsd + (ECD_aes asd,EK_symmetric aek) -> return $ decryptAES aek asd + (ECD_clear ct ,EK_none _ ) -> return ct + (ECD_no_data _ ,_ ) -> errorKS "restore: no data!" + _ -> errorKS "unexpected EncrypedCopy/EncryptionKey combo" + + +-- +-- making up an AESKey from a list of source texts +-- + +mkAESKeyKS :: EncrypedCopy -> [ClearText] -> KS AESKey +mkAESKeyKS _ [] = error "mkAESKey: no texts" +mkAESKeyKS EncrypedCopy{..} cts = p2 <$> lookupOpt opt__crypt_cipher + where + p2 ciphr = pbkdf _ec_prf ct _ec_salt _ec_iterations (keyWidth ciphr) $ AESKey . Binary + + ct = ClearText $ Binary $ B.concat $ map (_Binary._ClearText) cts + + +-- +-- encrypting & decrypting +-- + +encryptKS :: PublicKey -> ClearText -> KS RSASecretData +encryptKS pk ct = + do cip <- lookupOpt opt__crypt_cipher + aek <- randomAESKeyKS cip + rek <- encryptRSAKS pk aek + asd <- encryptAESKS aek ct + return + RSASecretData + { _rsd_encrypted_key = rek + , _rsd_aes_secret_data = asd + } + +decryptKS :: PrivateKey -> RSASecretData -> KS ClearText +decryptKS pk dat = e2ks $ decryptE pk dat + +decryptE :: PrivateKey -> RSASecretData -> E ClearText +decryptE pk RSASecretData{..} = + do aek <- decryptRSAE pk _rsd_encrypted_key + return $ decryptAES aek _rsd_aes_secret_data + + +-- +-- Serializing RSASecretData +-- + +encodeRSASecretData :: RSASecretData -> RSASecretBytes +encodeRSASecretData RSASecretData{..} = + RSASecretBytes $ Binary $ + B.concat + [ _Binary $ _RSAEncryptedKey _rsd_encrypted_key + , _Binary $ _IV _asd_iv + , _Binary $ _SecretData _asd_secret_data + ] + where + AESSecretData{..} = _rsd_aes_secret_data + +decodeRSASecretData :: RSASecretBytes -> KS RSASecretData +decodeRSASecretData (RSASecretBytes dat) = e2ks $ decodeRSASecretData_ $ _Binary dat + +decodeRSASecretData_ :: B.ByteString -> E RSASecretData +decodeRSASecretData_ dat0 = + do (eky,dat1) <- slice size_oae dat0 + (iv ,edat) <- slice size_aes_iv dat1 + return + RSASecretData + { _rsd_encrypted_key = RSAEncryptedKey $ Binary eky + , _rsd_aes_secret_data = + AESSecretData + { _asd_iv = IV $ Binary iv + , _asd_secret_data = SecretData $ Binary edat + } + } + where + slice sz bs = + case B.length bs >= _Octets sz of + True -> Right $ B.splitAt (_Octets sz) bs + False -> Left $ strMsg "decrypt: not enough bytes" + + +-- +-- RSA encrypting & decrypting +-- + +encryptRSAKS :: PublicKey -> AESKey -> KS RSAEncryptedKey +encryptRSAKS pk (AESKey (Binary dat)) = + RSAEncryptedKey . Binary <$> randomRSA (\g->OAEP.encrypt g oaep pk dat) + +decryptRSAKS :: PrivateKey -> RSAEncryptedKey -> KS AESKey +decryptRSAKS pk rek = either throwKS return $ decryptRSAE pk rek + +decryptRSAE :: PrivateKey -> RSAEncryptedKey -> E AESKey +decryptRSAE pk rek = + rsa2e $ fmap (AESKey . Binary) $ + OAEP.decrypt Nothing oaep pk $ _Binary $ _RSAEncryptedKey rek + +oaep :: OAEP.OAEPParams +oaep = + OAEP.OAEPParams + { OAEP.oaepHash = hashFunction hashDescrSHA512 + , OAEP.oaepMaskGenAlg = mgf1 + , OAEP.oaepLabel = Nothing + } + + +-- +-- signing & verifying +-- + +signKS :: PrivateKey -> ClearText -> KS RSASignature +signKS pk dat = + RSASignature . Binary <$> + randomRSA (\g->PSS.sign g Nothing pssp pk $ _Binary $ _ClearText dat) + +verifyKS :: PublicKey -> ClearText -> RSASignature -> Bool +verifyKS pk (ClearText (Binary dat)) (RSASignature (Binary sig)) = PSS.verify pssp pk dat sig + +pssp :: PSS.PSSParams +pssp = PSS.defaultPSSParams $ hashFunction hashDescrSHA512 + + +-- +-- AES encrypting/decrypting +-- + + +encryptAESKS :: AESKey -> ClearText -> KS AESSecretData +encryptAESKS aek ct = + do iv <- randomIVKS + return $ encryptAES aek iv ct + +encryptAES :: AESKey -> IV -> ClearText -> AESSecretData +encryptAES (AESKey (Binary ky)) (IV (Binary iv)) (ClearText (Binary dat)) = + AESSecretData + { _asd_iv = IV $ Binary iv + , _asd_secret_data = SecretData $ Binary $ encryptCTR (initAES ky) iv dat + } + +decryptAES :: AESKey -> AESSecretData -> ClearText +decryptAES aek AESSecretData{..} = + ClearText $ Binary $ + encryptCTR (initAES $ _Binary $ _AESKey aek ) + (_Binary $ _IV _asd_iv ) + (_Binary $ _SecretData _asd_secret_data) + +randomAESKeyKS :: Cipher -> KS AESKey +randomAESKeyKS cip = randomBytes (keyWidth cip) (AESKey . Binary) + +randomIVKS :: KS IV +randomIVKS = randomBytes size_aes_iv (IV . Binary) + + +-- +-- hashing +-- + + +hashKS :: ClearText -> KS Hash +hashKS ct = flip hashKS_ ct <$> defaultHashParamsKS + +defaultHashParamsKS :: KS HashDescription +defaultHashParamsKS = + do h_cmt <- lookupOpt opt__hash_comment + h_prf <- lookupOpt opt__hash_prf + itrns <- lookupOpt opt__hash_iterations + hs_wd <- lookupOpt opt__hash_width_octets + st_wd <- lookupOpt opt__hash_salt_octets + st <- randomBytes st_wd (Salt . Binary) + return $ hashd h_cmt h_prf itrns hs_wd st_wd st + where + hashd h_cmt h_prf itrns hs_wd st_wd st = + HashDescription + { _hashd_comment = h_cmt + , _hashd_prf = h_prf + , _hashd_iterations = itrns + , _hashd_width_octets = hs_wd + , _hashd_salt_octets = st_wd + , _hashd_salt = st + } + +hashKS_ :: HashDescription -> ClearText -> Hash +hashKS_ hd@HashDescription{..} ct = + Hash + { _hash_description = hd + , _hash_hash = pbkdf _hashd_prf ct _hashd_salt _hashd_iterations + _hashd_width_octets (HashData . Binary) + } + +--randomSalt :: KS Salt +--randomSalt = randomBytes size_salt Salt + +-- +-- Generating a private/public key pair +-- + +default_e :: Integer +default_e = 0x10001 + +default_key_size :: Int +default_key_size = 2048 `div` 8 + +generateKeysKS :: KS (PublicKey,PrivateKey) +generateKeysKS = generateKeysKS_ default_key_size + +generateKeysKS_ :: Int -> KS (PublicKey,PrivateKey) +generateKeysKS_ ksz = randomKS $ \g->generate g ksz default_e + + +-- +-- Encoding & decoding private & public keys +-- + +decodePrivateKeyDERE :: ClearText -> E PrivateKey +decodePrivateKeyDERE = decodeDERE . _Binary . _ClearText + +decodePublicKeyDERE :: ClearText -> E PublicKey +decodePublicKeyDERE = decodeDERE . _Binary . _ClearText + +encodePrivateKeyDER :: PrivateKey -> ClearText +encodePrivateKeyDER = ClearText . Binary . encodeDER + +encodePublicKeyDER :: PublicKey -> ClearText +encodePublicKeyDER = ClearText . Binary . encodeDER + +decodeDERE :: A.ASN1Object a => B.ByteString -> E a +decodeDERE bs = + case A.decodeASN1 A.DER $ lzy bs of + Left err -> Left $ strMsg $ show err + Right as -> + case A.fromASN1 as of + Left err -> Left $ strMsg $ show err + Right pr -> + case pr of + (pk,[]) -> return pk + _ -> Left $ strMsg "residual data" + where + lzy = LBS.pack . B.unpack + +encodeDER :: A.ASN1Object a => a -> B.ByteString +encodeDER = egr . A.encodeASN1 A.DER . flip A.toASN1 [] + where + egr = B.pack . LBS.unpack + + + +-- +-- Helpers +-- + +rsa2e :: Either Error a -> E a +rsa2e = either (Left . rsaError) Right diff --git a/src/Data/KeyStore/KS/KS.hs b/src/Data/KeyStore/KS/KS.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/KS/KS.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} + +module Data.KeyStore.KS.KS + ( KS + , Ctx(..) + , State(..) + , LogEntry(..) + , withKey + , trun + , e2io + , e2ks + , run_ + , randomBytes + , currentTime + , putStrKS + , btw + , debugLog + , catchKS + , errorKS + , throwKS + , lookupOpt + , getSettings + , lookupKey + , insertNewKey + , insertKey + , adjustKeyKS + , deleteKeysKS + , randomRSA + , randomKS + , getKeymap + , getConfig + , modConfig + ) where + +import Data.KeyStore.KS.CPRNG +import Data.KeyStore.KS.Configuration +import Data.KeyStore.KS.Opt +import Data.KeyStore.Types +import Crypto.PubKey.RSA +import qualified Data.Map as Map +import qualified Data.ByteString as B +import Data.Typeable +import Data.Time +import Control.Applicative +import Control.Monad.RWS.Strict +import qualified Control.Monad.Error as E +import Control.Exception +import Control.Lens + + +newtype KS a = KS { _KS :: E.ErrorT Reason (RWS Ctx [LogEntry] State) a } + deriving (Functor, Applicative, Monad, E.MonadError Reason) + +data Ctx + = Ctx + { ctx_now :: UTCTime + , ctx_store :: FilePath + , ctx_settings :: Settings + } + deriving (Typeable,Show) + +data State + = State + { st_keystore :: KeyStore + , st_cprng :: CPRNG + } + deriving (Typeable) + +data LogEntry + = LogEntry + { le_debug :: Bool + , le_message :: String + } + deriving (Show) + +withKey :: Name -> KS a -> KS a +withKey nm p = + do ctx <- KS ask + st <- KS get + let cfg = _ks_config $ st_keystore st + stgs = _cfg_settings cfg + stgs' <- e2ks $ trigger nm cfg stgs + case run_ ctx {ctx_settings=stgs'} st p of + (e,st',les) -> + do KS $ put st' + KS $ tell les + either throwKS return e + +trun :: KS a -> a +trun p = + case run_ (Ctx u "keystore.json" defaultSettings) s p of + (Left e,_,_) -> error $ show e + (Right x,_,_) -> x + where + s = State + { st_cprng = testCPRNG + , st_keystore = emptyKeyStore $ defaultConfiguration defaultSettings + } + + u = read "2014-01-01 00:00:00" + +e2io :: E a -> IO a +e2io = either throwIO return + +e2ks :: E a -> KS a +e2ks = either throwKS return + +run_ :: Ctx -> State -> KS a -> (E a,State,[LogEntry]) +run_ c s p = runRWS (E.runErrorT (_KS p)) c s + +randomBytes :: Octets -> (B.ByteString->a) -> KS a +randomBytes (Octets sz) k = k <$> randomKS (generateCPRNG sz) + +currentTime :: KS UTCTime +currentTime = ctx_now <$> KS ask + +putStrKS :: String -> KS () +putStrKS msg = KS $ tell [LogEntry False msg] + +btw :: String -> KS () +btw = debugLog + +debugLog :: String -> KS () +debugLog msg = KS $ tell [LogEntry True msg] + +catchKS :: KS a -> (Reason -> KS a) -> KS a +catchKS = E.catchError + +errorKS :: String -> KS a +errorKS = throwKS . strMsg + +throwKS :: Reason -> KS a +throwKS = E.throwError + +lookupOpt :: Show a => Opt a -> KS a +lookupOpt opt = getSettingsOpt opt <$> getSettings + +getSettings :: KS Settings +getSettings = ctx_settings <$> KS ask + +lookupKey :: Name -> KS Key +lookupKey nm = + do mp <- getKeymap + maybe oops return $ Map.lookup nm mp + where + oops = errorKS $ _name nm ++ ": no such keystore key" + +insertNewKey :: Key -> KS () +insertNewKey key = + do mp <- getKeymap + maybe (return ()) (const oops) $ Map.lookup nm mp + insertKey key + where + oops = errorKS $ _name nm ++ ": key already in use" + + nm = _key_name key + +insertKey :: Key -> KS () +insertKey key = mod_keymap $ Map.insert (_key_name key) key + +adjustKeyKS :: Name -> (Key->Key) -> KS () +adjustKeyKS nm adj = mod_keymap $ Map.adjust adj nm + +deleteKeysKS :: [Name] -> KS () +deleteKeysKS nms = + do s <- KS get + let mp = _ks_keymap $ st_keystore s + mp' = foldr Map.delete mp nms + case Map.null $ Map.filter tst mp' of + True -> mod_keymap $ const mp' + False -> errorKS "cannot delete these keys because they are still being used" + where + tst key = or [ any (`elem` safeguardKeys sg) nms | + sg<-Map.keys $ _key_secret_copies key ] + +randomRSA :: (CPRNG->(Either Error a,CPRNG)) -> KS a +randomRSA f = randomKS f >>= either (throwKS . rsaError) return + +randomKS :: (CPRNG->(a,CPRNG)) -> KS a +randomKS f = KS $ + do s <- get + let (x,!g') = f $ st_cprng s + put s { st_cprng = g' } + return x + +getKeymap :: KS KeyMap +getKeymap = _ks_keymap.st_keystore <$> KS get + +getConfig :: KS Configuration +getConfig = _ks_config.st_keystore <$> KS get + +mod_keymap :: (KeyMap->KeyMap) -> KS () +mod_keymap upd = KS get >>= \st -> KS $ put + st + { st_keystore = over ks_keymap upd (st_keystore st) + } + +modConfig :: (Configuration->Configuration) -> KS () +modConfig upd = KS get >>= \st -> KS $ put + st + { st_keystore = over ks_config upd (st_keystore st) + } diff --git a/src/Data/KeyStore/KS/Opt.hs b/src/Data/KeyStore/KS/Opt.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/KS/Opt.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.KeyStore.KS.Opt + ( Opt + , OptEnum(..) + , opt_enum + , getSettingsOpt + , setSettingsOpt + , opt__debug_enabled + , opt__verify_enabled + , opt__backup_keys + , opt__hash_comment + , opt__hash_prf + , opt__hash_iterations + , opt__hash_width_octets + , opt__hash_salt_octets + , opt__crypt_cipher + , opt__crypt_prf + , opt__crypt_iterations + , opt__crypt_salt_octets + , Opt_(..) + , opt_ + , listSettingsOpts + , optHelp + , optName + , parseOpt + ) where + +import Data.KeyStore.Types +import qualified Data.Vector as V +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.HashMap.Strict as HM +import Data.Aeson +import Data.Attoparsec.Number +import qualified Data.Text as T +import Data.Monoid +import Data.Maybe +import Data.Char +import Text.Printf + + +data Opt a + = Opt + { opt_enum :: OptEnum + , opt_default :: a + , opt_from :: Value -> a + , opt_to :: a -> Value + , opt_help :: Help + } + +data Help + = Help + { hlp_text :: [T.Text] + , hlp_type :: T.Text + } + deriving Show + +getSettingsOpt :: Opt a -> Settings -> a +getSettingsOpt Opt{..} (Settings hm) = + maybe opt_default opt_from $ HM.lookup (optName opt_enum) hm + +setSettingsOpt :: Opt a -> a -> Settings -> Settings +setSettingsOpt Opt{..} x (Settings hm) = + Settings $ HM.insert (optName opt_enum) (opt_to x) hm + + +opt__debug_enabled :: Opt Bool +opt__debug_enabled = bool_opt dbg_help False Debug__enabled + +opt__verify_enabled :: Opt Bool +opt__verify_enabled = bool_opt vfy_help False Verify__enabled + +opt__backup_keys :: Opt [Name] +opt__backup_keys = backup_opt bku_help Backup__keys + +opt__hash_comment :: Opt Comment +opt__hash_comment = text_opt hcm_help (Comment ,_Comment) "" Hash__comment + +opt__hash_prf :: Opt HashPRF +opt__hash_prf = enum_opt hpr_help _text_HashPRF PRF_sha512 Hash__prf + +opt__hash_iterations :: Opt Iterations +opt__hash_iterations = intg_opt hit_help (Iterations,_Iterations) 5000 Hash__iterations + +opt__hash_width_octets :: Opt Octets +opt__hash_width_octets = intg_opt hwd_help (Octets ,_Octets ) 64 Hash__width_octets + +opt__hash_salt_octets :: Opt Octets +opt__hash_salt_octets = intg_opt hna_help (Octets ,_Octets ) 16 Hash__salt_octets + +opt__crypt_cipher :: Opt Cipher +opt__crypt_cipher = enum_opt ccy_help _text_Cipher CPH_aes256 Crypt__cipher + +opt__crypt_prf :: Opt HashPRF +opt__crypt_prf = enum_opt cpr_help _text_HashPRF PRF_sha512 Crypt__prf + +opt__crypt_iterations :: Opt Iterations +opt__crypt_iterations = intg_opt cit_help (Iterations,_Iterations) 5000 Crypt__iterations + +opt__crypt_salt_octets :: Opt Octets +opt__crypt_salt_octets = intg_opt cna_help (Octets ,_Octets ) 16 Crypt__salt_octets + + +data OptEnum + = Debug__enabled + | Verify__enabled + | Backup__keys + | Hash__comment + | Hash__prf + | Hash__iterations + | Hash__width_octets + | Hash__salt_octets + | Crypt__cipher + | Crypt__prf + | Crypt__iterations + | Crypt__salt_octets + deriving (Bounded,Enum,Eq,Ord,Show) + +data Opt_ = forall a. Opt_ (Opt a) + +opt_ :: OptEnum -> Opt_ +opt_ enm = + case enm of + Debug__enabled -> Opt_ opt__debug_enabled + Verify__enabled -> Opt_ opt__verify_enabled + Backup__keys -> Opt_ opt__backup_keys + Hash__comment -> Opt_ opt__hash_comment + Hash__prf -> Opt_ opt__hash_prf + Hash__iterations -> Opt_ opt__hash_iterations + Hash__width_octets -> Opt_ opt__hash_width_octets + Hash__salt_octets -> Opt_ opt__hash_salt_octets + Crypt__cipher -> Opt_ opt__crypt_cipher + Crypt__prf -> Opt_ opt__crypt_prf + Crypt__iterations -> Opt_ opt__crypt_iterations + Crypt__salt_octets -> Opt_ opt__crypt_salt_octets + + +listSettingsOpts :: Maybe OptEnum -> T.Text +listSettingsOpts Nothing = T.unlines $ map optName [minBound..maxBound] +listSettingsOpts (Just oe) = optHelp oe + +optHelp :: OptEnum -> T.Text +optHelp = help . opt_ + +help :: Opt_ -> T.Text +help (Opt_ Opt{..}) = T.unlines $ map f + [ (,) pth "" + , (,) " type:" hlp_type + , (,) " default:" dflt + , (,) "" "" + ] <> map (" "<>) hlp_text + where + f (l,v) = T.pack $ printf "%-12s %s" (T.unpack l) (T.unpack v) + + pth = optName opt_enum + + dflt = T.pack $ LBS.unpack $ encode $ opt_to opt_default + + Help{..} = opt_help + +optName :: OptEnum -> T.Text +optName opt = T.pack $ map toLower grp ++ "." ++ drop 2 __nme + where + (grp,__nme) = splitAt (f (-1) ' ' so) so + where + f i _ [] = i+1 + f i '_' ('_':_) = i + f i _ (h:t) = f (i+1) h t + + so = show opt + +parseOpt :: T.Text -> Maybe OptEnum +parseOpt txt = listToMaybe [ oe | oe<-[minBound..maxBound], optName oe==txt ] + +backup_opt :: [T.Text] -> OptEnum -> Opt [Name] +backup_opt hp ce = + Opt + { opt_enum = ce + , opt_default = [] + , opt_from = frm + , opt_to = Array . V.fromList . map (String . T.pack . _name) + , opt_help = Help hp "[]" + } + where + frm val = + case val of + Array v -> catMaybes $ map extr $ V.toList v + _ -> [] + + extr val = + case val of + String t | Right nm <- name $ T.unpack t -> Just nm + _ -> Nothing + +bool_opt :: [T.Text] -> Bool -> OptEnum -> Opt Bool +bool_opt hp x0 ce = + Opt + { opt_enum = ce + , opt_default = x0 + , opt_from = frm + , opt_to = Bool + , opt_help = Help hp "" + } + where + frm v = + case v of + Bool b -> b + _ -> x0 + +intg_opt :: [T.Text] -> (Int->a,a->Int) -> a -> OptEnum -> Opt a +intg_opt hp (inj,prj) x0 ce = + Opt + { opt_enum = ce + , opt_default = x0 + , opt_from = frm + , opt_to = Number . I . toInteger . prj + , opt_help = Help hp "" + } + where + frm v = + case v of + Number (I i) -> inj $ fromInteger i + _ -> x0 + +text_opt :: [T.Text] -> (T.Text->a,a->T.Text) -> a -> OptEnum -> Opt a +text_opt hp (inj,prj) x0 ce = + Opt + { opt_enum = ce + , opt_default = x0 + , opt_from = frm + , opt_to = String . prj + , opt_help = Help hp "" + } + where + frm v = + case v of + String t -> inj t + _ -> x0 + +enum_opt :: (Bounded a,Enum a) => [T.Text] -> (a->T.Text) -> a -> OptEnum -> Opt a +enum_opt hp shw x0 ce = + Opt + { opt_enum = ce + , opt_default = x0 + , opt_from = frm + , opt_to = String . shw + , opt_help = Help hp typ + } + where + frm v = + case v of + String s | Just x <- Map.lookup s mp -> x + _ -> x0 + + mp = Map.fromList [ (shw v,v) | v<-[minBound..maxBound] ] + + typ = T.intercalate "|" $ map shw [minBound..maxBound] + +dbg_help, vfy_help, bku_help, hcm_help, hpr_help, hit_help, hwd_help, + hna_help, ccy_help, cpr_help, cit_help, cna_help :: [T.Text] + +dbg_help = + ["Controls whether debug output is enabled or not." + ] +vfy_help = + [ "Controls whether verification mode is enabled or not," + , "in which the secret text loaded from environment" + , "variables is checked against the stored MACs." + , "These checks can consume a lot of compute time." + ] +bku_help = + [ "Controls the default keys that will be used to make secret copies" + , "(i.e., backup) each key. Each key may individually specify their" + , "backup/save keys which will operate in addition to those specify here." + , "This setting usually set to empty globally accross a keystore but" + , "triggered to backup keys on a per-section basis with the section's" + , "backup key." + ] +hcm_help = + [ "Controls the default comment attribute for hashes." + ] +hpr_help = + [ "Controls the default psuedo-random/hash function used in the PBKDF2" + , "function used to generate the MACs." + ] +hit_help = + [ "Controls the default number of iterations used in the PBKDF2" + , "function used to generate the MACs." + ] +hwd_help = + [ "Controls the default width (in bytes) of the output of the PBKDF2" + , "function used to generate the MACs." + ] +hna_help = + [ "Controls the default width (in bytes) of the salt generated for the PBKDF2" + , "function used to generate the MACs." + ] +ccy_help = + [ "Controls the default cipher used to encrypt the keys." + ] +cpr_help = + [ "Controls the default psuedo-random/hash function used in the PBKDF2." + , "function used to generate the cipher keys." + ] +cit_help = + [ "Controls the default number of iterations used in the PBKDF2" + , "function used to generate cipher keys." + ] +cna_help = + [ "Controls the default width (in bytes) of the salt generated for the PBKDF2" + , "function used to generate cipher keys." + ] diff --git a/src/Data/KeyStore/KS/Packet.hs b/src/Data/KeyStore/KS/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/KS/Packet.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.KeyStore.KS.Packet + ( encocdeEncryptionPacket + , decocdeEncryptionPacketE + , encocdeSignaturePacket + , decocdeSignaturePacketE + -- debugging + , testBP + ) where + +import Data.KeyStore.KS.KS +import Data.KeyStore.Types +import Data.API.Types +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.ByteString.Lazy.Builder +import Data.Word +import Data.Bits +import Data.Char +import Text.Printf +import Control.Applicative +import Control.Monad.RWS.Strict +import qualified Control.Monad.Error as E + + +newtype MagicWord = MagicWord B.ByteString + +encryption_magic_word, signature_magic_word :: MagicWord +encryption_magic_word = MagicWord $ B.pack [0x54,0xab,0xcd,0x00] +signature_magic_word = MagicWord $ B.pack [0x54,0xab,0xcd,0x80] + + +encocdeEncryptionPacket :: Safeguard -> RSASecretBytes -> EncryptionPacket +encocdeEncryptionPacket sg rsb = + EncryptionPacket $ Binary $ + encodePacket encryption_magic_word sg $ _Binary $ _RSASecretBytes rsb + +decocdeEncryptionPacketE :: EncryptionPacket -> E (Safeguard,RSASecretBytes) +decocdeEncryptionPacketE ep = + do (sg,bs) <- decodePacketE encryption_magic_word $ _Binary $ _EncryptionPacket ep + return (sg,RSASecretBytes $ Binary bs) + +encocdeSignaturePacket :: Safeguard -> RSASignature -> SignaturePacket +encocdeSignaturePacket sg rs = + SignaturePacket $ Binary $ + encodePacket signature_magic_word sg $ _Binary $ _RSASignature rs + +decocdeSignaturePacketE :: SignaturePacket -> E (Safeguard,RSASignature) +decocdeSignaturePacketE sp = + do (sg,bs) <- decodePacketE signature_magic_word $ _Binary $ _SignaturePacket sp + return (sg,RSASignature $ Binary bs) + + +encodePacket :: MagicWord -> Safeguard -> B.ByteString -> B.ByteString +encodePacket (MagicWord mw_bs) sg bs = + B.append mw_bs $ + encodeSafeguard sg $ + bs + +decodePacketE :: MagicWord -> B.ByteString -> E (Safeguard,B.ByteString) +decodePacketE (MagicWord mw_bs) bs = run bs $ + do mw_bs' <- splitBP (Octets $ B.length mw_bs) + case mw_bs==mw_bs' of + True -> return () + False -> errorBP $ printf "bad magic word: %s/=%s" (BC.unpack $ to_hex mw_bs') (BC.unpack $ to_hex mw_bs) + sg <- decodeSafeguard + b_bs <- remainingBP + return (sg,b_bs) + +encodeSafeguard :: Safeguard -> ShowB +encodeSafeguard = encodeLengthPacket . BC.pack . printSafeguard + +decodeSafeguard :: BP Safeguard +decodeSafeguard = decodeLengthPacket $ e2bp . parseSafeguard . BC.unpack + +encodeLengthPacket :: B.ByteString -> ShowB +encodeLengthPacket bs t_bs = B.concat [ln_bs,bs,t_bs] + where + ln_bs = LBS.toStrict $ toLazyByteString $ int64LE $ toEnum $ B.length bs + +decodeLengthPacket :: (B.ByteString->BP a) -> BP a +decodeLengthPacket bp = + do ln_bs <- splitBP 8 + let ln = fromIntegral $ foldr (.|.) 0 $ map (f ln_bs) [0..7] + btwBP $ show ln + bs <- splitBP $ Octets ln + bp bs + where + f bs i = rotate w64 $ 8*i + where + w64 :: Word64 + w64 = fromIntegral $ B.index bs i + +type ShowB = B.ByteString -> B.ByteString + +newtype BP a = BP { _BP :: E.ErrorT Reason (RWS () [LogEntry] B.ByteString) a } + deriving (Functor, Applicative, Monad, E.MonadError Reason) + +e2bp :: E a -> BP a +e2bp = either throwBP return + +run :: B.ByteString -> BP a -> E a +run bs bp = + case (B.null bs',e) of + (False,Right _) -> Left $ strMsg "bad packet format (residual bytes)" + _ -> e + where + (e,bs',_) = runBP bs bp + +runBP :: B.ByteString -> BP a -> (E a,B.ByteString,[LogEntry]) +runBP s p = runRWS (E.runErrorT (_BP p)) () s + +testBP :: B.ByteString -> BP a -> IO a +testBP bs p = + do mapM_ lg les + case B.null rbs of + True -> return () + False -> putStrLn $ show(B.length rbs) ++ " bytes remaining" + case e of + Left dg -> error $ show dg + Right r -> return r + where + (e,rbs,les) = runBP bs p + + lg LogEntry{..} = putStrLn $ "log: " ++ le_message + +btwBP :: String -> BP () +btwBP msg = BP $ tell [LogEntry True msg] + +errorBP :: String -> BP a +errorBP = throwBP . strMsg . ("packet decode error: " ++) + +throwBP :: Reason -> BP a +throwBP = E.throwError + +splitBP :: Octets -> BP B.ByteString +splitBP (Octets n) = + do bs <- peek_remainingBP + let (bs_h,bs_r) = B.splitAt n bs + case n<=B.length bs of + True -> modifyBP (const bs_r) >> return bs_h + False -> errorBP "not enough bytes" + +remainingBP :: BP B.ByteString +remainingBP = + do bs <- peek_remainingBP + modifyBP $ const B.empty + return bs + +peek_remainingBP :: BP B.ByteString +peek_remainingBP = BP get + +modifyBP :: (B.ByteString->B.ByteString) -> BP () +modifyBP upd = BP $ modify upd + +-- hexify a ByteString + +to_hex :: B.ByteString -> B.ByteString +to_hex = BC.pack . foldr f "" . BC.unpack + where + f c t = intToDigit (n `div` 16) : intToDigit (n `mod` 16) : t + where + n = ord c diff --git a/src/Data/KeyStore/KeyStore.hs b/src/Data/KeyStore/KeyStore.hs deleted file mode 100644 --- a/src/Data/KeyStore/KeyStore.hs +++ /dev/null @@ -1,461 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE BangPatterns #-} - -module Data.KeyStore.KeyStore - ( keyStoreBytes - , keyStoreFromBytes - , settingsFromBytes - , createRSAKeyPair - , encryptWithRSAKey - , encryptWithRSAKey_ - , decryptWithRSAKey - , decryptWithRSAKey_ - , signWithRSAKey - , verifyWithRSAKey - , encryptWithKeys - , decryptWithKeys - , createKey - , backupKeys - , rememberKey - , secureKey - , getKeys - , list - , info - , loadKey - , loadEncryptionKey - ) where - -import Data.KeyStore.Opt -import Data.KeyStore.Packet -import Data.KeyStore.Crypto -import Data.KeyStore.KS -import Data.KeyStore.Types -import Data.API.JSON -import Data.Aeson -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map -import qualified Data.Text as T -import Data.Maybe -import Data.List -import Data.Time -import Text.Printf -import Control.Applicative -import Control.Lens -import Control.Monad - - -------------------------------------------------------------------------------- --- | Encode a key store as a JSON ByteString (discarding any cached cleartext --- copies of secrets it may have) -keyStoreBytes :: KeyStore -> LBS.ByteString -keyStoreBytes = encode . cln - where - cln ks = - ks { _ks_keymap = cleanKeyMap $ _ks_keymap ks - } - - -------------------------------------------------------------------------------- --- Parse a key store from a JSON ByteString. -keyStoreFromBytes :: LBS.ByteString -> E KeyStore -keyStoreFromBytes = chk . either (const Nothing) Just . decodeWithErrs - where - chk Nothing = Left $ strMsg "failed to decode keystore file" - chk (Just ks) = Right ks - - -------------------------------------------------------------------------------- --- Parse key store settings from a JSON ByteString. -settingsFromBytes :: LBS.ByteString -> E Settings -settingsFromBytes = chk . either (const Nothing) Just . decodeWithErrs - where - chk (Just(Object fm)) = Right $ Settings fm - chk _ = Left $ strMsg "failed to decode JSON settings" - - -------------------------------------------------------------------------------- --- Create a random RSA key pair under a name in the key store, --- safeguarding it zero, one or more times. -createRSAKeyPair :: Name -> Comment -> Identity -> [Safeguard] -> KS () -createRSAKeyPair nm cmt ide nmz = - do _ <- createKey nm cmt ide Nothing Nothing - (puk,prk) <- generateKeys - adjustKeyKS nm (add_puk puk) - rememberKey nm $ encodePrivateKeyDER prk - mapM_ (secureKey nm) nmz - where - add_puk puk key = key { _key_public = Just puk } - - -------------------------------------------------------------------------------- --- | Encrypt a clear text message with a name RSA key pair. -encryptWithRSAKey :: Name -> ClearText -> KS EncryptionPacket -encryptWithRSAKey nm ct = - encocdeEncryptionPacket (safeguard [nm]) . - encodeRSASecretData <$> encryptWithRSAKey_ nm ct - -encryptWithRSAKey_ :: Name -> ClearText -> KS RSASecretData -encryptWithRSAKey_ nm ct = - do scd <- _ec_secret_data <$> encryptWithKeys (safeguard [nm]) ct - case scd of - ECD_rsa rsd -> return rsd - _ -> errorKS "RSA key expected" - - -------------------------------------------------------------------------------- --- | Decrypt an RSA-encrypted message (the RSA secret key named in the message --- must be available.) -decryptWithRSAKey :: EncryptionPacket -> KS ClearText -decryptWithRSAKey ep = - do (sg,rsb) <- e2ks $ decocdeEncryptionPacket ep - nm <- case safeguardKeys sg of - [nm] -> return nm - _ -> errorKS "expected a single (RSA) key in the safeguard" - rsd <- decodeRSASecretData rsb - decryptWithRSAKey_ nm rsd - -decryptWithRSAKey_ :: Name -> RSASecretData -> KS ClearText -decryptWithRSAKey_ nm rsd = - do key <- loadKey nm - case _key_clear_private key of - Nothing -> errorKS "could not load private key" - Just prk -> decrypt prk rsd - - -------------------------------------------------------------------------------- --- | Sign a message with a named RSA secret key (which must be available). -signWithRSAKey :: Name -> ClearText -> KS SignaturePacket -signWithRSAKey nm ct = - do key <- loadKey nm - case _key_clear_private key of - Nothing -> errorKS "could not load private key" - Just prk -> encocdeSignaturePacket (safeguard [nm]) <$> sign prk ct - - -------------------------------------------------------------------------------- --- | Verify that an RSA signature of a message is correct. -verifyWithRSAKey :: ClearText -> SignaturePacket -> KS Bool -verifyWithRSAKey ct sp = - do (sg,rs) <- e2ks $ decocdeSignaturePacket sp - nm <- case safeguardKeys sg of - [nm] -> return nm - _ -> errorKS "expected a single (RSA) key in the safeguard" - key <- lookupKey nm - case _key_public key of - Nothing -> errorKS "not an RSA key pair" - Just puk -> return $ verify puk ct rs - - -------------------------------------------------------------------------------- --- | Symetrically encrypt a message with a Safeguard (list of names private --- keys). -encryptWithKeys :: Safeguard -> ClearText -> KS EncrypedCopy -encryptWithKeys nms ct = - do ec <- defaultEncryptedCopy nms - mb <- loadEncryptionKey Encrypting ec - ek <- case mb of - Nothing -> errorKS "could not load keys" - Just ek -> return ek - ecd <- save ek ct - return ec { _ec_secret_data = ecd } - - -------------------------------------------------------------------------------- --- | Symetrically encrypt a message with a Safeguard (list of names private --- keys). -decryptWithKeys :: EncrypedCopy -> KS ClearText -decryptWithKeys ec = - do mb <- loadEncryptionKey Decrypting ec - ek <- case mb of - Nothing -> errorKS "could not load keys" - Just ek -> return ek - restore (_ec_secret_data ec) ek - - -------------------------------------------------------------------------------- --- | Create a private key. -createKey :: Name -- ^ (unique) name of the new key - -> Comment -- ^ the comment string - -> Identity -- ^ the identity string - -> Maybe EnvVar -- ^ the environment variable used to hold a clear text copy - -> Maybe ClearText -- ^ (optionally) the clear test copy - -> KS () -createKey nm cmt ide mb_ev mb_ct = withKey nm $ - do now <- currentTime - insertNewKey - Key - { _key_name = nm - , _key_comment = cmt - , _key_identity = ide - , _key_is_binary = False - , _key_env_var = mb_ev - , _key_hash = Nothing - , _key_public = Nothing - , _key_secret_copies = Map.empty - , _key_clear_text = Nothing - , _key_clear_private = Nothing - , _key_created_at = now - } - maybe (return ()) (rememberKey nm) mb_ct - - -------------------------------------------------------------------------------- --- | Remember the secret text for a key -- will record the hash and encrypt --- it with the configured safeguards, generating an error if any of the --- safeguards are not available. -rememberKey :: Name -> ClearText -> KS () -rememberKey nm ct = - do key0 <- lookupKey nm - let key1 = key0 { _key_clear_text = Just ct } - vfy <- lookupOpt opt__verify_enabled - key2 <- case vfy of - True -> verify_key key1 ct - False -> return key1 - key <- - case _key_hash key2 of - Nothing | isNothing $ _key_public key2 -> upd key2 <$> hash ct - _ -> return key2 - insertKey key - backupKey nm - where - upd key hsh = - key { _key_hash = Just hsh - } - - -------------------------------------------------------------------------------- --- | Backup all of the keys in the store with their configured backup keys. -backupKeys :: KS () -backupKeys = getKeys >>= mapM_ (backupKey . _key_name) - - -------------------------------------------------------------------------------- --- | Backup a named key with its configured backup key. -backupKey :: Name -> KS () -backupKey nm = withKey nm $ - do nms <- lookupOpt opt__backup_keys - mapM_ backup nms - where - backup nm' = secure_key nm $ safeguard [nm'] - - -------------------------------------------------------------------------------- --- | Primitive to make a cryptographic copy (i.e., a safeguard) of the --- secret text of a key, storing it in the key (and doing nothing if the --- that safeguard is already present). -secureKey :: Name -> Safeguard -> KS () -secureKey nm sg = withKey nm $ secure_key nm sg - -secure_key :: Name -> Safeguard -> KS () -secure_key nm sg = - do key <- loadKey nm - when (isNothing $ Map.lookup sg $ _key_secret_copies key) $ - do ct <- case _key_clear_text key of - Nothing -> errorKS $ _name nm ++ ": cannot load key" - Just ct -> return ct - ec0 <- defaultEncryptedCopy sg - mbk <- loadEncryptionKey Encrypting ec0 - ek <- case mbk of - Nothing -> errorKS $ - printSafeguard sg ++ ": cannot load encryption keys" - Just ek -> return ek - ecd <- save ek ct - let ec = ec0 { _ec_secret_data = ecd } - insertKey $ over key_secret_copies (Map.insert sg ec) key - - -------------------------------------------------------------------------------- --- | List all of the keys in the store, one per line, on the output. -list :: KS () -list = - do nms <- map _key_name <$> getKeys - keys <- mapM loadKey $ sort nms - putStrKS $ concat $ map (list_key False) keys - --- | Print out the information of a particular key. -info :: Name -> KS () -info nm = - do key <- loadKey nm - putStrKS $ list_key True key - -data Line - = LnHeader String - | LnDate UTCTime - | LnHash String - | LnCopiesHeader - | LnCopy String - deriving Show - -list_key :: Bool -> Key -> String -list_key True key@Key{..} = - unlines $ map fmt $ - [ LnHeader hdr ] ++ - [ LnDate _key_created_at ] ++ - [ LnHash hsh | Just hsh<-[mb_hsh] ] ++ - [ LnCopiesHeader ] ++ - [ LnCopy $ fmt_ec ec | ec<-Map.elems $ _key_secret_copies ] - where - fmt ln = - case ln of - LnHeader s -> s - LnDate u -> fmt_ln 2 "Date:" $ show u - LnHash s -> fmt_ln 2 "Hash:" s - LnCopiesHeader -> fmt_ln 2 "Copies:" "" - LnCopy s -> fmt_ln_ 4 s - - hdr = printf "%s: %s%s -- %s" nm sts ev cmt - where - nm = _name _key_name - sts = status key - ev = maybe "" (printf " ($%s)" . T.unpack . _EnvVar) _key_env_var - cmt = T.unpack $ _Comment _key_comment - mb_hsh = fmt_hsh <$> _key_hash - - fmt_ec EncrypedCopy{..} = printf "%s(%d*%s[%s])" ci is pf sg - where - ci = show _ec_cipher - Iterations is = _ec_iterations - pf = show _ec_prf - sg = printSafeguard _ec_safeguard - - fmt_hsh Hash{_hash_description=HashDescription{..}} = printf "%d*%s(%d):%d" is pf sw wd - where - Iterations is = _hashd_iterations - pf = show _hashd_prf - Octets sw = _hashd_salt_octets - Octets wd = _hashd_width_octets - - fmt_ln i s s' = fmt_ln_ i $ printf "%-8s %s" s s' - fmt_ln_ i s = replicate i ' ' ++ s -list_key False key@Key{..} = printf "%-40s : %s%s (%s)\n" nm sts ev ecs - where - nm = _name _key_name - sts = status key - ev = maybe "" (printf " ($%s)" . T.unpack . _EnvVar) _key_env_var - ecs = intercalate "," $ map (printSafeguard . _ec_safeguard) $ - Map.elems _key_secret_copies - -status :: Key -> String -status Key{..} = [sts_t,sts_p] - where - sts_t = maybe '-' (const 'T') _key_clear_text - sts_p = maybe '-' (const 'P') _key_public - - -------------------------------------------------------------------------------- --- | Return all of the keys in the keystore. -getKeys :: KS [Key] -getKeys = Map.elems <$> getKeymap - - -------------------------------------------------------------------------------- --- | Try to load the secret copy into the key and return it. (No error is --- raised if it failed to recover the secret.) -loadKey :: Name -> KS Key -loadKey = loadKey' [] - -loadKey' :: [Name] -> Name -> KS Key -loadKey' nm_s nm = - do key <- lookupKey nm - maybe (loadKey'' nm_s nm) (const $ return key) $ _key_clear_text key - -loadKey'' :: [Name] -> Name -> KS Key -loadKey'' nm_s nm = - do key0 <- lookupKey nm - let ld [] = return key0 - ld (sc:scs) = - do key <- loadKey''' nm_s nm key0 sc - case _key_clear_text key of - Nothing -> ld scs - Just _ -> return key - ld $ Map.elems $ _key_secret_copies key0 - -loadKey''' :: [Name] - -> Name - -> Key - -> EncrypedCopy - -> KS Key -loadKey''' nm_s nm key@Key{..} ec = - case nm `elem` nm_s of - True -> return key - False -> - do mbk <- loadEncryptionKey_ Decrypting (nm:nm_s) ec - case mbk of - Nothing -> return key - Just ek -> - do ct <- restore (_ec_secret_data ec) ek - rememberKey nm ct - lookupKey nm - - -------------------------------------------------------------------------------- --- | Try to load an encryption or decryption key for an encrypted message. -loadEncryptionKey :: Dirctn -> EncrypedCopy -> KS (Maybe EncryptionKey) -loadEncryptionKey dir sc = loadEncryptionKey_ dir [] sc - -loadEncryptionKey_ :: Dirctn -> [Name] -> EncrypedCopy -> KS (Maybe EncryptionKey) -loadEncryptionKey_ dir nms_s sc = - case nms of - [] -> return $ Just $ EK_none void_ - [nm] -> - do key <- lookupKey nm - maybe sym (asm dir nm) $ _key_public key - _ -> sym - where - sym = - do keys <- mapM (loadKey' nms_s) nms - case all (isJust._key_clear_text) keys of - True -> Just . EK_symmetric <$> - (mkAESKey sc $ catMaybes $ map _key_clear_text keys) - False -> return Nothing - - asm Encrypting _ puk = return $ Just $ EK_public puk - asm Decrypting nm _ = - do key <- loadKey' nms_s nm - case _key_clear_private key of - Nothing -> return Nothing - Just prk -> return $ Just $ EK_private prk - - nms = safeguardKeys $ _ec_safeguard sc - - -------------------------------------------------------------------------------- -verify_key :: Key -> ClearText -> KS Key -verify_key key@Key{..} ct = - case (_key_hash,_key_public) of - (Just hsh,_ ) -> - case verify_key_ hsh ct of - True -> return key { _key_clear_text = Just ct } - False -> errorKS "key failed to match hash" - (Nothing ,Just puk) -> - do prk <- e2ks $ verify_private_key_ puk ct - return - key { _key_clear_text = Just ct - , _key_clear_private = Just prk - } - _ -> return - key { _key_clear_text = Just ct - } - -verify_key_ :: Hash -> ClearText -> Bool -verify_key_ hsh ct = - _hash_hash(hash_ (_hash_description hsh) ct) == _hash_hash hsh - -verify_private_key_ :: PublicKey -> ClearText -> E PrivateKey -verify_private_key_ puk ct = - do prk <- decodePrivateKeyDER ct - case puk==private_pub prk of - True -> return prk - False -> Left $ strMsg "private key mismatches public key" - - -------------------------------------------------------------------------------- -cleanKeyMap :: KeyMap -> KeyMap -cleanKeyMap mp = Map.map cln mp - where - cln key = - key { _key_clear_text = Nothing - , _key_clear_private = Nothing - } diff --git a/src/Data/KeyStore/Opt.hs b/src/Data/KeyStore/Opt.hs deleted file mode 100644 --- a/src/Data/KeyStore/Opt.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.KeyStore.Opt - ( Opt - , getSettingsOpt - , setSettingsOpt - , opt__debug_enabled - , opt__verify_enabled - , opt__backup_keys - , opt__hash_comment - , opt__hash_prf - , opt__hash_iterations - , opt__hash_width_octets - , opt__hash_salt_octets - , opt__crypt_cipher - , opt__crypt_prf - , opt__crypt_iterations - , opt__crypt_salt_octets - , Opt_(..) - , opt_ - ) where - -import Data.KeyStore.Types -import Data.Aeson -import qualified Data.Vector as V -import qualified Data.Map as Map -import qualified Data.HashMap.Strict as HM -import Data.Attoparsec.Number -import qualified Data.Text as T -import Data.Maybe -import Data.Char - - -data Opt a - = Opt - { opt_enum :: OptEnum - , opt_default :: a - , opt_from :: Value -> a - , opt_to :: a -> Value - } - - -getSettingsOpt :: Opt a -> Settings -> a -getSettingsOpt Opt{..} (Settings hm) = - maybe opt_default opt_from $ HM.lookup (opt_name opt_enum) hm - -setSettingsOpt :: Opt a -> a -> Settings -> Settings -setSettingsOpt Opt{..} x (Settings hm) = - Settings $ HM.insert (opt_name opt_enum) (opt_to x) hm - - -opt__debug_enabled :: Opt Bool -opt__debug_enabled = bool_opt False Debug__enabled - -opt__verify_enabled :: Opt Bool -opt__verify_enabled = bool_opt False Verify__enabled - -opt__backup_keys :: Opt [Name] -opt__backup_keys = backup_opt Backup__keys - -opt__hash_comment :: Opt Comment -opt__hash_comment = text_opt (Comment ,_Comment) "" Hash__comment - -opt__hash_prf :: Opt HashPRF -opt__hash_prf = enum_opt _text_HashPRF PRF_sha512 Hash__prf - -opt__hash_iterations :: Opt Iterations -opt__hash_iterations = intg_opt (Iterations,_Iterations) 5000 Hash__iterations - -opt__hash_width_octets :: Opt Octets -opt__hash_width_octets = intg_opt (Octets ,_Octets ) 64 Hash__width_octets - -opt__hash_salt_octets :: Opt Octets -opt__hash_salt_octets = intg_opt (Octets ,_Octets ) 16 Hash__salt_octets - -opt__crypt_cipher :: Opt Cipher -opt__crypt_cipher = enum_opt _text_Cipher CPH_aes256 Crypt__cipher - -opt__crypt_prf :: Opt HashPRF -opt__crypt_prf = enum_opt _text_HashPRF PRF_sha512 Crypt__prf - -opt__crypt_iterations :: Opt Iterations -opt__crypt_iterations = intg_opt (Iterations,_Iterations) 5000 Crypt__iterations - -opt__crypt_salt_octets :: Opt Octets -opt__crypt_salt_octets = intg_opt (Octets ,_Octets ) 16 Crypt__salt_octets - - -data OptEnum - = Debug__enabled - | Verify__enabled - | Backup__keys - | Hash__comment - | Hash__prf - | Hash__iterations - | Hash__width_octets - | Hash__salt_octets - | Crypt__cipher - | Crypt__prf - | Crypt__iterations - | Crypt__salt_octets - deriving (Bounded,Enum,Eq,Ord,Show) - -data Opt_ = forall a. Opt_ (Opt a) - -opt_ :: OptEnum -> Opt_ -opt_ enm = - case enm of - Debug__enabled -> Opt_ $ opt__debug_enabled - Verify__enabled -> Opt_ $ opt__verify_enabled - Backup__keys -> Opt_ $ opt__backup_keys - Hash__comment -> Opt_ $ opt__hash_comment - Hash__prf -> Opt_ $ opt__hash_prf - Hash__iterations -> Opt_ $ opt__hash_iterations - Hash__width_octets -> Opt_ $ opt__hash_width_octets - Hash__salt_octets -> Opt_ $ opt__hash_salt_octets - Crypt__cipher -> Opt_ $ opt__crypt_cipher - Crypt__prf -> Opt_ $ opt__crypt_prf - Crypt__iterations -> Opt_ $ opt__crypt_iterations - Crypt__salt_octets -> Opt_ $ opt__crypt_salt_octets - - -opt_name :: OptEnum -> T.Text -opt_name opt = T.pack $ map toLower grp ++ "." ++ drop 2 __nme - where - (grp,__nme) = splitAt (f (-1) ' ' so) so - where - f i _ [] = i+1 - f i '_' ('_':_) = i - f i _ (h:t) = f (i+1) h t - - so = show opt - -backup_opt :: OptEnum -> Opt [Name] -backup_opt ce = - Opt - { opt_enum = ce - , opt_default = [] - , opt_from = frm - , opt_to = Array . V.fromList . map (String . T.pack . _name) - } - where - frm val = - case val of - Array v -> catMaybes $ map extr $ V.toList v - _ -> [] - - extr val = - case val of - String t | Right nm <- name $ T.unpack t -> Just nm - _ -> Nothing - -bool_opt :: Bool -> OptEnum -> Opt Bool -bool_opt x0 ce = - Opt - { opt_enum = ce - , opt_default = x0 - , opt_from = frm - , opt_to = Bool - } - where - frm v = - case v of - Bool b -> b - _ -> x0 - -intg_opt :: (Int->a,a->Int) -> a -> OptEnum -> Opt a -intg_opt (inj,prj) x0 ce = - Opt - { opt_enum = ce - , opt_default = x0 - , opt_from = frm - , opt_to = Number . I . toInteger . prj - } - where - frm v = - case v of - Number (I i) -> inj $ fromInteger i - _ -> x0 - -text_opt :: (T.Text->a,a->T.Text) -> a -> OptEnum -> Opt a -text_opt (inj,prj) x0 ce = - Opt - { opt_enum = ce - , opt_default = x0 - , opt_from = frm - , opt_to = String . prj - } - where - frm v = - case v of - String t -> inj t - _ -> x0 - -enum_opt :: (Bounded a,Enum a) => (a->T.Text) -> a -> OptEnum -> Opt a -enum_opt shw x0 ce = - Opt - { opt_enum = ce - , opt_default = x0 - , opt_from = frm - , opt_to = String . shw - } - where - frm v = - case v of - String s | Just x <- Map.lookup s mp -> x - _ -> x0 - - mp = Map.fromList [ (shw v,v) | v<-[minBound..maxBound] ] diff --git a/src/Data/KeyStore/Packet.hs b/src/Data/KeyStore/Packet.hs deleted file mode 100644 --- a/src/Data/KeyStore/Packet.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Data.KeyStore.Packet - ( encocdeEncryptionPacket - , decocdeEncryptionPacket - , encocdeSignaturePacket - , decocdeSignaturePacket - -- debugging - , testBP - ) where - -import Data.KeyStore.KS -import Data.KeyStore.Types -import Data.API.Types -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.ByteString.Lazy.Builder -import Data.Word -import Data.Bits -import Control.Applicative -import Control.Monad.RWS.Strict -import qualified Control.Monad.Error as E - - -newtype MagicWord = MagicWord B.ByteString - -encryption_magic_word, signature_magic_word :: MagicWord -encryption_magic_word = MagicWord $ B.pack [0x54,0xab,0xcd,0x00] -signature_magic_word = MagicWord $ B.pack [0x54,0xab,0xcd,0x80] - - -encocdeEncryptionPacket :: Safeguard -> RSASecretBytes -> EncryptionPacket -encocdeEncryptionPacket sg rsb = - EncryptionPacket $ Binary $ - encodePacket encryption_magic_word sg $ _Binary $ _RSASecretBytes rsb - -decocdeEncryptionPacket :: EncryptionPacket -> E (Safeguard,RSASecretBytes) -decocdeEncryptionPacket ep = - do (sg,bs) <- decodePacket encryption_magic_word $ _Binary $ _EncryptionPacket ep - return (sg,RSASecretBytes $ Binary bs) - -encocdeSignaturePacket :: Safeguard -> RSASignature -> SignaturePacket -encocdeSignaturePacket sg rs = - SignaturePacket $ Binary $ - encodePacket signature_magic_word sg $ _Binary $ _RSASignature rs - -decocdeSignaturePacket :: SignaturePacket -> E (Safeguard,RSASignature) -decocdeSignaturePacket sp = - do (sg,bs) <- decodePacket signature_magic_word $ _Binary $ _SignaturePacket sp - return (sg,RSASignature $ Binary bs) - - -encodePacket :: MagicWord -> Safeguard -> B.ByteString -> B.ByteString -encodePacket (MagicWord mw_bs) sg bs = - B.append mw_bs $ - encodeSafeguard sg $ - bs - -decodePacket :: MagicWord -> B.ByteString -> E (Safeguard,B.ByteString) -decodePacket (MagicWord mw_bs) bs = run bs $ - do mw_bs' <- splitBP (Octets $ B.length mw_bs) - case mw_bs==mw_bs' of - True -> return () - False -> errorBP "bad magic word" - sg <- decodeSafeguard - b_bs <- remainingBP - return (sg,b_bs) - -encodeSafeguard :: Safeguard -> ShowB -encodeSafeguard = encodeLengthPacket . BC.pack . printSafeguard - -decodeSafeguard :: BP Safeguard -decodeSafeguard = decodeLengthPacket $ e2bp . parseSafeguard . BC.unpack - -encodeLengthPacket :: B.ByteString -> ShowB -encodeLengthPacket bs t_bs = B.concat [ln_bs,bs,t_bs] - where - ln_bs = LBS.toStrict $ toLazyByteString $ int64LE $ toEnum $ B.length bs - -decodeLengthPacket :: (B.ByteString->BP a) -> BP a -decodeLengthPacket bp = - do ln_bs <- splitBP 8 - let ln = fromIntegral $ foldr (.|.) 0 $ map (f ln_bs) [0..7] - btwBP $ show ln - bs <- splitBP $ Octets ln - bp bs - where - f bs i = rotate w64 $ 8*i - where - w64 :: Word64 - w64 = fromIntegral $ B.index bs i - -type ShowB = B.ByteString -> B.ByteString - -newtype BP a = BP { _BP :: E.ErrorT Reason (RWS () [LogEntry] B.ByteString) a } - deriving (Functor, Applicative, Monad, E.MonadError Reason) - -e2bp :: E a -> BP a -e2bp = either throwBP return - -run :: B.ByteString -> BP a -> E a -run bs bp = - case (B.null bs',e) of - (False,Right _) -> Left $ strMsg "bad packet format (residual bytes)" - _ -> e - where - (e,bs',_) = runBP bs bp - -runBP :: B.ByteString -> BP a -> (E a,B.ByteString,[LogEntry]) -runBP s p = runRWS (E.runErrorT (_BP p)) () s - -testBP :: B.ByteString -> BP a -> IO a -testBP bs p = - do mapM_ lg les - case B.null rbs of - True -> return () - False -> putStrLn $ show(B.length rbs) ++ " bytes remaining" - case e of - Left dg -> error $ show dg - Right r -> return r - where - (e,rbs,les) = runBP bs p - - lg LogEntry{..} = putStrLn $ "log: " ++ le_message - -btwBP :: String -> BP () -btwBP msg = BP $ tell [LogEntry True msg] - -errorBP :: String -> BP a -errorBP = throwBP . strMsg . ("packet decode error: " ++) - -throwBP :: Reason -> BP a -throwBP = E.throwError - -splitBP :: Octets -> BP B.ByteString -splitBP (Octets n) = - do bs <- peek_remainingBP - let (bs_h,bs_r) = B.splitAt n bs - case n<=B.length bs of - True -> modifyBP (const bs_r) >> return bs_h - False -> errorBP "not enough bytes" - -remainingBP :: BP B.ByteString -remainingBP = - do bs <- peek_remainingBP - modifyBP $ const B.empty - return bs - -peek_remainingBP :: BP B.ByteString -peek_remainingBP = BP get - -modifyBP :: (B.ByteString->B.ByteString) -> BP () -modifyBP upd = BP $ modify upd diff --git a/src/Data/KeyStore/Sections.hs b/src/Data/KeyStore/Sections.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Sections.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.KeyStore.Sections + ( SECTIONS(..) + , Code(..) + , Sections(..) + , SectionType(..) + , KeyData(..) + , KeyPredicate + , RetrieveDg(..) + , initialise + , rotate + , retrieve + , signKeystore + , verifyKeystore + , noKeys + , allKeys + , keyPrededicate + , keyHelp + , sectionHelp + , secretKeySummary + , publicKeySummary + , locateKeys + , keyName + , passwordName + ) + where + +import Data.KeyStore.IO +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as HM +import qualified Data.Vector as V +import Data.Maybe +import Data.List +import Data.Ord +import Data.Monoid +import Control.Applicative +import Text.Printf +import System.FilePath +import Safe + + +data SECTIONS h s k = SECTIONS + + +class (Bounded a,Enum a,Eq a, Ord a,Show a) => Code a where + encode :: a -> String + + decode :: String -> Maybe a + decode s = listToMaybe [ k | k<-[minBound..maxBound], encode k==s ] + + +class (Code h, Code s, Code k) => Sections h s k + | s -> h, k -> h + , h -> s, k -> s + , s -> k, h -> k + where + hostSection :: h -> s -- ^ the deployment section + hostRSection :: h -> s -- ^ section where host-indexed + -- keys reside for given host + sectionType :: s -> SectionType + superSections :: s -> [s] + keyIsHostIndexed :: k -> Maybe (h->Bool) + keyIsInSection :: k -> s -> Bool + getKeyData :: Maybe h -> s -> k -> IO KeyData + sectionSettings :: Maybe s -> IO Settings + describeKey :: k -> String + describeSection :: s -> String + sectionPWEnvVar :: s -> EnvVar + + hostRSection = hostSection + + sectionType = const ST_keys + + keyIsHostIndexed = const Nothing + + keyIsInSection = const $ const True + + getKeyData Nothing s = get_kd $ encode s + getKeyData (Just h) _ = get_kd $ encode h + + sectionSettings = const $ return mempty + + describeKey k = "The '" ++ encode k ++ "' key." + + describeSection s = "The '" ++ encode s ++ "' Section." + + sectionPWEnvVar = EnvVar . T.pack . ("KEY_" ++) . _name . passwordName + + +data SectionType + = ST_top + | ST_signing + | ST_keys + deriving (Show,Eq,Ord) + + +data KeyData = + KeyData + { kd_identity :: Identity + , kd_comment :: Comment + , kd_secret :: B.ByteString + } + + +type KeyPredicate h s k = Maybe h -> s -> k -> Bool + + +data RetrieveDg + = RDG_key_not_reachable + | RDG_no_such_host_key + deriving (Show,Eq,Ord) + + +initialise :: Sections h s k => CtxParams -> KeyPredicate h s k -> IO () +initialise cp kp = do + stgs <- scs kp Nothing + newKeyStore (the_keystore cp) stgs + ic <- instanceCtx cp + mapM_ (mks kp ic) [minBound..maxBound] + rotate ic kp + map _key_name <$> keys ic >>= mapM_ (keyInfo ic) + where + scs :: Sections h s k => KeyPredicate h s k -> Maybe s -> IO Settings + scs = const sectionSettings + + mks :: Sections h s k => KeyPredicate h s k -> IC -> s -> IO () + mks = const mk_section + +rotate :: Sections h s k => IC -> KeyPredicate h s k -> IO () +rotate ic kp = sequence_ [ rotate' ic mb_h s k | (mb_h,s,k)<-host_keys++non_host_keys, kp mb_h s k ] + where + host_keys = [ (Just h ,s,k) | k<-[minBound..maxBound], Just hp<-[keyIsHostIndexed k], h<-[minBound..maxBound], hp h, let s=hostRSection h ] + non_host_keys = [ (Nothing,s,k) | k<-[minBound..maxBound], Nothing<-[keyIsHostIndexed k], s<-[minBound..maxBound], keyIsInSection k s ] + +retrieve :: Sections h s k => IC -> h -> k -> IO (Either RetrieveDg [Key]) +retrieve ic h k = either (return . Left) (\nm->Right <$> locateKeys ic nm) ei_nm + where + ei_nm = case keyIsHostIndexed k of + Nothing -> maybe (Left RDG_key_not_reachable) Right $ + listToMaybe + [ key_nme Nothing s_ k | s_ <- lower_sections s, keyIsInSection k s_ ] + Just hp | hp h -> Right $ key_nme (Just h) s k + | otherwise -> Left RDG_no_such_host_key + + s = hostSection h + +signKeystore :: Sections h s k => IC -> SECTIONS h s k -> IO B.ByteString +signKeystore ic scn = B.readFile (the_keystore $ ic_ctx_params ic) >>= sign_ ic (sgn_nme $ signing_key scn) + +verifyKeystore :: IC -> B.ByteString -> IO Bool +verifyKeystore ic sig = B.readFile (the_keystore $ ic_ctx_params ic) >>= flip (verify_ ic) sig + +noKeys :: KeyPredicate h s k +noKeys _ _ _ = False + +allKeys :: KeyPredicate h s k +allKeys _ _ _ = True + +keyPrededicate :: Sections h s k => Maybe h -> Maybe s -> Maybe k -> KeyPredicate h s k +keyPrededicate mbh mbs mbk mbh_ s k = h_ok && s_ok && k_ok + where + h_ok = maybe True (\h->maybe False (h==) mbh_) mbh + s_ok = maybe True (s==) mbs + k_ok = maybe True (k==) mbk + +keyHelp :: Sections h s k => Maybe k -> T.Text +keyHelp x@Nothing = T.unlines $ map (T.pack . encode) [minBound..maxBound `asTypeOf` fromJust x ] +keyHelp (Just k) = T.unlines $ map T.pack $ (map f $ concat + [ [ (,) (encode k) "" ] + , [ (,) " hosts:" hln | Just hln <- [mb_hln] ] + , [ (,) " sections:" sln | Nothing <- [mb_hln] ] + ]) ++ "" : map (" "++) (lines $ describeKey k) ++ [""] + where + mb_hln = fmt <$> keyIsHostIndexed k + sln = fmt $ keyIsInSection k + + f = uncurry $ printf "%-10s %s" + +sectionHelp :: Sections h s k => Maybe s -> IO T.Text +sectionHelp x@Nothing = return $ T.unlines $ map (T.pack . encode) [minBound..maxBound `asTypeOf` fromJust x ] +sectionHelp (Just s) = do + stgs <- sectionSettings $ Just s + return $ T.unlines $ map T.pack $ (map f $ concat + [ [ (,) (encode s) typ ] + , [ (,) " p/w env var:" env ] + , [ (,) " hosts:" hln ] + , [ (,) " super sections:" sln ] + , [ (,) " under sections:" uln ] + , [ (,) " keys:" kln ] + , [ (,) " settings" "" ] + ]) ++ fmt_s stgs ++ "" : map (" "++) (lines $ describeSection s) ++ [""] + where + typ = case sectionType s of + ST_top -> "(top)" + ST_signing -> "(signing)" + ST_keys -> "(keys)" + env = "$" ++ T.unpack (_EnvVar $ sectionPWEnvVar s) + hln = unwords $ nub [ encode h | h<-[minBound..maxBound], hostSection h==s ] + sln = unwords $ map encode $ superSections s + uln = unwords $ map encode $ [ s_ | s_<-[minBound..maxBound], s `elem` superSections s_ ] + kln = fmt $ flip keyIsInSection s + + f = uncurry $ printf "%-20s %s" + + fmt_s stgs = map (" "++) $ lines $ LBS.unpack $ A.encode $ A.Object $ _Settings stgs + +secretKeySummary :: Sections h s k => IC -> SECTIONS h s k -> IO T.Text +secretKeySummary ic scn = T.unlines <$> mapM f (sections scn) + where + f s = do + sec <- T.pack . B.unpack <$> (showSecret ic False $ passwordName s) + return $ T.concat ["export ",_EnvVar $ sectionPWEnvVar s,"=",sec] + +publicKeySummary :: Sections h s k => IC -> SECTIONS h s k -> FilePath -> IO T.Text +publicKeySummary ic scn fp = f <$> showPublic ic True (sgn_nme $ signing_key scn) + where + f b = T.pack $ "echo '" ++ B.unpack b ++ "' >" ++ fp ++ "\n" + +locateKeys :: IC -> Name -> IO [Key] +locateKeys ic nm = sortBy (flip $ comparing _key_name) . filter yup <$> keys ic + where + yup = isp . _key_name + isp nm' = nm_s `isPrefixOf` _name nm' + + nm_s = _name nm + +keyName :: Sections h s k => h -> k -> Name +keyName h k = key_nme (const h <$> keyIsHostIndexed k) (hostSection h) k + +passwordName :: Sections h s k => s -> Name +passwordName s = name' $ "pw_" ++ encode s + +fmt :: Code a => (a->Bool) -> String +fmt p = unwords [ encode h | h<-[minBound..maxBound], p h ] + +rotate' :: Sections h s k => IC -> Maybe h -> s -> k -> IO () +rotate' ic mb_h s k = do + KeyData{..} <- getKeyData mb_h s k + nm <- unique_nme ic $ key_nme mb_h s k + createKey ic nm kd_comment kd_identity Nothing (Just kd_secret) + +lower_sections :: Sections h s k => s -> [s] +lower_sections s0 = + s0 : concat + [ s:lower_sections s | s<-[minBound..maxBound], s0 `elem` superSections s ] + +mk_section :: Sections h s k => IC -> s -> IO () +mk_section ic s = do + mk_section' ic s + case sectionType s of + ST_top -> return () + ST_signing -> add_signing ic s + ST_keys -> return () + +mk_section' :: Sections h s k => IC -> s -> IO () +mk_section' ic s = + do add_password ic s + add_save_key ic s + add_trigger ic s + mapM_ (backup_password ic s) $ superSections s + +add_signing :: Sections h s k => IC -> s -> IO () +add_signing ic s = createRSAKeyPair ic (sgn_nme s) cmt "" [pw_sg] + where + cmt = Comment $ T.pack $ "signing key" + pw_sg = safeguard [passwordName s] + +add_password :: Sections h s k => IC -> s -> IO () +add_password ic s = createKey ic nm cmt ide (Just ev) Nothing + where + cmt = Comment $ T.pack $ "password for " ++ encode s + ide = "" + ev = sectionPWEnvVar s + + nm = passwordName s + +add_save_key :: Sections h s k => IC -> s -> IO () +add_save_key ic s = createRSAKeyPair ic nm cmt ide [pw_sg] + where + nm = sve_nme s + cmt = Comment $ T.pack $ "save key for " ++ encode s + ide = "" + pw_sg = safeguard [passwordName s] + +add_trigger :: Sections h s k => IC -> s -> IO () +add_trigger ic s = do + stgs <- (bu_settings s <>) <$> sectionSettings (Just s) + addTrigger' ic tid pat stgs + where + tid = TriggerID $ T.pack $ encode s + pat = scn_pattern s + +bu_settings :: Sections h s k => s -> Settings +bu_settings s = Settings $ HM.fromList + [ ("backup.keys" + , A.Array $ V.singleton $ A.String $ T.pack $ _name $ sve_nme s + ) + ] + +signing_key :: Sections h s k => SECTIONS h s k -> s +signing_key _ = maybe oops id $ listToMaybe [ s_ | s_<-[minBound..maxBound], sectionType s_ == ST_signing ] + where + oops = error "signing_key: there is no signing key!" + +sections :: Sections h s k => SECTIONS h s k -> [s] +sections _ = [minBound..maxBound] + +backup_password :: Sections h s k => IC -> s -> s -> IO () +backup_password ic s sv_s = secureKey ic (passwordName s) $ safeguard [sve_nme sv_s] + +key_nme :: Sections h s k => Maybe h -> s -> k -> Name +key_nme mb_h s k = name' $ encode s ++ "_" ++ encode k ++ hst_sfx + where + hst_sfx = maybe "" (\h -> "_" ++ encode h) mb_h + +sgn_nme :: Sections h s k => s -> Name +sgn_nme s = name' $ encode s ++ "_keystore_signing_key" + +sve_nme :: Sections h s k => s -> Name +sve_nme s = name' $ "save_" ++ encode s + +scn_pattern :: Sections h s k => s -> Pattern +scn_pattern s = pattern $ "^" ++ encode s ++ "_.*" + +unique_nme :: IC -> Name -> IO Name +unique_nme ic nm = + do nms <- filter isp . map _key_name <$> keys ic + return $ unique_nme' nms nm + where + isp nm' = _name nm `isPrefixOf` _name nm' + +unique_nme' :: [Name] -> Name -> Name +unique_nme' nms nm0 = headNote "unique_name'" c_nms + where + c_nms = [ nm | i<-[length nms+1..], let nm=nname i nm0, nm `notElem` nms ] + + nname :: Int -> Name -> Name + nname i nm_ = name' $ _name nm_ ++ printf "_%03d" i + +name' :: String -> Name +name' = either (error.show) id . name + +the_keystore :: CtxParams -> FilePath +the_keystore = maybe "keystore.json" id . cp_store + +get_kd :: Sections h s k => String -> k -> IO KeyData +get_kd sd k = do + ide <- B.readFile $ fp "_id" + cmt <- B.readFile $ fp "_cmt" + sec <- B.readFile $ fp "" + return + KeyData + { kd_identity = Identity $ T.pack $ B.unpack ide + , kd_comment = Comment $ T.pack $ B.unpack cmt + , kd_secret = sec + } + where + fp sfx = sd encode k ++ sfx diff --git a/src/Data/KeyStore/Types.hs b/src/Data/KeyStore/Types.hs --- a/src/Data/KeyStore/Types.hs +++ b/src/Data/KeyStore/Types.hs @@ -128,6 +128,9 @@ deriving instance Num Octets +-- | Keystore session context, created at the start of a session and passed +-- to the keystore access functions. + data Pattern = Pattern { _pat_string :: String diff --git a/src/Data/KeyStore/Types/NameAndSafeguard.hs b/src/Data/KeyStore/Types/NameAndSafeguard.hs --- a/src/Data/KeyStore/Types/NameAndSafeguard.hs +++ b/src/Data/KeyStore/Types/NameAndSafeguard.hs @@ -68,7 +68,7 @@ _ | all chk s -> chk' $ safeguard $ map Name $ words $ map tr s | otherwise -> oops where - chk c = c==',' || is_nm_char c + chk c = c==',' || is_nm_char c chk' sg = case isWildSafeguard sg of