keystore (empty) → 0.1.0.0
raw patch · 20 files changed
+3560/−0 lines, 20 filesdep +Cabaldep +QuickCheckdep +aesonsetup-changed
Dependencies added: Cabal, QuickCheck, aeson, aeson-pretty, api-tools, array, asn1-encoding, asn1-types, attoparsec, base, base64-bytestring, byteable, bytestring, case-insensitive, cipher-aes, containers, crypto-pubkey, crypto-random, directory, filepath, keystore, lens, mtl, old-locale, optparse-applicative, pbkdf, regex-compat-tdfa, safe, safecopy, template-haskell, text, time, unordered-containers, vector
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- examples/psd/psd.hs +146/−0
- keystore.cabal +125/−0
- main/ks.hs +4/−0
- src/Data/KeyStore.hs +400/−0
- src/Data/KeyStore/CLI.hs +84/−0
- src/Data/KeyStore/CPRNG.hs +29/−0
- src/Data/KeyStore/Command.hs +374/−0
- src/Data/KeyStore/Configuration.hs +30/−0
- src/Data/KeyStore/Crypto.hs +347/−0
- src/Data/KeyStore/IO.hs +212/−0
- src/Data/KeyStore/KS.hs +200/−0
- src/Data/KeyStore/KeyStore.hs +462/−0
- src/Data/KeyStore/Opt.hs +211/−0
- src/Data/KeyStore/Packet.hs +155/−0
- src/Data/KeyStore/Types.hs +364/−0
- src/Data/KeyStore/Types/E.hs +49/−0
- src/Data/KeyStore/Types/NameAndSafeguard.hs +88/−0
- src/Data/KeyStore/Types/Schema.hs +251/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2013, Lainepress+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice, this+ list of conditions and the following disclaimer in the documentation and/or+ other materials provided with the distribution.++* Neither the name of the {organization} nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/psd/psd.hs view
@@ -0,0 +1,146 @@+{-# 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++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
@@ -0,0 +1,125 @@+Name: keystore+Version: 0.1.0.0+Synopsis: Managing stores of secret things+Homepage: http://github.com/cdornan/keystore+Author: Chris Dornan+Maintainer: chris@chrisdornan.com+Copyright: Chris Dornan+License: BSD3+License-file: LICENSE+Category: Cryptography+Build-type: Simple+Description:+ Provides a program, an IO-based API and its underlying functional API for+ managing a multi-level JSON-encoded store of encrypted and hashed symmetric+ and public keypairs and associated utilities for encrypting and signing+ files.++Cabal-version: >= 1.14++Source-repository head+ type: git+ location: https://github.com/iconnect/keystore++flag hpc+ default: False++flag stacktrace+ default: False++Library+ Hs-Source-Dirs: src++ Exposed-modules:+ Data.KeyStore+ Data.KeyStore.CLI+ Data.KeyStore.Configuration+ Data.KeyStore.CPRNG+ Data.KeyStore.IO+ Data.KeyStore.KeyStore+ Data.KeyStore.KS+ Data.KeyStore.Opt+ Data.KeyStore.Packet+ Data.KeyStore.Types+ Data.KeyStore.Types.E+ Data.KeyStore.Types.Schema+ Data.KeyStore.Types.NameAndSafeguard++ Other-modules:+ Data.KeyStore.Command+ Data.KeyStore.Crypto++ Build-depends:+ api-tools >= 0.2 ,+ asn1-types >= 0.2.0 ,+ asn1-encoding >= 0.8.0 ,+ crypto-pubkey >= 0.2.1 ,+ crypto-random >= 0.0.7 ,+ aeson >= 0.6.2 ,+ aeson-pretty <= 0.7 ,+ attoparsec >= 0.10.4.0 ,+ base >= 4 ,+ base64-bytestring >= 1.0 ,+ byteable >= 0.1 ,+ bytestring >= 0.9 ,+ cipher-aes >= 0.2.6 ,+ containers >= 0.4 ,+ directory >= 1.2 ,+ filepath >= 1.3 ,+ mtl >= 2 ,+ optparse-applicative >= 0.7.0.2 && < 0.8 ,+ pbkdf >= 1.1.1.0 ,+ safe >= 0.3.3 ,+ text >= 0.11 ,+ unordered-containers >= 0.2.3.0 ,++ Cabal >= 1.16 ,+ QuickCheck >= 2.6 ,+ array >= 0.4 ,+ case-insensitive >= 1.0.0.2 ,+ lens >= 3.9.2 ,+ old-locale >= 1.0.0.5 ,+ regex-compat-tdfa >= 0.95.1 ,+ safecopy >= 0.8.2 ,+ template-haskell ,+ time >= 1.4 ,+ vector >= 0.10.9+++ Default-Language: Haskell2010++ GHC-Options:+ -fwarn-tabs+++Executable ks+ Hs-Source-Dirs: main++ Main-is: ks.hs++ Default-Language: Haskell2010++ Build-depends:+ base > 4 && < 5 ,+ keystore >= 0.0.0.1++ GHC-Options:+ -fwarn-tabs++Executable psd+ Hs-Source-Dirs: examples/psd++ Main-is: psd.hs++ Default-Language: Haskell2010++ Build-depends:+ base > 4 && < 5 ,+ bytestring >= 0.9 ,+ directory >= 1.0 ,+ filepath >= 1.1 ,+ keystore ,+ text >= 0.11++ GHC-Options:+ -fwarn-tabs
+ main/ks.hs view
@@ -0,0 +1,4 @@+import Data.KeyStore.CLI++main :: IO ()+main = cli
+ src/Data/KeyStore.hs view
@@ -0,0 +1,400 @@+{-# 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 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+ LBS.writeFile (ctx_store ctx) $ KS.keyStoreBytes $ st_keystore st++report :: String -> IO ()+report = hPutStrLn stderr++++++++++++++++
+ src/Data/KeyStore/CLI.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE RecordWildCards #-}++module Data.KeyStore.CLI (cli) where++import Data.KeyStore.Command+import Data.KeyStore+import qualified Data.ByteString.Char8 as B+import Control.Applicative+import Control.Monad+import System.Exit+++version :: String+version = "0.1.0.0"++cli :: IO ()+cli = parseCommand >>= command++command :: Command -> IO ()+command Command{..} =+ 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+ where+ pr p = p >>= B.putStrLn+ cp = CtxParams+ { cp_store = cmd_store+ , cp_debug = cmd_debug+ }++create :: IC+ -> Name+ -> Comment+ -> Identity+ -> Maybe EnvVar+ -> Maybe FilePath+ -> [Safeguard]+ -> IO ()+create ic nm cmt ide mbe mbf secs =+ do createKey ic nm cmt ide mbe Nothing+ secure ic nm mbf secs++secure :: IC -> Name -> Maybe FilePath -> [Safeguard] -> IO ()+secure ic nm mbf secs =+ do case mbf of+ Nothing -> const () <$> loadKey ic nm+ Just fp -> rememberKey ic nm fp+ mapM_ (secureKey ic nm) secs++info_cli :: IC -> [Name] -> IO ()+info_cli ic = mapM_ $ info ic++verify_cli :: IC -> FilePath -> FilePath -> IO ()+verify_cli ic m_fp s_fp =+ do ok <- verify ic m_fp s_fp+ when (not ok) exitFailure
+ src/Data/KeyStore/CPRNG.hs view
@@ -0,0 +1,29 @@+{-# 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 view
@@ -0,0 +1,374 @@+{-# 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_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 Version)+ $ long "version"+ <> help "display the version"+++p_command :: Parser Command+p_command =+ Command+ <$> optional p_store+ <*> p_debug_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_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 view
@@ -0,0 +1,30 @@+{-# 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 view
@@ -0,0 +1,347 @@+{-# 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
@@ -0,0 +1,212 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.KeyStore.IO+ ( readSettings+ , CtxParams(..)+ , defaultCtxParams+ , defaultSettingsFilePath+ , settingsFilePath+ , defaultKeyStoreFilePath+ , determineCtx+ , establishState+ , newGenerator+ , readKeyStore+ , scanEnv+ , errorIO+ , logit+ ) where++import Data.KeyStore.KeyStore+import Data.KeyStore.Configuration+import Data.KeyStore.KS+import Data.KeyStore.Opt+import Data.KeyStore.Types+import Data.KeyStore.CPRNG+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 qualified Control.Exception as X+import Control.Applicative+import System.Environment+import System.Directory+import System.FilePath+import System.IO+import Safe+++-- | 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+ }++-- | Suitable default 'CtxParams'.+defaultCtxParams :: CtxParams+defaultCtxParams =+ CtxParams+ { cp_store = Nothing+ , cp_debug = False+ }++-- | 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 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"+ _ <- rememberKey _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
@@ -0,0 +1,200 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# 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+ ) where++import Data.KeyStore.Configuration+import Data.KeyStore.Opt+import Data.KeyStore.Types+import Data.KeyStore.CPRNG+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 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 :: 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/KeyStore.hs view
@@ -0,0 +1,462 @@+{-# 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 Crypto.PubKey.RSA+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 view
@@ -0,0 +1,211 @@+{-# 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 view
@@ -0,0 +1,155 @@+{-# 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/Types.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | The KeyStore and Associated Types+--+-- Note that most of these types and functions were generated by the+-- api-tools ("Data.Api.Tools") from the schema in "Data.KeyStore.Types.Schema",+-- marked down in <https://github.com/cdornan/keystore/blob/master/schema.md>.++module Data.KeyStore.Types+ ( KeyStore(..)+ , ks_keymap+ , ks_config+ , Configuration(..)+ , TriggerMap(..)+ , Trigger(..)+ , Settings(..)+ , cfg_settings+ , cfg_triggers+ , TextJsonAssoc(..)+ , KeyMap(..)+ , NameKeyAssoc(..)+ , Key(..)+ , key_name+ , key_comment+ , key_identity+ , key_is_binary+ , key_env_var+ , key_hash+ , key_public+ , key_secret_copies+ , key_clear_text+ , key_clear_private+ , key_created_at+ , Hash(..)+ , HashDescription(..)+ , EncrypedCopyMap(..)+ , EncrypedCopy(..)+ , Safeguard(..)+ , EncrypedCopyData(..)+ , RSASecretData(..)+ , AESSecretData(..)+ , PublicKey(..)+ , PrivateKey(..)+ , Cipher(..)+ , _text_Cipher+ , HashPRF(..)+ , _text_HashPRF+ , EncryptionKey(..)+ , FragmentID(..)+ , Pattern(..)+ , Iterations(..)+ , Octets(..)+ , Name(..)+ , Identity(..)+ , SettingID(..)+ , TriggerID(..)+ , Comment(..)+ , EnvVar(..)+ , ClearText(..)+ , Salt(..)+ , IV(..)+ , HashData(..)+ , AESKey(..)+ , SecretData(..)+ , RSAEncryptedKey(..)+ , RSASecretBytes(..)+ , RSASignature(..)+ , EncryptionPacket(..)+ , SignaturePacket(..)+ , Void(..)+ , Dirctn(..)+ , void_+ , pattern+ , defaultSettings+ , checkSettingsCollisions+ , emptyKeyStore+ , emptyKeyMap+ , defaultConfiguration+ , pbkdf+ , keyWidth+ , module Data.KeyStore.Types.NameAndSafeguard+ , module Data.KeyStore.Types.E+ ) where++import Data.KeyStore.Types.Schema+import Data.KeyStore.Types.NameAndSafeguard+import Data.KeyStore.Types.E+import Data.Aeson+import qualified Data.Map as Map+import Data.Monoid+import qualified Data.Text as T+import Data.List+import Data.Ord+import Data.String+import Data.API.Tools+import Data.API.Types+import Data.API.JSON+import qualified Data.ByteString as B+import qualified Data.HashMap.Strict as HM+import qualified Data.Vector as V+import Text.Regex+import qualified Crypto.PBKDF.ByteString as P+import Crypto.PubKey.RSA (PublicKey(..), PrivateKey(..))+++$(generate keystoreSchema)+++deriving instance Num Iterations+deriving instance Num Octets+++data Pattern =+ Pattern+ { _pat_string :: String+ , _pat_regex :: Regex+ }++instance Eq Pattern where+ (==) pat pat' = _pat_string pat == _pat_string pat'++instance Show Pattern where+ show pat = "Pattern " ++ show(_pat_string pat) ++ " <regex>"++instance IsString Pattern where+ fromString s =+ Pattern+ { _pat_string = s+ , _pat_regex = mkRegex s+ }++pattern :: String -> Pattern+pattern = fromString++inj_pattern :: REP__Pattern -> ParserWithErrs Pattern+inj_pattern (REP__Pattern t) =+ return $+ Pattern+ { _pat_string = s+ , _pat_regex = mkRegex s+ }+ where+ s = T.unpack t++prj_pattern :: Pattern -> REP__Pattern+prj_pattern = REP__Pattern . T.pack . _pat_string+++type TriggerMap = Map.Map TriggerID Trigger++inj_trigger_map :: REP__TriggerMap -> ParserWithErrs TriggerMap+inj_trigger_map = map_from_list "TriggerMap" _tmp_map _trg_id _TriggerID++prj_trigger_map :: TriggerMap -> REP__TriggerMap+prj_trigger_map = REP__TriggerMap . Map.elems+++newtype Settings = Settings { _Settings :: Object }+ deriving (Eq,Show)++inj_settings :: REP__Settings -> ParserWithErrs Settings+inj_settings REP__Settings { _stgs_json = Object hm}+ = return $ Settings hm+inj_settings _ = fail "object expected for settings"++prj_settings :: Settings -> REP__Settings+prj_settings (Settings hm) = REP__Settings { _stgs_json = Object hm }++defaultSettings :: Settings+defaultSettings = mempty+++instance Monoid Settings where+ mempty = Settings HM.empty++ mappend (Settings fm_0) (Settings fm_1) =+ Settings $ HM.unionWith cmb fm_0 fm_1+ where+ cmb v0 v1 =+ case (v0,v1) of+ (Array v_0,Array v_1) -> Array $ v_0 V.++ v_1+ _ -> marker++checkSettingsCollisions :: Settings -> [SettingID]+checkSettingsCollisions (Settings hm) =+ [ SettingID k | (k,v)<-HM.toList hm, v==marker ]++marker :: Value+marker = String "*** Collision * in * Settings ***"+++type KeyMap = Map.Map Name Key++inj_keymap :: REP__KeyMap -> ParserWithErrs KeyMap+inj_keymap (REP__KeyMap as) =+ return $ Map.fromList [ (_nka_name,_nka_key) | NameKeyAssoc{..}<-as ]++prj_keymap :: KeyMap -> REP__KeyMap+prj_keymap mp = REP__KeyMap [ NameKeyAssoc nme key | (nme,key)<-Map.toList mp ]++emptyKeyStore :: Configuration -> KeyStore+emptyKeyStore cfg =+ KeyStore+ { _ks_config = cfg+ , _ks_keymap = emptyKeyMap+ }++emptyKeyMap :: KeyMap+emptyKeyMap = Map.empty+++type EncrypedCopyMap = Map.Map Safeguard EncrypedCopy++inj_encrypted_copy_map :: REP__EncrypedCopyMap -> ParserWithErrs EncrypedCopyMap+inj_encrypted_copy_map (REP__EncrypedCopyMap ecs) =+ return $ Map.fromList [ (_ec_safeguard ec,ec) | ec<-ecs ]++prj_encrypted_copy_map :: EncrypedCopyMap -> REP__EncrypedCopyMap+prj_encrypted_copy_map mp = REP__EncrypedCopyMap [ ec | (_,ec)<-Map.toList mp ]++defaultConfiguration :: Settings -> Configuration+defaultConfiguration stgs =+ Configuration+ { _cfg_settings = stgs+ , _cfg_triggers = Map.empty+ }+++inj_safeguard :: REP__Safeguard -> ParserWithErrs Safeguard+inj_safeguard = return . safeguard . _sg_names++prj_safeguard :: Safeguard -> REP__Safeguard+prj_safeguard = REP__Safeguard . safeguardKeys+++inj_name :: REP__Name -> ParserWithErrs Name+inj_name = e2p . name . T.unpack . _REP__Name++prj_name :: Name -> REP__Name+prj_name = REP__Name . T.pack . _name++++inj_PublicKey :: REP__PublicKey -> ParserWithErrs PublicKey+inj_PublicKey REP__PublicKey{..} =+ return+ PublicKey+ { public_size = _puk_size+ , public_n = _puk_n+ , public_e = _puk_e+ }++prj_PublicKey :: PublicKey -> REP__PublicKey+prj_PublicKey PublicKey{..} =+ REP__PublicKey+ { _puk_size = public_size+ , _puk_n = public_n+ , _puk_e = public_e+ }+++++inj_PrivateKey :: REP__PrivateKey -> ParserWithErrs PrivateKey+inj_PrivateKey REP__PrivateKey{..} =+ return+ PrivateKey+ { private_pub = _prk_pub+ , private_d = _prk_d+ , private_p = _prk_p+ , private_q = _prk_q+ , private_dP = _prk_dP+ , private_dQ = _prk_dQ+ , private_qinv = _prk_qinv+ }++prj_PrivateKey :: PrivateKey -> REP__PrivateKey+prj_PrivateKey PrivateKey{..} =+ REP__PrivateKey+ { _prk_pub = private_pub+ , _prk_d = private_d+ , _prk_p = private_p+ , _prk_q = private_q+ , _prk_dP = private_dP+ , _prk_dQ = private_dQ+ , _prk_qinv = private_qinv+ }+++e2p :: E a -> ParserWithErrs a+e2p = either (fail . showReason) return++data Dirctn+ = Encrypting+ | Decrypting+ deriving (Show)+++pbkdf :: HashPRF+ -> ClearText+ -> Salt+ -> Iterations+ -> Octets+ -> (B.ByteString->a)+ -> a+pbkdf hp (ClearText dat) (Salt st) (Iterations k) (Octets wd) c =+ c $ fn (_Binary dat) (_Binary st) k wd+ where+ fn = case hp of+ PRF_sha1 -> P.sha1PBKDF2+ PRF_sha256 -> P.sha256PBKDF2+ PRF_sha512 -> P.sha512PBKDF2++keyWidth :: Cipher -> Octets+keyWidth aes =+ case aes of+ CPH_aes128 -> Octets 16+ CPH_aes192 -> Octets 24+ CPH_aes256 -> Octets 32++void_ :: Void+void_ = Void 0++map_from_list :: Ord a+ => String+ -> (c->[b])+ -> (b->a)+ -> (a->T.Text)+ -> c+ -> ParserWithErrs (Map.Map a b)+map_from_list ty xl xf xt c =+ case [ xt $ xf b | b:_:_<-obss ] of+ [] -> return $ Map.fromDistinctAscList ps+ ds -> fail $ ty ++ ": " ++ show ds ++ "duplicated"+ where+ ps = [ (xf b,b) | [b]<-obss ]++ obss = groupBy same $ sortBy (comparing xf) $ xl c++ same b b' = comparing xf b b' == EQ+++$(generateAPITools keystoreSchema+ [ enumTool+ , jsonTool+ , lensTool+ ])
+ src/Data/KeyStore/Types/E.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.KeyStore.Types.E+ ( E+ , Reason+ , E.strMsg+ , rsaError+ , eWrap+ , showReason+ ) where++import Crypto.PubKey.RSA+import Data.Typeable+import qualified Control.Monad.Error as E+import qualified Control.Exception as X+import System.IO+import System.Exit+++type E a = Either Reason a++data Reason+ = R_RSA Error+ | R_MSG String+ | R_GEN+ deriving (Typeable,Show)++instance X.Exception Reason++instance E.Error Reason where+ noMsg = R_GEN+ strMsg = R_MSG++rsaError :: Error -> Reason+rsaError = R_RSA++eWrap :: IO a -> IO a+eWrap p = X.catch p h+ where+ h = rpt . showReason++ rpt s = hPutStrLn stderr s >> exitFailure++showReason :: Reason -> String+showReason r =+ case r of+ R_RSA e -> "error: " ++ show e+ R_MSG s -> "error: " ++ s+ R_GEN -> "error"
+ src/Data/KeyStore/Types/NameAndSafeguard.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.KeyStore.Types.NameAndSafeguard+ ( Name+ , name+ , _name+ , Safeguard+ , safeguard+ , safeguardKeys+ , isWildSafeguard+ , printSafeguard+ , parseSafeguard+ ) where++import Data.KeyStore.Types.E+import qualified Data.Set as Set+import Data.String+import Data.Char+import qualified Control.Exception as X++newtype Name+ = Name { _Name :: String }+ deriving (Eq,Ord,IsString,Read,Show)++name :: String -> E Name+name s =+ case all is_nm_char s of+ True -> Right $ Name s+ False -> Left $ strMsg "bad name syntax"++_name :: Name -> String+_name = _Name+++newtype Safeguard+ = Safeguard { _Safeguard :: Set.Set Name }+ deriving (Eq,Ord,Show)++instance IsString Safeguard where+ fromString s =+ case parseSafeguard s of+ Left err -> X.throw err+ Right sg -> sg+++safeguard :: [Name] -> Safeguard+safeguard = Safeguard . Set.fromList++safeguardKeys :: Safeguard -> [Name]+safeguardKeys = Set.elems . _Safeguard++isWildSafeguard :: Safeguard -> Bool+isWildSafeguard = null . safeguardKeys++printSafeguard :: Safeguard -> String+printSafeguard (Safeguard st) =+ case Set.null st of+ True -> "*"+ False -> map tr $ unwords $ map _name $ Set.elems st+ where+ tr ' ' = ','+ tr c = c++parseSafeguard :: String -> E Safeguard+parseSafeguard s =+ case s of+ "*" -> Right $ safeguard []+ _ | all chk s -> chk' $ safeguard $ map Name $ words $ map tr s+ | otherwise -> oops+ where+ chk c = c==',' || is_nm_char c++ chk' sg =+ case isWildSafeguard sg of+ True -> oops+ False -> Right sg++ tr ',' = ' '+ tr c = c++ oops = Left $ strMsg "bad safeguard syntax"++is_nm_char :: Char -> Bool+is_nm_char c = isAscii c || isDigit c || c `Set.member` sg_sym_chs++sg_sym_chs :: Set.Set Char+sg_sym_chs = Set.fromList ".-_:'=#$%"+
+ src/Data/KeyStore/Types/Schema.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.KeyStore.Types.Schema+ ( keystoreSchema+ , keystoreChangelog+ ) where++import Data.API.Parse+import Data.API.Types+import Data.API.Changes+++keystoreSchema :: API+keystoreChangelog :: APIChangelog+(keystoreSchema, keystoreChangelog) = [apiWithChangelog|+ks :: KeyStore+ // the keystore+ = record+ config :: Configuration+ keymap :: KeyMap++cfg :: Configuration+ = record+ settings :: Settings+ triggers :: TriggerMap++tmp :: TriggerMap+ = record+ map :: [Trigger]+ with inj_trigger_map, prj_trigger_map++trg :: Trigger+ = record+ id :: TriggerID+ pattern :: Pattern+ settings :: Settings++stgs :: Settings+ = record+ 'json' :: json+ with inj_settings, prj_settings++tja :: TextJsonAssoc+ = record+ id :: SettingID+ key :: json++kmp :: KeyMap+ = record+ map :: [NameKeyAssoc]+ with inj_keymap, prj_keymap++nka :: NameKeyAssoc+ = record+ name :: Name+ key :: Key++key :: Key+ = record+ name :: Name+ comment :: Comment+ identity :: Identity+ is_binary :: boolean+ env_var :: ? EnvVar+ hash :: ? Hash+ public :: ? PublicKey+ secret_copies :: EncrypedCopyMap+ clear_text :: ? ClearText+ clear_private :: ? PrivateKey+ created_at :: utc++hash :: Hash+ = record+ description :: HashDescription+ hash :: HashData++hashd :: HashDescription+ = record+ comment :: Comment+ prf :: HashPRF+ iterations :: Iterations+ width_octets :: Octets+ salt_octets :: Octets+ salt :: Salt++ecm :: EncrypedCopyMap+ = record+ map :: [EncrypedCopy]+ with inj_encrypted_copy_map, prj_encrypted_copy_map++ec :: EncrypedCopy+ = record+ safeguard :: Safeguard+ cipher :: Cipher+ prf :: HashPRF+ iterations :: Iterations+ salt :: Salt+ secret_data :: EncrypedCopyData++sg :: Safeguard+ = record+ names :: [Name]+ with inj_safeguard, prj_safeguard++ecd :: EncrypedCopyData+ = union+ | rsa :: RSASecretData+ | aes :: AESSecretData+ | clear :: ClearText+ | no_data :: Void++rsd :: RSASecretData+ = record+ encrypted_key :: RSAEncryptedKey+ aes_secret_data :: AESSecretData++asd :: AESSecretData+ = record+ iv :: IV+ secret_data :: SecretData++puk :: PublicKey+ = record+ size :: integer+ n :: Integer+ e :: Integer+ with inj_PublicKey, prj_PublicKey++prk :: PrivateKey+ = record+ pub :: PublicKey+ d :: Integer+ p :: Integer+ q :: Integer+ dP :: Integer+ dQ :: Integer+ qinv :: Integer+ with inj_PrivateKey, prj_PrivateKey++cph :: Cipher+ = enum+ | aes128+ | aes192+ | aes256++prf :: HashPRF+ = enum+ | sha1+ | sha256+ | sha512++ek :: EncryptionKey+ = union+ | public :: PublicKey+ | private :: PrivateKey+ | symmetric :: AESKey+ | none :: Void++fid :: FragmentID+ // name of a settings fragment+ = basic string++pat :: Pattern+ // a regular expression to match keynames+ = basic string+ with inj_pattern, prj_pattern++its :: Iterations+ = basic integer++octs :: Octets+ = basic integer++nm :: Name+ = basic string+ with inj_name, prj_name++idn :: Identity+ = basic string++sid :: SettingID+ = basic string++tid :: TriggerID+ = basic string++cmt :: Comment+ = basic string++ev :: EnvVar+ = basic string++ct :: ClearText+ = basic binary++slt :: Salt+ = basic binary++iv :: IV+ = basic binary++hd :: HashData+ = basic binary++aek :: AESKey+ = basic binary++sd :: SecretData+ = basic binary++rek :: RSAEncryptedKey+ = basic binary++rsb :: RSASecretBytes+ = basic binary++rsg :: RSASignature+ = basic binary++ep :: EncryptionPacket+ = basic binary++sp :: SignaturePacket+ = basic binary+++void :: Void+ = basic integer++changes++// Initial version+version "0.0.0.1"++|]