dhall-secret (empty) → 0.5.50
raw patch · 11 files changed
+808/−0 lines, 11 filesdep +HUnitdep +amazonkadep +amazonka-kmssetup-changed
Dependencies added: HUnit, amazonka, amazonka-kms, base, base64, bech32, bytestring, cryptonite, dhall, dhall-secret, lens, memory, optparse-applicative, pem, text, unordered-containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Main.hs +97/−0
- dhall-secret.cabal +186/−0
- src/Dhall/Secret.hs +138/−0
- src/Dhall/Secret/Age.hs +227/−0
- src/Dhall/Secret/Aws.hs +24/−0
- src/Dhall/Secret/IO.hs +43/−0
- src/Dhall/Secret/Type.hs +8/−0
- test/Age.hs +24/−0
- test/Spec.hs +29/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2022++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 Author name here nor the names of other+ 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+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Main where++import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Void (Void)+import Dhall (EvaluateSettings (..), InputSettings (..),+ inputExpr, inputExprWithSettings)+import Dhall.Core (pretty)+import Dhall.Import (load)+import Dhall.Secret+import Dhall.Secret.IO (parseExpr, prettyExpr, version)+import Dhall.Secret.Type (secretTypes)+import Dhall.Src+import Options.Applicative+data EncryptOpts = EncryptOpts+ { eo'file :: Maybe String+ , eo'inplace :: Bool+ , eo'output :: Maybe String+ }++data DecryptOpts = DecryptOpts+ { do'file :: Maybe String+ , do'inplace :: Bool+ , do'output :: Maybe String+ , do'notypes :: Bool+ }++data GenTypesOpts = GenTypesOpts { gt'output :: Maybe String }++data Command = Encrypt EncryptOpts | Decrypt DecryptOpts | GenTypes GenTypesOpts++versionOpt = infoOption version (long "version" <> short 'v' <> help "print version")++genTypesOpt = GenTypesOpts <$> optional (strOption+ (long "output"+ <> short 'o'+ <> metavar "FILE"+ <> help "Output types into FILE"))++encryptOpt = EncryptOpts+ <$> optional (strOption+ (long "file"+ <> short 'f'+ <> metavar "FILE"+ <> help "Read expression from file to encrypt"))+ <*> switch (long "in-place" <> short 'i' <> help "encrypt file in place")+ <*> optional (strOption+ (long "output"+ <> short 'o'+ <> metavar "FILE"+ <> help "Write result to a file instead of stdout"))+++decryptOpt = DecryptOpts+ <$> optional (strOption+ (long "file"+ <> short 'f'+ <> metavar "FILE"+ <> help "Read expression from file to encrypt"))+ <*> switch (long "in-place" <> short 'i' <> help "decrypt file in place")+ <*> optional (strOption+ (long "output"+ <> short 'o'+ <> metavar "FILE"+ <> help "Write result to a file instead of stdout"))+ <*> switch (long "plain-text" <> short 'p' <> help "decrypt into plain text without types")++encryptCmdParser = hsubparser $ command "encrypt" (info encryptOpt (progDesc "Encrypt a Dhall expression")) <> metavar "encrypt"++decryptCmdParser = hsubparser $ command "decrypt" (info decryptOpt (progDesc "Decrypt a Dhall expression")) <> metavar "decrypt"++genTypesCmdParser = hsubparser $ command "gen-types" (info genTypesOpt (progDesc "generate types")) <> metavar "gen-types"++commands = Encrypt <$> encryptCmdParser+ <|> Decrypt <$>decryptCmdParser+ <|> GenTypes <$> genTypesCmdParser++main :: IO ()+main = exec =<< execParser opts+ where+ opts = info (commands <**> helper <**> versionOpt) fullDesc++exec :: Command -> IO ()+exec (Encrypt EncryptOpts {eo'file, eo'output, eo'inplace}) = ioDhallExpr eo'file eo'output eo'inplace encrypt+exec (Decrypt DecryptOpts {do'file, do'output, do'inplace, do'notypes}) = ioDhallExpr do'file do'output do'inplace (decrypt (DecryptPreference do'notypes))+exec (GenTypes GenTypesOpts {gt'output}) = do+ let a = pretty secretTypes+ maybe (TIO.putStrLn a) (`TIO.writeFile` a) gt'output++ioDhallExpr input output inplace op = do+ text <- maybe TIO.getContents TIO.readFile input+ expr <- parseExpr text+ procssed <- op expr >>= prettyExpr+ maybe (TIO.putStrLn procssed) (`TIO.writeFile` procssed) (output <|> (if inplace then input else Nothing))
+ dhall-secret.cabal view
@@ -0,0 +1,186 @@+cabal-version: 3.0+-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.++-- Initial package description 'dhall-secret' generated by+-- 'cabal init'. For further documentation, see:+-- http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name: dhall-secret++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.5.50++-- A short (one-line) description of the package.+synopsis: Encrypt Decrypt Dhall expressions++-- A longer description of the package.+description: A simple tool to manage secrets in Dhall configuration+-- URL for the project homepage or repository.+homepage: https://github.com/jcouyang/dhall-secret++-- The license under which the package is released.+license: Apache-2.0++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Jichao Ouyang++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: oyanglulu@gmail.com++-- A copyright notice.+-- copyright:+category: Data+build-type: Simple++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:+source-repository head+ type: git+ location: https://github.com/jcouyang/dhall-secret++common warnings+ ghc-options: -Wall++library+ -- Import common warning flags.+ import: warnings++ -- Modules exported by the library.+ exposed-modules:+ Dhall.Secret+ Dhall.Secret.Age+ Dhall.Secret.Aws+ Dhall.Secret.IO+ Dhall.Secret.Type+ autogen-modules:+ Paths_dhall_secret+ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends: base >=4.14 && < 5+ , amazonka >= 1.6.1 && < 1.7+ , bytestring >= 0.10.12 && < 0.11+ , text >= 1.2.4 && < 1.3+ , unordered-containers >= 0.2.19 && < 0.3+ , cryptonite >= 0.30 && < 0.31+ , memory >= 0.18.0 && < 0.19+ , pem >= 0.2.4 && < 0.3+ , lens >= 5.2 && < 5.3+ , amazonka-kms >= 1.6.1 && < 1.7+ , base64 >= 0.3.1 && < 0.4+ , bech32 >= 1.1.2 && < 1.2+ , dhall >= 1.41.2 && < 1.42++ -- Directories containing source files.+ hs-source-dirs: src+ other-modules:+ Paths_dhall_secret++ -- Base language which the package is written in.+ default-language: Haskell2010++ default-extensions:+ QuasiQuotes+ TemplateHaskell+ NamedFieldPuns+ OverloadedStrings+executable dhall-secret+ -- Import common warning flags.+ import: warnings++ -- .hs or .lhs file containing the Main module.+ main-is: Main.hs++ -- Modules included in this executable, other than Main.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends:+ base >=4.14 && < 5+ , dhall-secret+ , amazonka >= 1.6.1 && < 1.7+ , bytestring >= 0.10.12 && < 0.11+ , text >= 1.2.4 && < 1.3+ , unordered-containers >= 0.2.19 && < 0.3+ , cryptonite >= 0.30 && < 0.31+ , memory >= 0.18.0 && < 0.19+ , pem >= 0.2.4 && < 0.3+ , lens >= 5.2 && < 5.3+ , amazonka-kms >= 1.6.1 && < 1.7+ , base64 >= 0.3.1 && < 0.4+ , bech32 >= 1.1.2 && < 1.2+ , dhall >= 1.41.2 && < 1.42+ , optparse-applicative >= 0.17.0 && < 0.18++ -- Directories containing source files.+ hs-source-dirs: app+ other-modules:+ Paths_dhall_secret++ -- Base language which the package is written in.+ default-language: Haskell2010++test-suite dhall-secret-test+ -- Import common warning flags.+ import: warnings+ other-modules:+ Paths_dhall_secret+ Age++ -- Base language which the package is written in.+ default-language: Haskell2010++ -- Modules included in this executable, other than Main.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- The interface type and version of the test suite.+ type: exitcode-stdio-1.0++ -- Directories containing source files.+ hs-source-dirs: test++ -- The entrypoint to the test suite.+ main-is: Spec.hs++ -- Test dependencies.+ build-depends:+ base >=4.14 && < 5+ , dhall-secret+ , HUnit+ , amazonka >= 1.6.1 && < 1.7+ , bytestring >= 0.10.12 && < 0.11+ , text >= 1.2.4 && < 1.3+ , unordered-containers >= 0.2.19 && < 0.3+ , cryptonite >= 0.30 && < 0.31+ , memory >= 0.18.0 && < 0.19+ , pem >= 0.2.4 && < 0.3+ , lens >= 5.2 && < 5.3+ , amazonka-kms >= 1.6.1 && < 1.7+ , base64 >= 0.3.1 && < 0.4+ , bech32 >= 1.1.2 && < 1.2+ , dhall >= 1.41.2 && < 1.42
+ src/Dhall/Secret.hs view
@@ -0,0 +1,138 @@+module Dhall.Secret+ ( encrypt,+ decrypt,+ DecryptPreference(..),+ )+where++import Control.Lens+import Data.ByteArray (ByteArrayAccess)+import Data.ByteArray.Encoding (Base (Base64), convertFromBase,+ convertToBase)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Void (Void)+import Dhall.Core (Chunks (Chunks), Expr (..),+ FieldSelection (FieldSelection),+ RecordField (RecordField),+ makeFieldSelection, makeRecordField,+ subExpressions)+import qualified Dhall.Map as DM+import qualified Dhall.Secret.Age as Age+import Dhall.Secret.Aws (awsRun)+import Dhall.Secret.Type (secretTypes)+import Dhall.Src (Src)+import GHC.Exts (toList)+import Network.AWS (send)+import Network.AWS.KMS (decEncryptionContext,+ eEncryptionContext)+import qualified Network.AWS.KMS as KMS+import Network.AWS.KMS.Decrypt (drsKeyId, drsPlaintext)+import Network.AWS.KMS.Encrypt (ersCiphertextBlob, ersKeyId)+import System.Environment (getEnv)++varName :: Expr s a+varName = Var "dhall-secret"++data DecryptPreference = DecryptPreference+ { dp'notypes :: Bool+ }++encrypt :: Expr Src Void -> IO (Expr Src Void)+encrypt (App (Field u (FieldSelection src t c)) (RecordLit m))+ | u == secretTypes && t == "AwsKmsDecrypted" = case (DM.lookup "KeyId" m, DM.lookup "PlainText" m, DM.lookup "EncryptionContext" m) of+ ( Just (RecordField _ (TextLit (Chunks _ kid)) _ _),+ Just (RecordField _ (TextLit (Chunks _ pt)) _ _),+ Just ec@(RecordField _ (ListLit _ ecl) _ _)+ ) -> do+ let context = mconcat $ toList (dhallMapToHashMap <$> ecl)+ eResp <- awsRun $ send $ KMS.encrypt kid (T.encodeUtf8 pt) & eEncryptionContext .~ context+ case (eResp ^. ersKeyId, eResp ^. ersCiphertextBlob) of+ (Just _, Just cb) ->+ pure $+ App+ (Field varName (makeFieldSelection "AwsKmsEncrypted"))+ ( RecordLit $+ DM.fromList+ [ ("KeyId", makeRecordField (TextLit (Chunks [] kid))),+ ("CiphertextBlob", makeRecordField (TextLit (Chunks [] (byteStringToB64 cb)))),+ ("EncryptionContext", ec)+ ]+ )+ _ -> error (show eResp)+ _ -> error "Internal Error when encrypting AwsKmsDecrypted expr"+ | u == secretTypes && t == "AgeDecrypted" = case+ ( DM.lookup "Recipients" m,+ DM.lookup "PlainText" m) of+ (Just (RecordField _ (ListLit _ pks) _ _),+ Just (RecordField _ (TextLit (Chunks _ plaintext)) _ _)) -> do+ rs <- traverse Age.parseRecipient (toList $ extractTextLit <$> pks)+ encrypted <- Age.encrypt rs (T.encodeUtf8 plaintext)+ pure $ App+ (Field varName (makeFieldSelection "AgeEncrypted"))+ ( RecordLit $+ DM.fromList+ [ ("Recipients", makeRecordField (ListLit Nothing pks)),+ ("CiphertextBlob", makeRecordField (TextLit (Chunks [] (T.decodeUtf8 encrypted))))+ ])+ _ -> error "Internal Error when encrypting Symmetric expr"+ | u == secretTypes = pure $ App (Field varName (FieldSelection src t c)) (RecordLit m)+encrypt expr = subExpressions encrypt expr++decrypt :: DecryptPreference -> Expr Src Void -> IO (Expr Src Void)+decrypt opts (App (Field u (FieldSelection s t c)) (RecordLit m))+ | u == secretTypes && t == "AwsKmsEncrypted" = case (DM.lookup "KeyId" m, DM.lookup "CiphertextBlob" m, DM.lookup "EncryptionContext" m) of+ (Just (RecordField _ (TextLit (Chunks _ kid)) _ _), Just (RecordField _ (TextLit (Chunks _ cb)) _ _), Just ec@(RecordField _ (ListLit _ ecl) _ _)) -> do+ eResp <- case convertFromBase Base64 (T.encodeUtf8 cb) of+ Left e -> error (show e)+ Right a -> awsRun $ send $ KMS.decrypt a & decEncryptionContext .~ mconcat (toList (dhallMapToHashMap <$> ecl))+ case (eResp ^. drsKeyId, eResp ^. drsPlaintext) of+ (Just _, Just pt) ->+ pure $ if dp'notypes opts then+ TextLit (Chunks [] (T.decodeUtf8 pt))+ else+ App+ (Field varName (makeFieldSelection "AwsKmsDecrypted"))+ ( RecordLit $+ DM.fromList+ [ ("KeyId", makeRecordField (TextLit (Chunks [] kid))),+ ("PlainText", makeRecordField (TextLit (Chunks [] (T.decodeUtf8 pt)))),+ ("Context", ec)+ ])+ _ -> error (show eResp)+ _ -> error "something wrong decrypting aws kms"+ | u == secretTypes && t == "AgeEncrypted" = case+ ( DM.lookup "Recipients" m,+ DM.lookup "CiphertextBlob" m) of+ (Just (RecordField _ (ListLit _ pks) _ _),+ Just (RecordField _ (TextLit (Chunks _ plaintext)) _ _)) -> do+ keys <- T.splitOn "\n" . T.pack <$> getEnv "DHALL_SECRET_AGE_KEYS"+ decodedKeys <- traverse Age.parseIdentity keys+ decrypted <- Age.decrypt (T.encodeUtf8 plaintext) decodedKeys+ pure $ if dp'notypes opts then+ TextLit (Chunks [] (T.decodeUtf8 decrypted))+ else App+ (Field varName (makeFieldSelection "AgeDecrypted"))+ ( RecordLit $+ DM.fromList+ [ ("Recipients", makeRecordField (ListLit Nothing pks)),+ ("PlainText", makeRecordField (TextLit (Chunks [] (T.decodeUtf8 decrypted))))+ ])+ _ -> error "Internal Error when decrypting Age"+ | u == secretTypes = pure $ App (Field varName (FieldSelection s t c)) (RecordLit m)+decrypt opts expr = subExpressions (decrypt opts) expr++dhallMapToHashMap :: Expr Src a -> HashMap T.Text T.Text+dhallMapToHashMap (RecordLit m) = case (DM.lookup "mapKey" m, DM.lookup "mapValue" m) of+ (Just (RecordField _ (TextLit (Chunks _ k)) _ _), Just (RecordField _ (TextLit (Chunks _ v)) _ _)) -> HashMap.singleton k v+ _ -> mempty+dhallMapToHashMap _ = mempty++byteStringToB64 :: (ByteArrayAccess baa) => baa -> T.Text+byteStringToB64 = T.decodeUtf8 . convertToBase Base64++extractTextLit :: Expr Src Void -> T.Text+extractTextLit (TextLit (Chunks _ t)) = t+extractTextLit _ = ""
+ src/Dhall/Secret/Age.hs view
@@ -0,0 +1,227 @@+module Dhall.Secret.Age+ ( encrypt,+ decrypt,+ generateX25519Identity,+ parseRecipient,+ parseIdentity,+ toRecipient+ ) where+import qualified Codec.Binary.Bech32 as Bech32+import qualified Crypto.Cipher.ChaChaPoly1305 as CC+import Crypto.Error (CryptoError (..),+ CryptoFailable (..),+ eitherCryptoError,+ throwCryptoErrorIO)+import Crypto.Hash (SHA256)+import Crypto.KDF.HKDF (PRK)+import qualified Crypto.KDF.HKDF as HKDF+import Crypto.MAC.HMAC (HMAC, hmac)+import qualified Crypto.PubKey.Curve25519 as X25519+import Crypto.Random (MonadRandom (getRandomBytes))+import Data.ByteArray (ByteArrayAccess, convert)+import Data.ByteString (ByteString, intercalate)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as BS+import Data.Either (isRight)+import Data.List (find)+import Data.Maybe (fromMaybe)+import Data.PEM (PEM (..), pemParseBS, pemWriteBS)+import Data.Text (Text)+import qualified Data.Text as T++data Stanza = Stanza+ { stzType:: ByteString+ , stzArgs :: [ByteString]+ , stzBody :: ByteString+ } deriving Show+data X25519Recipient = X25519Recipient X25519.PublicKey+instance Show X25519Recipient where+ show (X25519Recipient pub) = T.unpack $ b32 "age" pub++data X25519Identity = X25519Identity X25519.PublicKey X25519.SecretKey+instance Show X25519Identity where+ show (X25519Identity _ sec) = T.unpack $ T.toUpper $ b32 "AGE-SECRET-KEY-" sec++data Header = Header [Stanza] ByteString++data CipherBlock = Cipher Header ByteString ByteString++encrypt :: [X25519Recipient] -> ByteString -> IO ByteString+encrypt recipients msg = do+ fileKey <- getRandomBytes 16 :: IO ByteString+ nonce <- getRandomBytes 16 :: IO ByteString+ stanzas <- traverse (mkStanza fileKey) recipients+ body <- encryptChunks (payloadKey nonce fileKey) (zeroNonceOf 11) msg+ pure $ pemWriteBS $ PEM { pemName ="AGE ENCRYPTED FILE", pemHeader = [], pemContent = mkHeader fileKey stanzas <> nonce <> body}++decrypt :: ByteString -> [X25519Identity] -> IO ByteString+decrypt ciphertext identities = do+ (Cipher header nonce body) <- either error pure $ parseCipher ciphertext+ let Header stz mac = header+ let possibleKeys = findFileKey identities header+ case find isRight $ possibleKeys of+ Just (Right key) -> do+ let (headerNoMac, macGot) = mkHeaderMac key stz+ if macGot == mac then+ decryptChunks (payloadKey nonce key) (zeroNonceOf 11) body+ else error $ show $ "Header MAC not match" <> headerNoMac <> "\n" <> macGot+ _ -> error "No file key found"++generateX25519Identity :: IO X25519Identity+generateX25519Identity = do+ sec <- X25519.generateSecretKey+ pure $ X25519Identity (X25519.toPublic sec) sec++parseRecipient :: Text -> IO X25519Recipient+parseRecipient r = X25519Recipient <$> throwCryptoErrorIO (X25519.publicKey $ b32dec r)++parseIdentity :: Text -> IO X25519Identity+parseIdentity i = throwCryptoErrorIO $ do+ key <- X25519.secretKey (b32dec i)+ pure $ X25519Identity (X25519.toPublic key) key++decryptChunks :: ByteString -> ByteString -> ByteString -> IO ByteString+decryptChunks key nonce body = case BS.splitAt (64 * 1024) body of+ (head', tail') | tail' == BS.empty -> decryptChunk key nonce head' (BS.pack [1])+ (head', tail') -> decryptChunk key nonce head' (BS.pack [0]) <> decryptChunks key (incNonce nonce) tail'++decryptChunk :: ByteString -> ByteString -> ByteString -> ByteString -> IO ByteString+decryptChunk key nonce cipherblob isFinal = do+ st1 <- throwCryptoErrorIO $ do+ payloadNonce <- CC.nonce12 $ (nonce <> isFinal)+ CC.finalizeAAD <$> CC.initialize key payloadNonce+ let (msg, tag) = BS.splitAt (BS.length cipherblob - 16) cipherblob+ let (d, st2) = CC.decrypt msg st1+ let authtag = CC.finalize st2+ if (convert authtag) == tag then pure d else error "Invalid auth tag"++parseCipher :: ByteString -> Either String CipherBlock+parseCipher ct = do+ content <- pemContent . head <$> pemParseBS ct+ let (_, rest) = BS.break (== 0x0a) content+ (header, rest2) <- parseHeader (Header [] "") (BS.drop 1 rest)+ let (nonce, body) = BS.splitAt 16 rest2+ pure $ Cipher header nonce body++parseHeader :: Header -> ByteString -> Either String (Header, ByteString)+parseHeader (Header stz mac) content = do+ case BS.take 3 content of+ "---" ->+ let (mac', body) = BS.break isLF $ content in+ Right $ (Header (reverse stz) (BS.decodeBase64Lenient $ BS.drop 4 mac'), BS.drop 1 body)+ "-> " ->+ let (recipients, rest1) = BS.break isLF $ BS.drop 3 content+ (fileKey, rest2) = BS.break isLF $ BS.drop 1 rest1+ (stztype, rest11) = BS.break isSpace recipients+ stzarg = BS.drop 1 rest11+ st = Stanza {stzType = stztype, stzArgs = [stzarg], stzBody = BS.decodeBase64Lenient fileKey} in+ parseHeader (Header (st:stz) mac) (BS.drop 1 rest2)+ _ -> Left "invalid headers"+ where+ isLF = (== 0x0a)+ isSpace = (== 0x20)++findFileKey :: [X25519Identity] -> Header -> [Either CryptoError ByteString]+findFileKey identities (Header stanza _mac) = hasKey <$> identities <*> stanza+ where+ hasKey :: X25519Identity -> Stanza -> Either CryptoError ByteString+ hasKey (X25519Identity pk sec) stz = eitherCryptoError $ do+ let theirPkBs = BS.decodeBase64Lenient $ head (stzArgs stz)+ theirPk <- X25519.publicKey theirPkBs+ let shareKey = X25519.dh theirPk sec+ let salt = (convert theirPk) <> (convert pk)+ let wrappingKey = hkdf "age-encryption.org/v1/X25519" (convert shareKey) salt+ nonce <- CC.nonce12 (zeroNonceOf 12)+ st0 <- CC.initialize wrappingKey nonce+ let fileKey = stzBody stz+ let (e, tag) = BS.splitAt (BS.length fileKey - 16) fileKey+ let (d, st1) = CC.decrypt e st0+ let dtag = CC.finalize st1+ if (convert dtag) == tag then pure d else CryptoFailed CryptoError_AuthenticationTagSizeInvalid++encryptChunks :: ByteString -> ByteString -> ByteString -> IO ByteString+encryptChunks key nonce msg = case BS.splitAt (64 * 1024) msg of+ (head', tail') | tail' == BS.empty -> encryptChunk key nonce head' (BS.pack [1])+ (head', tail') -> encryptChunk key nonce head' (BS.pack [0]) <> encryptChunks key (incNonce nonce) tail'++encryptChunk :: ByteString -> ByteString -> ByteString -> ByteString -> IO ByteString+encryptChunk key nonce msg isFinal = do+ st <- throwCryptoErrorIO $ do+ payloadNonce <- CC.nonce12 $ (nonce <> isFinal)+ CC.finalizeAAD <$> CC.initialize key payloadNonce+ let (e, st1) = CC.encrypt msg st+ let tag = CC.finalize st1+ return $ e <> (convert tag)++toRecipient :: X25519Identity -> X25519Recipient+toRecipient (X25519Identity pub _) = X25519Recipient pub++b32 :: (ByteArrayAccess b) => Text -> b -> Text+b32 header b = case Bech32.humanReadablePartFromText header of+ Left e -> T.pack $ show e+ Right header' -> case Bech32.encode header' (Bech32.dataPartFromBytes (convert b)) of+ Left e -> T.pack $ show e+ Right t -> t++b32dec :: Text -> ByteString+b32dec r = case Bech32.decode r of+ Left _ -> error "Cannot decode bech32"+ Right (_, d) -> fromMaybe (error "Cannot extract bech32 data") $ Bech32.dataPartToBytes d++mkStanza :: ByteString -> X25519Recipient -> IO Stanza+mkStanza fileKey (X25519Recipient theirPK) = do+ ourKey <- X25519.generateSecretKey+ let ourPK = X25519.toPublic ourKey+ let shareKey = X25519.dh theirPK ourKey+ let salt = (convert ourPK) <> (convert theirPK) :: ByteString+ let wrappingKey = hkdf "age-encryption.org/v1/X25519" (convert shareKey) salt+ body <- throwCryptoErrorIO $ do+ nonce <- CC.nonce12 (BS.pack $ take 12 $ repeat 0)+ st0 <- CC.initialize wrappingKey nonce+ let (e, st1) = CC.encrypt fileKey st0+ return $ e <> (convert $ CC.finalize st1)+ pure Stanza {stzType = "X25519", stzBody = body, stzArgs = [BS.encodeBase64Unpadded' (convert ourPK)]}++marshalStanza :: Stanza -> ByteString+marshalStanza stanza =+ let prefix = "-> " :: ByteString+ body = BS.encodeBase64Unpadded' $ stzBody stanza+ argLine = prefix <> stzType stanza <> " " <> intercalate " " (stzArgs stanza) <> "\n"+ in argLine <>+ wrap64b body <> "\n"++mkHeader :: ByteString -> [Stanza] -> ByteString+mkHeader fileKey recipients =+ let (headerNoMac, mac) = mkHeaderMac fileKey recipients+ in headerNoMac <> " " <> (BS.encodeBase64Unpadded' mac) <> "\n"++mkHeaderMac :: ByteString -> [Stanza] -> (ByteString, ByteString)+mkHeaderMac fileKey recipients =+ let intro = "age-encryption.org/v1\n" :: ByteString+ macKey = hkdf "header" fileKey ""+ footer = "---" :: ByteString+ stanza = BS.concat (marshalStanza <$> recipients)+ headerNoMac = intro <> stanza <> footer+ mac = convert (hmac macKey headerNoMac :: HMAC SHA256) :: ByteString+ in (headerNoMac, mac)++hkdf :: ByteString -> ByteString -> ByteString -> ByteString+hkdf info key salt = HKDF.expand (HKDF.extract salt key ::PRK SHA256) info 32++incNonce :: ByteString -> ByteString+incNonce n = BS.pack . snd $ foldr inc1 (True, []) (BS.unpack n)+ where+ inc1 cur (True, acc) = (cur + 1 == 0, (cur + 1) : acc)+ inc1 cur (False, acc) = (False, cur : acc)++zeroNonceOf :: Int -> ByteString+zeroNonceOf n = BS.pack (take n $ repeat 0)++wrap64b :: ByteString -> ByteString+wrap64b bs =+ let (head', tail') = BS.splitAt 64 bs+ in if (BS.length tail' == 0) then head'+ else head' <> "\n" <> wrap64b tail'++payloadKey :: ByteString -> ByteString -> ByteString+payloadKey nonce filekey = HKDF.expand (HKDF.extract nonce filekey ::PRK SHA256) ("payload" :: ByteString) 32
+ src/Dhall/Secret/Aws.hs view
@@ -0,0 +1,24 @@+module Dhall.Secret.Aws where++import Control.Lens ((&), (.~))+import Data.Text (pack)+import Network.AWS (AWS, Credentials (Discover),+ HasEnv (envLogger), LogLevel (Info),+ envRegion, newEnv, newLogger, runAWS,+ runResourceT)+import Network.AWS.Data (fromText)+import System.Environment.Blank (getEnv)+import System.IO (stdout)++awsRun :: Network.AWS.AWS b -> IO b+awsRun cmd = do+ logger <- Network.AWS.newLogger Network.AWS.Info stdout+ discover <- Network.AWS.newEnv Network.AWS.Discover+ defaultRegion <- getEnv "AWS_REGION"+ Network.AWS.runResourceT $ Network.AWS.runAWS (case (hush . fromText . pack) =<< defaultRegion of+ Nothing -> discover & Network.AWS.envLogger .~ logger+ Just region -> discover & Network.AWS.envRegion .~ region & Network.AWS.envLogger .~ logger)+ cmd+ where+ hush (Left _) = Nothing+ hush (Right x) = Just x
+ src/Dhall/Secret/IO.hs view
@@ -0,0 +1,43 @@+module Dhall.Secret.IO where+import Control.Lens (set)+import qualified Data.Text as T+import Data.Version (showVersion)+import Data.Void (Void, vacuous)+import Dhall (InputSettings, defaultInputSettings,+ evaluateSettings, inputExprWithSettings,+ substitutions)+import Dhall.Core (Directory (Directory), Expr (..),+ File (File), Import (Import),+ ImportHashed (ImportHashed),+ ImportMode (Code), ImportType (Remote),+ Scheme (HTTPS), URL (URL), freeIn,+ makeBinding, normalize, pretty)+import Dhall.Freeze (Intent (Secure), Scope (OnlyRemoteImports),+ freezeExpression)+import Dhall.Import (load)+import qualified Dhall.Map+import Dhall.Secret.Type (secretTypes)+import Dhall.Src (Src)+import qualified Paths_dhall_secret as P++version :: String+version = showVersion P.version++inputsetting :: InputSettings+inputsetting = set (evaluateSettings . substitutions ) (Dhall.Map.fromList ([("dhall-secret", secretTypes)])) defaultInputSettings++defineVar :: Expr Src Void -> Expr Src Import+defineVar = Let (makeBinding "dhall-secret" (Embed (Import (ImportHashed Nothing (Remote (URL HTTPS "raw.githubusercontent.com" (File (Directory $ reverse ["jcouyang", "dhall-secret", tag]) "Type.dhall") Nothing Nothing))) Code))) . vacuous+ where+ tag = if version == "0.1.0.0" then "master" else "v" <> T.pack version++addLetbinding :: Expr Src Void -> IO (Expr Src Import)+addLetbinding x+ | freeIn "dhall-secret" x = freezeExpression "." OnlyRemoteImports Secure $ defineVar x+ | otherwise = pure $ vacuous $ normalize x++parseExpr :: T.Text -> IO (Expr Src Void)+parseExpr text = inputExprWithSettings inputsetting text >>= addLetbinding >>= load++prettyExpr :: Expr Src Void -> IO T.Text+prettyExpr = fmap pretty . addLetbinding
+ src/Dhall/Secret/Type.hs view
@@ -0,0 +1,8 @@+module Dhall.Secret.Type where+import Data.Void (Void)+import Dhall.Core (Expr)+import Dhall.Src (Src)+import Dhall.TH++secretTypes :: Expr Src Void+secretTypes = [dhall|./src/Type.dhall|]
+ test/Age.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Age where+import qualified Crypto.Cipher.ChaChaPoly1305 as CC+import Crypto.Error (throwCryptoErrorIO)+import Data.ByteArray (ByteArray, ByteArrayAccess,+ Bytes, convert, pack)+import Data.ByteString (ByteString, empty)+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as TIO+import Dhall.Secret.Age+import Test.HUnit++testAgeEncryption = TestCase $ do+ i <- generateX25519Identity+ i2 <- generateX25519Identity+ let r = toRecipient i+ let r2 = toRecipient i2+ plaintext <- BS.readFile "./README.md"+ encrypted <- encrypt [r, r2] plaintext+ print encrypted+ decrypted <- decrypt encrypted [i]+ assertEqual "age encryption" plaintext decrypted
+ test/Spec.hs view
@@ -0,0 +1,29 @@+module Main where+import Age+import qualified Data.Text.IO as TIO+import Dhall+import Dhall.Core (pretty)+import qualified Dhall.Secret as Lib+import Dhall.Secret.IO+import System.Environment (setEnv)+import System.Environment.Blank (getEnv)+import Test.HUnit+testKms = "encrypt decrypt with KMS" ~: snapshot "./test/example01.dhall" "./test/example01.encrypted.dhall"+testAge = "encrypt decrypt with Age Algo" ~: snapshot "./test/example02.dhall" "./test/example02.encrypted.dhall"++main :: IO ()+main = do+ alg <- getEnv "TEST_ALG"+ setEnv "DHALL_SECRET_AGE_KEYS" "AGE-SECRET-KEY-1SR4ZPP77HDEUJJ9MXJPFQFKHNJ57XKUHXW7TFZ6R3AV59M3KHP2S45ZFW9\nAGE-SECRET-KEY-1HKC2ZRPFFY66049G5EWYLT2PMYKTPN6UW6RFEEEN3JEEWTFFFDNQ2QTC8M\nAGE-SECRET-KEY-1GLAZ75TDSSR647WXD0MH3RUU8XGRK6R5SD8UGQ6C6R9MCYR03ULQSUC7D6"+ case alg of+ Just "KMS" -> runTestTTAndExit (test testKms)+ Just "ALL" -> runTestTTAndExit (test [testKms, testAgeEncryption, testAge])+ _ -> runTestTTAndExit (test [testAgeEncryption, testAge])++snapshot src expect = do+ expr <- TIO.readFile src+ encrypted1 <- parseExpr expr >>= Lib.encrypt >>= prettyExpr+ encrypted2 <- TIO.readFile expect >>= parseExpr+ decrypted1 <- parseExpr encrypted1 >>= Lib.decrypt (Lib.DecryptPreference False) >>= prettyExpr+ decrypted2 <- Lib.decrypt (Lib.DecryptPreference False) encrypted2 >>= prettyExpr+ assertEqual "snapshot" decrypted1 decrypted2