diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/psd/psd.hs b/examples/psd/psd.hs new file mode 100644 --- /dev/null +++ b/examples/psd/psd.hs @@ -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 diff --git a/keystore.cabal b/keystore.cabal new file mode 100644 --- /dev/null +++ b/keystore.cabal @@ -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 diff --git a/main/ks.hs b/main/ks.hs new file mode 100644 --- /dev/null +++ b/main/ks.hs @@ -0,0 +1,4 @@ +import Data.KeyStore.CLI + +main :: IO () +main = cli diff --git a/src/Data/KeyStore.hs b/src/Data/KeyStore.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore.hs @@ -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 + + + + + + + + + + + + + + + + diff --git a/src/Data/KeyStore/CLI.hs b/src/Data/KeyStore/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/CLI.hs @@ -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 diff --git a/src/Data/KeyStore/CPRNG.hs b/src/Data/KeyStore/CPRNG.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/CPRNG.hs @@ -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 diff --git a/src/Data/KeyStore/Command.hs b/src/Data/KeyStore/Command.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Command.hs @@ -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) diff --git a/src/Data/KeyStore/Configuration.hs b/src/Data/KeyStore/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Configuration.hs @@ -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 diff --git a/src/Data/KeyStore/Crypto.hs b/src/Data/KeyStore/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Crypto.hs @@ -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 diff --git a/src/Data/KeyStore/IO.hs b/src/Data/KeyStore/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/IO.hs @@ -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" ] diff --git a/src/Data/KeyStore/KS.hs b/src/Data/KeyStore/KS.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/KS.hs @@ -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) + } diff --git a/src/Data/KeyStore/KeyStore.hs b/src/Data/KeyStore/KeyStore.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/KeyStore.hs @@ -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 + } diff --git a/src/Data/KeyStore/Opt.hs b/src/Data/KeyStore/Opt.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Opt.hs @@ -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] ] diff --git a/src/Data/KeyStore/Packet.hs b/src/Data/KeyStore/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Packet.hs @@ -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 diff --git a/src/Data/KeyStore/Types.hs b/src/Data/KeyStore/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Types.hs @@ -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 . + +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) ++ " " + +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 + ]) diff --git a/src/Data/KeyStore/Types/E.hs b/src/Data/KeyStore/Types/E.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Types/E.hs @@ -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" diff --git a/src/Data/KeyStore/Types/NameAndSafeguard.hs b/src/Data/KeyStore/Types/NameAndSafeguard.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Types/NameAndSafeguard.hs @@ -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 ".-_:'=#$%" + diff --git a/src/Data/KeyStore/Types/Schema.hs b/src/Data/KeyStore/Types/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Types/Schema.hs @@ -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" + +|]