diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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)) diff --git a/dhall-secret.cabal b/dhall-secret.cabal new file mode 100644 --- /dev/null +++ b/dhall-secret.cabal @@ -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 diff --git a/src/Dhall/Secret.hs b/src/Dhall/Secret.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Secret.hs @@ -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 _ = "" diff --git a/src/Dhall/Secret/Age.hs b/src/Dhall/Secret/Age.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Secret/Age.hs @@ -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 diff --git a/src/Dhall/Secret/Aws.hs b/src/Dhall/Secret/Aws.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Secret/Aws.hs @@ -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 diff --git a/src/Dhall/Secret/IO.hs b/src/Dhall/Secret/IO.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Secret/IO.hs @@ -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 diff --git a/src/Dhall/Secret/Type.hs b/src/Dhall/Secret/Type.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Secret/Type.hs @@ -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|] diff --git a/test/Age.hs b/test/Age.hs new file mode 100644 --- /dev/null +++ b/test/Age.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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