keystore 0.1.1.0 → 0.2.0.0
raw patch · 26 files changed
+3135/−2546 lines, 26 filesdep +raw-strings-qqdep ~aeson-prettydep ~optparse-applicativenew-component:exe:deploy
Dependencies added: raw-strings-qq
Dependency ranges changed: aeson-pretty, optparse-applicative
Files
- examples/deploy/deploy.hs +89/−0
- examples/psd/psd.hs +0/−146
- keystore.cabal +23/−18
- main/ks.hs +1/−1
- src/Data/KeyStore.hs +7/−400
- src/Data/KeyStore/CLI.hs +70/−45
- src/Data/KeyStore/CLI/Command.hs +467/−0
- src/Data/KeyStore/CPRNG.hs +0/−29
- src/Data/KeyStore/Command.hs +0/−383
- src/Data/KeyStore/Configuration.hs +0/−30
- src/Data/KeyStore/Crypto.hs +0/−347
- src/Data/KeyStore/IO.hs +340/−167
- src/Data/KeyStore/IO/IC.hs +218/−0
- src/Data/KeyStore/KS.hs +422/−152
- src/Data/KeyStore/KS/CPRNG.hs +29/−0
- src/Data/KeyStore/KS/Configuration.hs +30/−0
- src/Data/KeyStore/KS/Crypto.hs +384/−0
- src/Data/KeyStore/KS/KS.hs +204/−0
- src/Data/KeyStore/KS/Opt.hs +315/−0
- src/Data/KeyStore/KS/Packet.hs +166/−0
- src/Data/KeyStore/KeyStore.hs +0/−461
- src/Data/KeyStore/Opt.hs +0/−211
- src/Data/KeyStore/Packet.hs +0/−155
- src/Data/KeyStore/Sections.hs +366/−0
- src/Data/KeyStore/Types.hs +3/−0
- src/Data/KeyStore/Types/NameAndSafeguard.hs +1/−1
+ examples/deploy/deploy.hs view
@@ -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
− examples/psd/psd.hs
@@ -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
keystore.cabal view
@@ -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
main/ks.hs view
@@ -1,4 +1,4 @@-import Data.KeyStore.CLI+import Data.KeyStore main :: IO () main = cli
src/Data/KeyStore.hs view
@@ -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
src/Data/KeyStore/CLI.hs view
@@ -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 =
+ src/Data/KeyStore/CLI/Command.hs view
@@ -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
− src/Data/KeyStore/CPRNG.hs
@@ -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
− src/Data/KeyStore/Command.hs
@@ -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)
− src/Data/KeyStore/Configuration.hs
@@ -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
− src/Data/KeyStore/Crypto.hs
@@ -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
src/Data/KeyStore/IO.hs view
@@ -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
+ src/Data/KeyStore/IO/IC.hs view
@@ -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" ]
src/Data/KeyStore/KS.hs view
@@ -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+ }
+ src/Data/KeyStore/KS/CPRNG.hs view
@@ -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
+ src/Data/KeyStore/KS/Configuration.hs view
@@ -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
+ src/Data/KeyStore/KS/Crypto.hs view
@@ -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
+ src/Data/KeyStore/KS/KS.hs view
@@ -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)+ }
+ src/Data/KeyStore/KS/Opt.hs view
@@ -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 "[<string>]"+ }+ 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 "<boolean>"+ }+ 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 "<integer>"+ }+ 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 "<string>"+ }+ 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."+ ]
+ src/Data/KeyStore/KS/Packet.hs view
@@ -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
− src/Data/KeyStore/KeyStore.hs
@@ -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- }
− src/Data/KeyStore/Opt.hs
@@ -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] ]
− src/Data/KeyStore/Packet.hs
@@ -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
+ src/Data/KeyStore/Sections.hs view
@@ -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
src/Data/KeyStore/Types.hs view
@@ -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
src/Data/KeyStore/Types/NameAndSafeguard.hs view
@@ -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