{-# 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 #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- | 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 ( module Data.KeyStore.Types , module Data.KeyStore.Types.NameAndSafeguard , module Data.KeyStore.Types.E , PublicKey(..) , PrivateKey(..) ) 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 -- | Keystore session context, created at the start of a session and passed -- to the keystore access functions. 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 ])