diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -113,3 +113,9 @@ 0.7.0.1 Chris Dornan 2014-12-04 * Data.KeyStore.Sections: export mkSection + +0.9.0.0 Chris Dornan 2022-06-02 + * fix for GHC 9.2 + * switch cryptonite in place of older deprecated packages + * upgrade to aeson-2.* + * upgrade to api-tools 0.10.* diff --git a/examples/deploy/Deploy/Deploy.hs b/examples/deploy/Deploy/Deploy.hs --- a/examples/deploy/Deploy/Deploy.hs +++ b/examples/deploy/Deploy/Deploy.hs @@ -15,7 +15,7 @@ deploy :: IC -> HostID -> IO LBS.ByteString -deploy ic h = A.encode . A.Object . HM.fromList <$> mapM (extract ic h) +deploy ic h = A.encode . A.Object . mkKeyMap <$> mapM (extract ic h) [ k | k<-[minBound..maxBound], maybe True ($ h) $ keyIsHostIndexed k ] @@ -36,7 +36,7 @@ K_ssl -> clear_text k key hash :: KeyID -> Key -> A.Value -hash k Key{..} = chk $ A.Object $ HM.fromList +hash k Key{..} = chk $ A.Object $ mkKeyMap [ (,) "name" $ A.toJSON _key_name , (,) "identity" $ A.toJSON _key_identity , (,) "comment" $ A.toJSON _key_comment @@ -48,7 +48,7 @@ oops = error $ encode k ++ ": hash not present" clear_text :: KeyID -> Key -> A.Value -clear_text k Key{..} = chk $ A.Object $ HM.fromList +clear_text k Key{..} = chk $ A.Object $ mkKeyMap [ (,) "name" $ A.toJSON _key_name , (,) "identity" $ A.toJSON _key_identity , (,) "comment" $ A.toJSON _key_comment @@ -69,3 +69,7 @@ tst [] = error $ encode k ++ ": key not present in the this section" tst (key:_) = return key + + +mkKeyMap :: [(T.Text,a)] -> A.Object +mkKeyMap = undefined (HM.fromList :: [(T.Text,a)] -> HM.HashMap T.Text a) diff --git a/examples/deploy/deploy.hs b/examples/deploy/deploy.hs --- a/examples/deploy/deploy.hs +++ b/examples/deploy/deploy.hs @@ -67,7 +67,7 @@ C_sign -> return () _ -> verify_ks True ic_ro case cc_cmd of - C_create -> error "main: Initialise" + -- C_create -> error "main: Initialise" C_rotate mbh mbs mbk -> rotate ic $ key_prededicate mbh mbs mbk C_rotate_smart mbh mbs mbk -> rotateIfChanged ic $ key_prededicate mbh mbs mbk C_deploy False mb hst -> deploy ic_ro hst >>= write mb @@ -75,14 +75,14 @@ C_client -> lookupEnv "KEY_pw_session" >>= putStrLn . ("session-token=>" ++) . maybe "NONE" id C_sign -> sign_ks ic_ro C_verify -> T.putStrLn "the keystore matches the signature" - C_list_hosts -> error "main: ListHosts" + -- C_list_hosts -> error "main: ListHosts" C_info_key mbk -> T.putStr $ keyHelp mbk C_info_section mbs -> sectionHelp mbs >>= T.putStr C_secret_script -> secretKeySummary ic sections >>= T.putStr C_public_script -> publicKeySummary ic sections ks_mac_fp >>= T.putStr - C_sample_script -> error "main: SampleScript" - C_ks _ -> error "main: KS" - C_pm _ -> error "main: PM" + -- C_sample_script -> error "main: SampleScript" + -- C_ks _ -> error "main: KS" + -- C_pm _ -> error "main: PM" verify_ks False ic_ro create_cc, deploy_cc, client_cc :: CollectConfig SectionID diff --git a/keystore.cabal b/keystore.cabal --- a/keystore.cabal +++ b/keystore.cabal @@ -1,5 +1,5 @@ Name: keystore -Version: 0.8.2.0 +Version: 0.9.0.0 Synopsis: Managing stores of secret things Homepage: http://github.com/cdornan/keystore Author: Chris Dornan @@ -122,7 +122,7 @@ on GitHub home page for launch instructions for the deploy example. Data-files: stack.yaml - stack-8.6.yaml + stack-8.10.yaml examples/deploy/zshenv/.zshrc examples/deploy/example-pwstore.dat @@ -153,6 +153,7 @@ Data.KeyStore.PasswordManager Data.KeyStore.Sections Data.KeyStore.Types + Data.KeyStore.Types.AesonCompat Data.KeyStore.Types.E Data.KeyStore.Types.NameAndSafeguard Data.KeyStore.Types.PasswordStoreModel @@ -161,30 +162,35 @@ Data.KeyStore.Types.UTC Data.KeyStore.Version + Other-modules: + Text.KSRegex + Build-depends: - api-tools >= 0.5.2 , + aeson >= 1.5.6.0 , + aeson-pretty >= 0.7 , + api-tools >= 0.9.0.0 , + array >= 0.5.4.0 , asn1-types >= 0.2.0 , asn1-encoding >= 0.8.0 , ansi-wl-pprint >= 0.6.7 , - crypto-pubkey >= 0.2.1 , - crypto-random >= 0.0.7 , - aeson >= 0.8 , - aeson-pretty >= 0.7 , base >= 4.8 , base64-bytestring >= 1.0 , byteable >= 0.1 , bytestring >= 0.9 , - cipher-aes >= 0.2.6 , + crypto-pubkey-types >= 0.4.3 , + cryptonite >= 0.30 , containers >= 0.4 , directory >= 1.2 , filepath >= 1.3 , lens >= 3.9.2 , + memory >= 0.17.0 , mtl >= 2 , old-locale >= 1.0.0.5 , optparse-applicative >= 0.11.0 , pbkdf >= 1.1.1.0 , regex >= 1.0.1.3 , - regex-compat-tdfa >= 0.95.1 , + regex-base >= 0.94.0.2 , + regex-tdfa >= 1.3.1.2 , safe >= 0.3.3 , setenv >= 0.1 , text >= 0.11.3 , diff --git a/src/Data/KeyStore/CLI/Command.hs b/src/Data/KeyStore/CLI/Command.hs --- a/src/Data/KeyStore/CLI/Command.hs +++ b/src/Data/KeyStore/CLI/Command.hs @@ -18,7 +18,7 @@ import Data.KeyStore.IO.IC import Data.Monoid import Data.String -import Text.Regex +import Text.KSRegex import qualified Data.Text as T import Options.Applicative import System.Environment diff --git a/src/Data/KeyStore/IO.hs b/src/Data/KeyStore/IO.hs --- a/src/Data/KeyStore/IO.hs +++ b/src/Data/KeyStore/IO.hs @@ -73,9 +73,9 @@ import Data.KeyStore.KS import Data.KeyStore.KS.KS import Data.KeyStore.Types +import Data.KeyStore.Types.AesonCompat 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 @@ -147,7 +147,7 @@ where id_s = T.unpack $ _TriggerID _trg_id pat_s = _pat_string _trg_pattern - stgs_s = LBS.unpack $ encode $ Object $ _Settings _trg_settings + stgs_s = LBS.unpack $ encode $ Object $ intoKM $ _Settings _trg_settings -- | Returns the striggers setup on the keystore. triggers :: IC -> IO [Trigger] diff --git a/src/Data/KeyStore/IO/IC.hs b/src/Data/KeyStore/IO/IC.hs --- a/src/Data/KeyStore/IO/IC.hs +++ b/src/Data/KeyStore/IO/IC.hs @@ -20,9 +20,9 @@ import Data.KeyStore.KS import Data.KeyStore.Types +import Data.KeyStore.Types.AesonCompat import Data.API.Types -import Data.Aeson -import Data.Text as T +import Data.Text as T hiding (elem) import qualified Data.Map as Map import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B @@ -181,7 +181,7 @@ Left msg -> errorIO msg Right val -> case val of - Object hm -> return $ Settings hm + Object hm -> return $ Settings $ fromKM hm _ -> errorIO "JSON object expected in the configuration file" errorIO :: String -> IO a diff --git a/src/Data/KeyStore/KS.hs b/src/Data/KeyStore/KS.hs --- a/src/Data/KeyStore/KS.hs +++ b/src/Data/KeyStore/KS.hs @@ -39,8 +39,8 @@ import Data.KeyStore.KS.Configuration import Data.KeyStore.KS.CPRNG import Data.KeyStore.Types +import Data.KeyStore.Types.AesonCompat 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 @@ -77,7 +77,7 @@ settingsFromBytes :: LBS.ByteString -> E Settings settingsFromBytes = chk . either (const Nothing) Just . decodeWithErrs where - chk (Just(Object fm)) = Right $ Settings fm + chk (Just(Object fm)) = Right $ Settings $ fromKM fm chk _ = Left $ strMsg "failed to decode JSON settings" diff --git a/src/Data/KeyStore/KS/CPRNG.hs b/src/Data/KeyStore/KS/CPRNG.hs --- a/src/Data/KeyStore/KS/CPRNG.hs +++ b/src/Data/KeyStore/KS/CPRNG.hs @@ -9,20 +9,20 @@ ) where import Crypto.Random -import qualified Data.ByteString as B +import qualified Data.ByteArray as BA +import System.IO.Unsafe newtype CPRNG - = CPRNG { _CPRNG :: SystemRNG } - deriving (CPRG) + = CPRNG { _CPRNG :: SystemDRG } + deriving (DRG) newCPRNG :: IO CPRNG -newCPRNG = cprgCreate <$> createEntropyPool +newCPRNG = CPRNG <$> getSystemDRG testCPRNG :: CPRNG -testCPRNG = cprgSetReseedThreshold 0 $ - cprgCreate $ createTestEntropyPool "Data.CertStore.Tools" +testCPRNG = unsafePerformIO newCPRNG -generateCPRNG :: Int -> CPRNG -> (B.ByteString,CPRNG) -generateCPRNG = cprgGenerate +generateCPRNG :: BA.ByteArray ba => Int -> CPRNG -> (ba,CPRNG) +generateCPRNG = randomBytesGenerate diff --git a/src/Data/KeyStore/KS/Configuration.hs b/src/Data/KeyStore/KS/Configuration.hs --- a/src/Data/KeyStore/KS/Configuration.hs +++ b/src/Data/KeyStore/KS/Configuration.hs @@ -5,7 +5,7 @@ import Data.KeyStore.Types import qualified Data.Map as Map import Data.Maybe -import Text.Regex +import Text.KSRegex configurationSettings :: Configuration -> Settings diff --git a/src/Data/KeyStore/KS/Crypto.hs b/src/Data/KeyStore/KS/Crypto.hs --- a/src/Data/KeyStore/KS/Crypto.hs +++ b/src/Data/KeyStore/KS/Crypto.hs @@ -3,6 +3,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Data.KeyStore.KS.Crypto ( sizeAesIV @@ -55,14 +59,22 @@ import qualified Data.ASN1.Types as A import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.ByteString.Char8 as B +import Data.Coerce +import Data.Maybe +import Data.Typeable +import Crypto.Error +import Crypto.Hash.Algorithms 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 +import qualified Crypto.Types.PubKey.RSA as CPT +-- avoiding class with crypto-pubkey-types which we are using for DER generation +import qualified "cryptonite" Crypto.Cipher.Types as CCT + sizeAesIV, sizeOAE :: Octets sizeAesIV = 16 sizeOAE = 256 @@ -219,41 +231,43 @@ encryptRSAKS :: PublicKey -> AESKey -> KS RSAEncryptedKey encryptRSAKS pk (AESKey (Binary dat)) = - RSAEncryptedKey . Binary <$> randomRSA (\g->OAEP.encrypt g oaep pk dat) + fmap (RSAEncryptedKey . Binary) $ rsaErrorKS $ OAEP.encrypt oaep pk dat decryptRSAKS :: PrivateKey -> RSAEncryptedKey -> KS AESKey decryptRSAKS pk rek = either throwKS return $ decryptRSAE pk rek decryptRSAE :: PrivateKey -> RSAEncryptedKey -> E AESKey -decryptRSAE pk rek = - rsa2e $ fmap (AESKey . Binary) $ - OAEP.decrypt Nothing oaep pk $ _Binary $ _RSAEncryptedKey rek +decryptRSAE pk rek = rsa2e $ fmap (AESKey . Binary) $ + OAEP.decrypt Nothing oaep pk $ _Binary $ _RSAEncryptedKey rek -oaep :: OAEP.OAEPParams -oaep = - OAEP.OAEPParams - { OAEP.oaepHash = hashFunction hashDescrSHA512 - , OAEP.oaepMaskGenAlg = mgf1 - , OAEP.oaepLabel = Nothing - } +type OAEPparams = OAEP.OAEPParams SHA512 B.ByteString B.ByteString +oaep :: OAEPparams +oaep = OAEP.OAEPParams + { OAEP.oaepHash = SHA512 + , OAEP.oaepMaskGenAlg = mgf1 SHA512 + , OAEP.oaepLabel = Nothing + } + -- -- signing & verifying -- signKS :: PrivateKey -> ClearText -> KS RSASignature signKS pk dat = - RSASignature . Binary <$> - randomRSA (\g->PSS.sign g Nothing pssp pk $ _Binary $ _ClearText dat) + fmap (RSASignature . Binary) $ + rsaErrorKS $ PSS.sign Nothing pssp pk $ _Binary $ _ClearText dat verifyKS :: PublicKey -> ClearText -> RSASignature -> Bool verifyKS pk (ClearText (Binary dat)) (RSASignature (Binary sig)) = PSS.verify pssp pk dat sig -pssp :: PSS.PSSParams -pssp = PSS.defaultPSSParams $ hashFunction hashDescrSHA512 +type PSSparams = PSS.PSSParams SHA512 B.ByteString B.ByteString +pssp :: PSSparams +pssp = PSS.defaultPSSParams SHA512 + -- -- AES encrypting/decrypting -- @@ -265,26 +279,51 @@ return $ encryptAES aek iv ct encryptAES :: AESKey -> IV -> ClearText -> AESSecretData -encryptAES (AESKey (Binary ky)) (IV (Binary iv)) (ClearText (Binary dat)) = +encryptAES aek iv (ClearText (Binary dat)) = AESSecretData - { _asd_iv = IV $ Binary iv - , _asd_secret_data = SecretData $ Binary $ encryptCTR (initAES ky) iv dat + { _asd_iv = iv + , _asd_secret_data = SecretData $ Binary $ encryptCTR aek 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) +decryptAES aek AESSecretData{..} = ClearText $ Binary $ + encryptCTR aek _asd_iv $ _Binary $ _SecretData _asd_secret_data randomAESKeyKS :: Cipher -> KS AESKey -randomAESKeyKS cip = randomBytes (keyWidth cip) (AESKey . Binary) +randomAESKeyKS cip = randomBytes (keyWidth cip) $ AESKey . Binary randomIVKS :: KS IV -randomIVKS = randomBytes sizeAesIV (IV . Binary) +randomIVKS = randomBytes sizeAesIV $ IV . Binary +encryptCTR :: AESKey -> IV -> B.ByteString -> B.ByteString +encryptCTR aek = case B.length $ coerce aek of + 16 -> aes_ctr (Proxy @AES128) aek + 24 -> aes_ctr (Proxy @AES192) aek + 32 -> aes_ctr (Proxy @AES256) aek + ln -> error $ "aek_from_key: unexpected AES key size: " ++ show ln +aes_ctr :: forall k . (CCT.BlockCipher k,Typeable k) + => Proxy k -> AESKey -> IV -> B.ByteString -> B.ByteString +aes_ctr pxy aek iv msg = CCT.ctrCombine ky_ iv_ msg + where + ky_ :: k + ky_ = case CCT.cipherInit ky_b of + CryptoFailed _ -> oops "key" + CryptoPassed z -> z + + iv_ :: CCT.IV k + iv_ = fromMaybe (oops "IV") $ CCT.makeIV iv_b + + oops :: String -> a + oops thg = error $ tynm ++ " cryption error: mismatched size of "++thg + + tynm :: String + tynm = show $ typeRep pxy + + AESKey (Binary ky_b) = aek + IV (Binary iv_b) = iv + + -- -- hashing -- @@ -324,9 +363,6 @@ _hashd_width_octets (HashData . Binary) } ---randomSalt :: KS Salt ---randomSalt = randomBytes size_salt Salt - -- -- Generating a private/public key pair -- @@ -341,7 +377,7 @@ generateKeysKS = generateKeysKS_ default_key_size generateKeysKS_ :: Int -> KS (PublicKey,PrivateKey) -generateKeysKS_ ksz = randomKS $ \g->generate g ksz default_e +generateKeysKS_ ksz = generate ksz default_e -- @@ -360,8 +396,43 @@ encodePublicKeyDER :: PublicKey -> ClearText encodePublicKeyDER = ClearText . Binary . encodeDER -decodeDERE :: A.ASN1Object a => B.ByteString -> E a -decodeDERE bs = + +class ASN1 a where + decodeDERE :: B.ByteString -> E a + encodeDER :: a -> B.ByteString + + +instance ASN1 PrivateKey where + decodeDERE = fmap privateFromCPT . decodeDERE_ + encodeDER = encodeDER_ . privateIntoCPT + +instance ASN1 PublicKey where + decodeDERE = fmap publicFromCPT . decodeDERE_ + encodeDER = encodeDER_ . publicIntoCPT + +privateFromCPT :: CPT.PrivateKey -> PrivateKey +privateFromCPT CPT.PrivateKey{..} = + PrivateKey + { private_pub = publicFromCPT private_pub + , .. + } + +privateIntoCPT :: PrivateKey -> CPT.PrivateKey +privateIntoCPT PrivateKey{..} = + CPT.PrivateKey + { private_pub = publicIntoCPT private_pub + , .. + } + +publicFromCPT :: CPT.PublicKey -> PublicKey +publicFromCPT CPT.PublicKey{..} = PublicKey{..} + +publicIntoCPT :: PublicKey -> CPT.PublicKey +publicIntoCPT PublicKey{..} = CPT.PublicKey{..} + + +decodeDERE_ :: A.ASN1Object a => B.ByteString -> E a +decodeDERE_ bs = case A.decodeASN1 A.DER $ lzy bs of Left err -> Left $ strMsg $ show err Right as -> @@ -374,8 +445,8 @@ where lzy = LBS.pack . B.unpack -encodeDER :: A.ASN1Object a => a -> B.ByteString -encodeDER = egr . A.encodeASN1 A.DER . flip A.toASN1 [] +encodeDER_ :: A.ASN1Object a => a -> B.ByteString +encodeDER_ = egr . A.encodeASN1 A.DER . flip A.toASN1 [] where egr = B.pack . LBS.unpack diff --git a/src/Data/KeyStore/KS/KS.hs b/src/Data/KeyStore/KS/KS.hs --- a/src/Data/KeyStore/KS/KS.hs +++ b/src/Data/KeyStore/KS/KS.hs @@ -7,6 +7,7 @@ , Ctx(..) , State(..) , LogEntry(..) + , rsaErrorKS , withKey , trun , e2io @@ -28,8 +29,8 @@ , insertKey , adjustKeyKS , deleteKeysKS - , randomRSA - , randomKS + -- , randomRSA + -- , randomKS , getKeymap , getConfig , modConfig @@ -39,7 +40,9 @@ import Data.KeyStore.KS.Configuration import Data.KeyStore.KS.Opt import Data.KeyStore.Types -import Crypto.PubKey.RSA +import qualified Data.ByteArray as BA +-- import Crypto.PubKey.RSA +import Crypto.Random.Types import qualified Data.Map as Map import qualified Data.ByteString as B import Data.Typeable @@ -48,6 +51,7 @@ import qualified Control.Monad.Error as E import Control.Exception import Control.Lens +import Crypto.PubKey.RSA.Types newtype KS a = KS { _KS :: E.ErrorT Reason (RWS Ctx [LogEntry] State) a } @@ -75,6 +79,21 @@ } deriving (Show) + +instance MonadRandom KS where + getRandomBytes sz = KS $ state upd + where + upd :: BA.ByteArray ba => State -> (ba,State) + upd st = (ba,st') + where + st' = st + { st_cprng = cprg' + } + (ba,cprg') = generateCPRNG sz $ st_cprng st + +rsaErrorKS :: KS (Either Error a) -> KS a +rsaErrorKS ks_e = either (throwKS . rsaError) return =<< ks_e + withKey :: Name -> KS a -> KS a withKey nm p = do ctx <- KS ask @@ -111,7 +130,7 @@ 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) +randomBytes (Octets sz) k = fmap k $ getRandomBytes sz currentTime :: KS UTCTime currentTime = ctx_now <$> KS ask @@ -177,16 +196,6 @@ 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 diff --git a/src/Data/KeyStore/KS/Packet.hs b/src/Data/KeyStore/KS/Packet.hs --- a/src/Data/KeyStore/KS/Packet.hs +++ b/src/Data/KeyStore/KS/Packet.hs @@ -16,7 +16,7 @@ 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.ByteString.Builder import Data.Word import Data.Bits import Data.Char diff --git a/src/Data/KeyStore/Sections.hs b/src/Data/KeyStore/Sections.hs --- a/src/Data/KeyStore/Sections.hs +++ b/src/Data/KeyStore/Sections.hs @@ -39,13 +39,13 @@ import Data.KeyStore.IO import Data.KeyStore.KS -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.Aeson as A -import qualified Data.HashMap.Strict as HM -import qualified Data.Vector as V -import qualified Data.Map as Map +import qualified Data.KeyStore.Types.AesonCompat as A +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.HashMap.Strict as HM +import qualified Data.Vector as V +import qualified Data.Map as Map import Data.API.Types import Data.Maybe import Data.List @@ -295,7 +295,7 @@ f = uncurry $ printf "%-20s %s" - fmt_s stgs = map (" "++) $ lines $ LBS.unpack $ A.encode $ A.Object $ _Settings stgs + fmt_s stgs = map (" "++) $ lines $ LBS.unpack $ A.encode $ A.Object $ A.intoKM $ _Settings stgs -- | List a shell script for establishing all of the keys in the environment. NB For this -- to work the password for the top section (or the passwords for all of the sections @@ -690,7 +690,7 @@ fmap f m = m >>= \x -> return $ f x instance Applicative Munch where - pure = return + pure x = Munch $ \s -> Just (x,s) (<*>) = ap instance Alternative Munch where @@ -698,7 +698,7 @@ (<|>) x y = Munch $ \s -> _Munch x s <|> _Munch y s instance Monad Munch where - return x = Munch $ \s -> Just (x,s) + return = pure (>>=) m f = Munch $ \s -> _Munch m s >>= \(x,s') -> _Munch (f x) s' run_munch :: Munch a -> String -> Maybe a diff --git a/src/Data/KeyStore/Types.hs b/src/Data/KeyStore/Types.hs --- a/src/Data/KeyStore/Types.hs +++ b/src/Data/KeyStore/Types.hs @@ -43,11 +43,12 @@ import Data.KeyStore.Types.NameAndSafeguard import Data.KeyStore.Types.E import Data.KeyStore.Types.UTC -import Data.Aeson +import Data.KeyStore.Types.AesonCompat import Data.API.Tools import Data.API.JSON import Data.API.Types import qualified Data.ByteString as B +import Data.Coerce import qualified Data.HashMap.Strict as HM import Data.List import qualified Data.Map as Map @@ -56,7 +57,7 @@ import Data.Time import Data.String import qualified Data.Vector as V -import Text.Regex +import Text.KSRegex $(generate keystoreSchema) @@ -105,29 +106,30 @@ prj_pattern = REP__Pattern . T.pack . _pat_string -newtype Settings = Settings { _Settings :: Object } +newtype Settings = Settings { _Settings :: HM.HashMap T.Text Value } deriving (Eq,Show) inj_settings :: REP__Settings -> ParserWithErrs Settings -inj_settings REP__Settings { _stgs_json = Object hm} - = return $ Settings hm +inj_settings REP__Settings { _stgs_json = Object o} + = return $ Settings $ fromKM o inj_settings _ = fail "object expected for settings" prj_settings :: Settings -> REP__Settings -prj_settings (Settings hm) = REP__Settings { _stgs_json = Object hm } +prj_settings (Settings hm) = REP__Settings { _stgs_json = Object $ intoKM hm } defaultSettings :: Settings defaultSettings = mempty + #if __GLASGOW_HASKELL__ >= 804 instance Semigroup Settings where (<>) = mappendSettings #endif instance Monoid Settings where - mempty = Settings HM.empty - mappend = mappendSettings + mempty = Settings mempty + -- mappend = mappendSettings mappendSettings :: Settings -> Settings -> Settings mappendSettings (Settings fm_0) (Settings fm_1) = @@ -136,7 +138,7 @@ cmb v0 v1 = case (v0,v1) of (Array v_0,Array v_1) -> Array $ v_0 V.++ v_1 - _ -> marker + _ -> marker checkSettingsCollisions :: Settings -> [SettingID] checkSettingsCollisions (Settings hm) = diff --git a/src/Data/KeyStore/Types/AesonCompat.hs b/src/Data/KeyStore/Types/AesonCompat.hs new file mode 100644 --- /dev/null +++ b/src/Data/KeyStore/Types/AesonCompat.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} + +module Data.KeyStore.Types.AesonCompat + ( module A + , module Data.KeyStore.Types.AesonCompat + ) where + +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + + +#if MIN_VERSION_aeson(2,0,0) + + +import Data.Aeson as A hiding (Key) +import qualified Data.Aeson.Key as A +import qualified Data.Aeson.KeyMap as A + +type KM a = A.KeyMap a + +fromKM :: KM a -> HM.HashMap T.Text a +fromKM = HM.mapKeys A.toText . A.toHashMap + +intoKM :: HM.HashMap T.Text a -> KM a +intoKM = A.fromHashMap . HM.mapKeys A.fromText + + +#else + + +import Data.Aeson as A + +type KM a = HM.HashMap T.Text a + +fromKM :: KM a -> HM.HashMap T.Text a +fromKM = id + +intoKM :: HM.HashMap T.Text a -> KM a +intoKM = id + + +#endif diff --git a/src/Text/KSRegex.hs b/src/Text/KSRegex.hs new file mode 100644 --- /dev/null +++ b/src/Text/KSRegex.hs @@ -0,0 +1,197 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Regex +-- Copyright : (c) Chris Kuklewicz 2006, (c) shelarcy 2012, derived from (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (regex-base needs MPTC+FD) +-- +-- Regular expression matching. Uses the POSIX regular expression +-- interface in "Text.Regex.TDFA". +-- +--------------------------------------------------------------------------- + +-- +-- Modified by Chris Kuklewicz to be a thin layer over the regex-posix +-- package, and moved into a regex-compat package. +-- +module Text.KSRegex ( + -- * Regular expressions + Regex, + mkRegex, + mkRegexWithOpts, + matchRegex, + matchRegexAll, + subRegex, + splitRegex + ) where + +import Data.Array((!)) +import Text.Regex.Base(RegexMaker(makeRegexOpts),defaultCompOpt,defaultExecOpt,RegexLike(matchAll,matchAllText),RegexContext(matchM),MatchText) +import Text.Regex.TDFA(Regex,caseSensitive,multiline,newSyntax) + +-- | Makes a regular expression with the default options (multi-line, +-- case-sensitive). The syntax of regular expressions is +-- otherwise that of @egrep@ (i.e. POSIX \"extended\" regular +-- expressions). +mkRegex :: String -> Regex +mkRegex s = makeRegexOpts opt defaultExecOpt s + where opt = defaultCompOpt { newSyntax = True, multiline = True } + +-- | Makes a regular expression, where the multi-line and +-- case-sensitive options can be changed from the default settings. +mkRegexWithOpts + :: String -- ^ The regular expression to compile + -> Bool -- ^ 'True' @\<=>@ @\'^\'@ and @\'$\'@ match the beginning and + -- end of individual lines respectively, and @\'.\'@ does /not/ + -- match the newline character. + -> Bool -- ^ 'True' @\<=>@ matching is case-sensitive + -> Regex -- ^ Returns: the compiled regular expression + +mkRegexWithOpts s single_line case_sensitive + = let opt = defaultCompOpt + { multiline = (if single_line then True else False) + , caseSensitive = (if case_sensitive then True else False) + , newSyntax = True } + in makeRegexOpts opt defaultExecOpt s + +-- | Match a regular expression against a string +matchRegex + :: Regex -- ^ The regular expression + -> String -- ^ The string to match against + -> Maybe [String] -- ^ Returns: @'Just' strs@ if the match succeeded + -- (and @strs@ is the list of subexpression matches), + -- or 'Nothing' otherwise. +matchRegex p str = fmap (\(_,_,_,str) -> str) (matchRegexAll p str) + +-- | Match a regular expression against a string, returning more information +-- about the match. +matchRegexAll + :: Regex -- ^ The regular expression + -> String -- ^ The string to match against + -> Maybe ( String, String, String, [String] ) + -- ^ Returns: 'Nothing' if the match failed, or: + -- + -- > Just ( everything before match, + -- > portion matched, + -- > everything after the match, + -- > subexpression matches ) + +matchRegexAll p str = matchM p str + +{- | Replaces every occurance of the given regexp with the replacement string. + +In the replacement string, @\"\\1\"@ refers to the first substring; +@\"\\2\"@ to the second, etc; and @\"\\0\"@ to the entire match. +@\"\\\\\\\\\"@ will insert a literal backslash. + +This does not advance if the regex matches an empty string. This +misfeature is here to match the behavior of the the original +Text.Regex API. +-} + +subRegex :: Regex -- ^ Search pattern + -> String -- ^ Input string + -> String -- ^ Replacement text + -> String -- ^ Output string +subRegex _ "" _ = "" +subRegex regexp inp repl = + let compile _i str [] = \ _m -> (str++) + compile i str (("\\",(off,len)):rest) = + let i' = off+len + pre = take (off-i) str + str' = drop (i'-i) str + in if null str' then \ _m -> (pre ++) . ('\\':) + else \ m -> (pre ++) . ('\\' :) . compile i' str' rest m + compile i str ((xstr,(off,len)):rest) = + let i' = off+len + pre = take (off-i) str + str' = drop (i'-i) str + x = read xstr + in if null str' then \ m -> (pre++) . ((fst (m!x))++) + else \ m -> (pre++) . ((fst (m!x))++) . compile i' str' rest m + compiled :: MatchText String -> String -> String + compiled = compile 0 repl findrefs where + -- bre matches a backslash then capture either a backslash or some digits + bre = mkRegex "\\\\(\\\\|[0-9]+)" + findrefs = map (\m -> (fst (m!1),snd (m!0))) (matchAllText bre repl) + go _i str [] = str + go i str (m:ms) = + let (_,(off,len)) = m!0 + i' = off+len + pre = take (off-i) str + str' = drop (i'-i) str + in if null str' then pre ++ (compiled m "") + else pre ++ (compiled m (go i' str' ms)) + in go 0 inp (matchAllText regexp inp) + +{- | Splits a string based on a regular expression. The regular expression +should identify one delimiter. + +This does not advance and produces an infinite list of [] if the regex +matches an empty string. This misfeature is here to match the +behavior of the the original Text.Regex API. +-} + +splitRegex :: Regex -> String -> [String] +splitRegex _ [] = [] +splitRegex delim strIn = + let matches = map (! 0) (matchAll delim strIn) + go _i str [] = str : [] + go i str ((off,len):rest) = + let i' = off+len + firstline = take (off-i) str + remainder = drop (i'-i) str + in seq i' $ + if null remainder then [firstline,""] + else firstline : go i' remainder rest + in go 0 strIn matches + +{- + +-- These are the older versions which failed on (correct answer:) +-- let r = mkRegex "^(.)" in subRegex2 r "abc\ndef" "|\\1" +-- "|abc\n|def" + +subRegex :: Regex -- ^ Search pattern + -> String -- ^ Input string + -> String -- ^ Replacement text + -> String -- ^ Output string +subRegex _ "" _ = "" +subRegex regexp inp repl = + let -- bre matches a backslash then capture either a backslash or some digits + bre = mkRegex "\\\\(\\\\|[0-9]+)" + lookup _ [] _ = [] + lookup [] _ _ = [] + lookup match repl groups = + case matchRegexAll bre repl of + Nothing -> repl + Just (lead, _, trail, bgroups) -> + let newval = + if (head bgroups) == "\\" + then "\\" + else let index :: Int + index = (read (head bgroups)) - 1 + in if index == -1 + then match + else groups !! index + in lead ++ newval ++ lookup match trail groups + in case matchRegexAll regexp inp of + Nothing -> inp + Just (lead, match, trail, groups) -> + lead ++ lookup match repl groups ++ (subRegex regexp trail repl) + +splitRegex :: Regex -> String -> [String] +splitRegex _ [] = [] +splitRegex delim strIn = loop strIn where + loop str = case matchOnceText delim str of + Nothing -> [str] + Just (firstline, _, remainder) -> + if null remainder + then [firstline,""] + else firstline : loop remainder + +-} diff --git a/stack-8.10.yaml b/stack-8.10.yaml new file mode 100644 --- /dev/null +++ b/stack-8.10.yaml @@ -0,0 +1,14 @@ +resolver: lts-18.28 + +allow-newer: true + +packages: +- '.' + +flags: + cryptonite: + use_target_attributes: false + +extra-deps: +- api-tools-0.9.0.0 +- pbkdf-1.1.1.1 diff --git a/stack-8.6.yaml b/stack-8.6.yaml deleted file mode 100644 --- a/stack-8.6.yaml +++ /dev/null @@ -1,12 +0,0 @@ -resolver: nightly-2018-12-19 -install-ghc: true -flags: {} -packages: -- '.' -system-ghc: false -extra-deps: - - api-tools-0.8.0.2 - - crypto-numbers-0.2.7 - - crypto-pubkey-0.2.8 - - serialise-0.2.1.0 - - pbkdf-1.1.1.0 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,17 @@ -resolver: nightly-2020-12-07 +resolver: nightly-2022-05-31 + ghc-options: "$locals": -Werror + +allow-newer: true + packages: - '.' + flags: cryptonite: use_target_attributes: false + extra-deps: - - pbkdf-1.1.1.0 +- api-tools-0.10.0.0 +- pbkdf-1.1.1.1