diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/secretspec.cabal b/secretspec.cabal new file mode 100644 --- /dev/null +++ b/secretspec.cabal @@ -0,0 +1,51 @@ +cabal-version: 2.4 +name: secretspec +version: 0.13.0 +synopsis: Haskell SDK for SecretSpec, a declarative secrets manager +description: + A thin client over the @secretspec-ffi@ C ABI (linked at build time). + Resolution (providers, chains, profiles, generation, @as_path@) happens in the + Rust core; this package marshals a JSON request to the native library and + parses the response, mirroring the Rust derive crate's vocabulary. +homepage: https://secretspec.dev/ +license: Apache-2.0 +license-file: LICENSE +author: Domen Kožar +maintainer: domen@enlambda.com +category: Configuration +build-type: Simple + +library + exposed-modules: SecretSpec + hs-source-dirs: src + build-depends: base >=4.14 && <5 + , aeson >=2.0 && <3 + , bytestring <1 + , containers <1 + , directory <2 + , text <3 + -- The native resolver, statically linked at build time. Point --extra-lib-dirs + -- at a directory containing ONLY libsecretspec_ffi.a (so -lsecretspec_ffi + -- resolves to the archive, not a co-located .so), and pass the archive's + -- transitive native deps via --ghc-options=-optl (capture them with + -- `cargo rustc -p secretspec-ffi --crate-type staticlib -- --print native-static-libs`). + -- The Rust code is embedded in the binary, so no LD_LIBRARY_PATH is needed. + extra-libraries: secretspec_ffi + default-language: Haskell2010 + ghc-options: -Wall + +test-suite secretspec-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base + , secretspec + , aeson >=2.0 + , bytestring + , containers + , directory + , filepath + , process + , text + default-language: Haskell2010 + ghc-options: -Wall -threaded diff --git a/src/SecretSpec.hs b/src/SecretSpec.hs new file mode 100644 --- /dev/null +++ b/src/SecretSpec.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Haskell SDK for SecretSpec, a declarative secrets manager. +-- +-- A thin client over the @secretspec-ffi@ C ABI, linked at build time. +-- Resolution (providers, fallback chains, profiles, generation, @as_path@) +-- happens entirely in the Rust core; this module marshals a JSON request to +-- @secretspec_resolve@, parses the response envelope, and exposes it with the +-- same vocabulary as the Rust derive crate. +-- +-- > import qualified SecretSpec as S +-- > import Data.Function ((&)) +-- > +-- > main = do +-- > resolved <- S.load (S.builder & S.withProvider "keyring://" & S.withReason "boot") +-- > print (S.get =<< Data.Map.lookup "DATABASE_URL" (S.resolvedSecrets resolved)) +-- > S.setAsEnv resolved +module SecretSpec + ( -- * Builder + Builder + , builder + , withPath + , withProvider + , withProfile + , withReason + , withNoValues + -- * Resolve (value-carrying) + , Resolved(..) + , ResolvedSecret(..) + , load + , get + , fields + , fieldsJson + , setAsEnv + , close + -- * Report (value-free) + , Report(..) + , SecretReport(..) + , report + -- * Errors + , SecretSpecError(..) + , MissingRequiredError(..) + -- * Misc + , abiVersion + ) where + +import Control.Exception (Exception, finally, mask, throwIO) +import Control.Monad (forM_, unless, when) +import Data.Aeson (FromJSON (..), Value, eitherDecodeStrict, encode, + object, withObject, (.!=), (.:), (.:?), (.=)) +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Foreign.C.String (CString, peekCString) +import Foreign.Ptr (nullPtr) +import System.Directory (doesFileExist, removeFile) +import qualified System.Environment.Blank as Env + +-- The three C ABI functions, statically linked at build time (the archive +-- libsecretspec_ffi.a is embedded; -lsecretspec_ffi resolves to it). They are +-- declared @safe@ because @secretspec_resolve@ may block on provider I/O +-- (1Password, LastPass), and a @safe@ call lets other Haskell threads run. +foreign import ccall safe "secretspec_resolve" + c_secretspec_resolve :: CString -> IO CString + +foreign import ccall safe "secretspec_free" + c_secretspec_free :: CString -> IO () + +foreign import ccall safe "secretspec_abi_version" + c_secretspec_abi_version :: IO CString + +-- | Wire-format version of the value-carrying resolve response this SDK +-- understands. Tracks @secretspec@'s @RESOLVE_SCHEMA_VERSION@. +resolveSchemaVersion :: Int +resolveSchemaVersion = 1 + +-- | Wire-format version of the value-free report. Tracks @secretspec@'s +-- @RESOLUTION_REPORT_SCHEMA_VERSION@. +reportSchemaVersion :: Int +reportSchemaVersion = 1 + +-- | A resolution failure (bad manifest, provider error, reason policy). Carries +-- a stable @kind@. +data SecretSpecError = SecretSpecError + { errorKind :: Text + , errorMessage :: Text + } deriving (Show, Eq) + +instance Exception SecretSpecError + +-- | One or more required secrets were not found anywhere. +newtype MissingRequiredError = MissingRequiredError + { missing :: [Text] + } deriving (Show, Eq) + +instance Exception MissingRequiredError + +-- | One resolved secret. Exactly one of 'secretValue' \/ 'secretPath' is set: +-- the path for @as_path@ secrets, the value otherwise. Both are 'Nothing' for a +-- value-less ('withNoValues') response. +data ResolvedSecret = ResolvedSecret + { secretValue :: Maybe Text + , secretPath :: Maybe Text + , secretAsPath :: Bool + , secretSource :: Text + , secretSourceProvider :: Maybe Text + } deriving (Show, Eq) + +instance FromJSON ResolvedSecret where + parseJSON = withObject "ResolvedSecret" $ \o -> + ResolvedSecret + <$> o .:? "value" + <*> o .:? "path" + <*> o .:? "as_path" .!= False + <*> o .: "source" + <*> o .:? "source_provider" + +-- | A successful resolution, mirroring the Rust @Resolved@ wrapper. +data Resolved = Resolved + { resolvedProvider :: Text + , resolvedProfile :: Text + , resolvedSecrets :: Map Text ResolvedSecret + , resolvedMissingOptional :: [Text] + } deriving (Show, Eq) + +-- | The value-free resolution outcome for one declared secret: how it would +-- resolve and from where, never the value itself. +data SecretReport = SecretReport + { srName :: Text + , srStatus :: Text -- ^ @"resolved"@, @"missing_required"@, or @"missing_optional"@. + , srRequired :: Bool + , srSourceProvider :: Maybe Text + , srDefaultApplied :: Bool + , srGenerated :: Bool + , srAsPath :: Bool + } deriving (Show, Eq) + +instance FromJSON SecretReport where + parseJSON = withObject "SecretReport" $ \o -> + SecretReport + <$> o .: "name" + <*> o .: "status" + <*> o .:? "required" .!= False + <*> o .:? "source_provider" + <*> o .:? "default_applied" .!= False + <*> o .:? "generated" .!= False + <*> o .:? "as_path" .!= False + +-- | A value-free resolution snapshot. Unlike 'Resolved', a missing required +-- secret is a @"missing_required"@ status here, not an error. +data Report = Report + { reportProvider :: Text + , reportProfile :: Text + , reportSecrets :: [SecretReport] + } deriving (Show, Eq) + +-- | A resolution request. Build it from 'builder' with the @withX@ setters and +-- pass it to 'load' or 'report'. +data Builder = Builder + { bPath :: Maybe Text + , bProvider :: Maybe Text + , bProfile :: Maybe Text + , bReason :: Maybe Text + , bNoValues :: Bool + } + +-- | A builder with no options set. +builder :: Builder +builder = Builder Nothing Nothing Nothing Nothing False + +-- | Resolve from a manifest at this path instead of walking up from the working +-- directory. +withPath :: Text -> Builder -> Builder +withPath v b = b { bPath = Just v } + +-- | Override the provider (a @keyring:\/\/@-style URI or a configured alias). +withProvider :: Text -> Builder -> Builder +withProvider v b = b { bProvider = Just v } + +-- | Override the profile. +withProfile :: Text -> Builder -> Builder +withProfile v b = b { bProfile = Just v } + +-- | Set a human-readable reason for this access (for audited providers). +withReason :: Text -> Builder -> Builder +withReason v b = b { bReason = Just v } + +-- | Omit secret values, returning only structure and provenance. +withNoValues :: Bool -> Builder -> Builder +withNoValues v b = b { bNoValues = v } + +-- | The usable string: the file path for @as_path@ secrets, else the value. +-- 'Nothing' when no usable value is present (e.g. under 'withNoValues'). +get :: ResolvedSecret -> Maybe Text +get s = if secretAsPath s then secretPath s else secretValue s + +-- | Flat @name -> usable value@ map ('Nothing' encodes to JSON @null@), the +-- input for a quicktype-generated deserializer. See @secretspec schema@. +fields :: Resolved -> Map Text (Maybe Text) +fields = Map.map get . resolvedSecrets + +-- | 'fields' as a JSON byte string (a @{SECRET_NAME: value-or-null}@ object). +fieldsJson :: Resolved -> BL.ByteString +fieldsJson = encode . fields + +-- | Export each resolved secret into the process environment by its declared +-- name. Secrets with no usable value (e.g. under 'withNoValues') are skipped. +setAsEnv :: Resolved -> IO () +setAsEnv r = + forM_ (Map.toList (resolvedSecrets r)) $ \(name, secret) -> + case get secret of + -- System.Environment.setEnv treats setEnv name "" as unsetEnv name, which + -- would *delete* a secret that resolves to "" (e.g. `.env` line `FOO=` or + -- `default = ""`). System.Environment.Blank.setEnv with overwrite=True sets + -- the empty string, matching the Go/Python/Ruby/Node SDKs. + Just v -> Env.setEnv (T.unpack name) (T.unpack v) True + Nothing -> pure () + +-- | Remove the temp files backing any @as_path@ secrets in this result. The +-- resolver persists those files (mode 0400) so their paths stay valid after +-- resolve returns; the caller owns their lifetime. Call 'close' when done so the +-- secret files do not accumulate in the temp dir. A file already gone is ignored. +close :: Resolved -> IO () +close r = + forM_ (Map.elems (resolvedSecrets r)) $ \secret -> + case (secretAsPath secret, secretPath secret) of + (True, Just p) -> do + let fp = T.unpack p + exists <- doesFileExist fp + when exists (removeFile fp) + _ -> pure () + +-- | The ABI version reported by the loaded native library. +abiVersion :: IO Text +abiVersion = do + -- A static, library-owned string; do not free it. + c <- c_secretspec_abi_version + T.pack <$> peekCString c + +-- | Resolve the secrets. Throws 'MissingRequiredError' if a required secret is +-- missing, and 'SecretSpecError' for any other failure. +load :: Builder -> IO Resolved +load b = do + resp <- callNative (requestBytes b Nothing) + value <- responseValue resp resolveSchemaVersion "resolve" + (prov, prof, secs, mreq, mopt) <- fromResult (parseEither pResolve value) + case mreq of + [] -> pure (Resolved prov prof secs mopt) + xs -> throwIO (MissingRequiredError xs) + where + pResolve = withObject "response" $ \o -> + (,,,,) + <$> o .: "provider" + <*> o .: "profile" + <*> o .:? "secrets" .!= Map.empty + <*> o .:? "missing_required" .!= [] + <*> o .:? "missing_optional" .!= [] + +-- | Resolve a value-free 'Report' (the inventory\/preflight view, the same one +-- the CLI exposes as @check --json@). Unlike 'load', it does not throw when a +-- required secret is missing: that secret appears as a 'SecretReport' with +-- status @"missing_required"@. +report :: Builder -> IO Report +report b = do + resp <- callNative (requestBytes b (Just "report")) + value <- responseValue resp reportSchemaVersion "report" + (prov, prof, secs) <- fromResult (parseEither pReport value) + pure (Report prov prof secs) + where + pReport = withObject "response" $ \o -> + (,,) + <$> o .: "provider" + <*> o .: "profile" + <*> o .:? "secrets" .!= [] + +-- Build the request JSON for a resolve (@mode = Nothing@) or report +-- (@mode = Just "report"@), omitting unset options. +requestBytes :: Builder -> Maybe Text -> BL.ByteString +requestBytes b mode = + encode . object $ + catMaybes + [ ("path" .=) <$> bPath b + , ("provider" .=) <$> bProvider b + , ("profile" .=) <$> bProfile b + , ("reason" .=) <$> bReason b + ] + ++ ["no_values" .= True | bNoValues b] + ++ ["mode" .= m | Just m <- [mode]] + +-- Marshal a request to secretspec_resolve and copy the response out before +-- freeing the native allocation. +-- +-- The response is a Rust allocation the caller must free, and it carries secret +-- values. @mask@ keeps an async exception (e.g. a 'System.Timeout.timeout' +-- around 'load') from landing between the call returning and the free being +-- installed, and @finally@ guarantees the free runs whether @packCString@ +-- succeeds, throws, or is interrupted — so the secret-bearing buffer never leaks. +callNative :: BL.ByteString -> IO BS.ByteString +callNative reqLazy = + BS.useAsCString (BL.toStrict reqLazy) $ \creq -> + mask $ \restore -> do + cresp <- c_secretspec_resolve creq + if cresp == nullPtr + then throwIO (SecretSpecError "ffi" "secretspec_resolve returned null") + else restore (BS.packCString cresp) `finally` c_secretspec_free cresp + +-- Decode the envelope, unwrap @ok@/@error@, and check the schema version, +-- returning the response object as a 'Value' for the caller to project. +responseValue :: BS.ByteString -> Int -> Text -> IO Value +responseValue resp expectVer kind = do + env <- case eitherDecodeStrict resp :: Either String (Envelope Value) of + Left e -> throwIO (SecretSpecError "parse" (T.pack e)) + Right v -> pure v + if not (envOk env) + then case envError env of + Just (ErrInfo k m) -> throwIO (SecretSpecError k m) + Nothing -> throwIO (SecretSpecError "unknown" "") + else case envResponse env of + Nothing -> throwIO (SecretSpecError "ffi" "secretspec_resolve reported ok with no response") + Just value -> do + ver <- fromResult (parseEither (withObject "response" (.: "schema_version")) value) + unless (ver == expectVer) (throwIO (versionError ver expectVer kind)) + pure value + +versionError :: Int -> Int -> Text -> SecretSpecError +versionError got expected kind = + SecretSpecError "version" $ + T.concat + [ "unsupported ", kind, " schema version ", T.pack (show got) + , " (expected ", T.pack (show expected) + , "); the secretspec-ffi library and this SDK are out of sync" + ] + +fromResult :: Either String a -> IO a +fromResult = either (throwIO . SecretSpecError "parse" . T.pack) pure + +-- The response envelope shared by every native binding. +data Envelope a = Envelope + { envOk :: Bool + , envResponse :: Maybe a + , envError :: Maybe ErrInfo + } + +instance FromJSON a => FromJSON (Envelope a) where + parseJSON = withObject "Envelope" $ \o -> + Envelope <$> o .: "ok" <*> o .:? "response" <*> o .:? "error" + +data ErrInfo = ErrInfo Text Text + +instance FromJSON ErrInfo where + parseJSON = withObject "error" $ \o -> ErrInfo <$> o .: "kind" <*> o .: "message" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Unit + cross-language conformance tests for the Haskell SDK. The native +-- resolver is statically linked, so no loader path is needed -- stage the +-- archive alone and pass its transitive native deps: +-- +-- > cabal test --extra-lib-dirs="$DIR_WITH_ONLY_THE_A" \ +-- > --ghc-options=-optl-ldbus-1 ... # libs from `--print native-static-libs` +module Main (main) where + +import Control.Exception (SomeException, try) +import Control.Monad (filterM, forM) +import Data.Aeson (Value, eitherDecode, eitherDecodeStrict, object, + (.=)) +import qualified Data.Aeson.Key as Key +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.Function ((&)) +import Data.List (isInfixOf, isPrefixOf, sort) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified SecretSpec as S +import System.Directory (canonicalizePath, createDirectoryIfMissing, + doesDirectoryExist, findExecutable, + getTemporaryDirectory, listDirectory) +import System.Environment (lookupEnv) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath (()) +import System.Process (callProcess, readProcess) + +main :: IO () +main = do + fixturesDir <- canonicalizePath ("." ".." "conformance" "fixtures") + names <- listDirectory fixturesDir + fixtures <- filterM doesDirectoryExist (map (fixturesDir ) (sort names)) + + let tests = + [ ("abi_version_nonempty", testAbiVersion) + , ("missing_required_throws", testMissingRequired) + , ("codegen", testCodegen) + ] + ++ concatMap conformanceTests fixtures + + results <- mapM runOne tests + let failed = [name | (name, ok) <- results, not ok] + putStrLn "" + putStrLn (show (length results - length failed) ++ "/" ++ show (length results) ++ " passed") + if null failed + then exitSuccess + else putStrLn ("FAILED: " ++ unwords failed) >> exitFailure + +runOne :: (String, IO ()) -> IO (String, Bool) +runOne (name, act) = do + r <- try act :: IO (Either SomeException ()) + case r of + Right () -> putStrLn ("ok " ++ name) >> pure (name, True) + Left e -> putStrLn ("FAIL " ++ name ++ ": " ++ show e) >> pure (name, False) + +expect :: Bool -> String -> IO () +expect True _ = pure () +expect False msg = ioError (userError msg) + +-- Unit tests -------------------------------------------------------------- + +testAbiVersion :: IO () +testAbiVersion = do + v <- S.abiVersion + expect (not (T.null v)) "abi version was empty" + +testMissingRequired :: IO () +testMissingRequired = do + tmp <- getTemporaryDirectory + let dir = tmp "secretspec-hs-missing" + createDirectoryIfMissing True dir + writeFile (dir "secretspec.toml") $ + unlines + [ "[project]" + , "name = \"hs-missing\"" + , "revision = \"1.0\"" + , "" + , "[profiles.default]" + , "NEEDED = { description = \"x\", required = true }" + ] + writeFile (dir ".env") "" + r <- + try (S.load (fixtureBuilder dir)) :: + IO (Either S.MissingRequiredError S.Resolved) + case r of + Left _ -> pure () + Right _ -> ioError (userError "expected MissingRequiredError") + +-- End-to-end codegen: secretspec schema -> quicktype --lang haskell -> compile +-- the generated module and decode the SDK's own fieldsJson output with it, so +-- the schema -> fields() linkage is exercised, not just hand-written JSON. Skips +-- unless SECRETSPEC_BIN, npx, runghc, and a cabal-written GHC environment file +-- (so runghc sees aeson and the generated module's transitive imports) are all +-- present -- i.e. when run via `cabal test --write-ghc-environment-files=always` +-- with SECRETSPEC_BIN set, as scripts/ci-sdks.sh does. +testCodegen :: IO () +testCodegen = do + mbin <- lookupEnv "SECRETSPEC_BIN" + npx <- findExecutable "npx" + rghc <- findExecutable "runghc" + hasEnv <- any (isPrefixOf ".ghc.environment.") <$> listDirectory "." + case (mbin, npx, rghc, hasEnv) of + (Just bin, Just _, Just _, True) -> runCodegen bin + _ -> putStrLn " (skipped: needs SECRETSPEC_BIN, npx, runghc, and a ghc env file)" + +runCodegen :: FilePath -> IO () +runCodegen bin = do + tmp <- getTemporaryDirectory + let dir = tmp "secretspec-hs-codegen" + createDirectoryIfMissing True dir + writeFile (dir "secretspec.toml") $ + unlines + [ "[project]" + , "name = \"hs-codegen\"" + , "revision = \"1.0\"" + , "" + , "[profiles.default]" + , "DATABASE_URL = { required = true }" + , "LOG_LEVEL = { required = false, default = \"info\" }" + ] + writeFile (dir ".env") "DATABASE_URL=postgres://db\n" + + -- The SDK itself produces the flat fields JSON the generated decoder consumes, + -- so this exercises the real schema -> fields() linkage. + resolved <- + S.load + ( S.builder + & S.withPath (T.pack (dir "secretspec.toml")) + & S.withProvider (T.pack ("dotenv://" ++ (dir ".env"))) + & S.withReason "codegen" + ) + BL.writeFile (dir "fields.json") (S.fieldsJson resolved) + + callProcess bin ["-f", dir "secretspec.toml", "schema", "-o", dir "schema.json"] + callProcess + "npx" + [ "--yes", "quicktype", "-s", "schema", dir "schema.json" + , "--top-level", "SecretSpec", "--lang", "haskell" + , "--module", "Secrets", "-o", dir "Secrets.hs" + ] + writeFile (dir "Driver.hs") driverSource + + out <- readProcess "runghc" ["-i" ++ dir, dir "Driver.hs", dir "fields.json"] "" + expect ("codegen OK" `isInfixOf` out) ("unexpected driver output: " ++ out) + +-- A standalone program that decodes the SDK's fields JSON with the +-- quicktype-generated SecretSpec type, proving the generated code is usable. +driverSource :: String +driverSource = + unlines + [ "{-# LANGUAGE OverloadedStrings #-}" + , "import Secrets (SecretSpec(..), decodeTopLevel)" + , "import qualified Data.ByteString.Lazy as BL" + , "import System.Environment (getArgs)" + , "import System.Exit (exitFailure)" + , "main :: IO ()" + , "main = do" + , " [f] <- getArgs" + , " bytes <- BL.readFile f" + , " case decodeTopLevel bytes of" + , " Just s | databaseURLSecretSpec s == \"postgres://db\" -> putStrLn \"codegen OK\"" + , " _ -> exitFailure" + ] + +-- Conformance ------------------------------------------------------------- + +conformanceTests :: FilePath -> [(String, IO ())] +conformanceTests dir = + [ ("conformance:" ++ base, testConformance dir) + , ("conformance_no_values:" ++ base, testNoValues dir) + , ("conformance_report:" ++ base, testReport dir) + ] + where + base = lastSegment dir + +testConformance :: FilePath -> IO () +testConformance dir = do + resolved <- S.load (fixtureBuilder dir) + actual <- canonical resolved + expected <- readJson (dir "expected.json") + expect (actual == expected) (mismatch "expected.json" actual expected) + -- Remove any as_path temp files this value-carrying resolve materialized, so + -- repeated runs do not leave secret-bearing files behind in the temp dir. + S.close resolved + +-- Under no_values every SDK must emit the same all-null fields map: a +-- value-less secret serializes to null, not an empty string. +testNoValues :: FilePath -> IO () +testNoValues dir = do + resolved <- S.load (S.withNoValues True (fixtureBuilder dir)) + let actual = either error id (eitherDecode (S.fieldsJson resolved)) :: Value + expected <- readJson (dir "expected_no_values.json") + expect (actual == expected) (mismatch "expected_no_values.json" actual expected) + S.close resolved + +-- The value-free report (status + provenance) is identical across SDKs. +testReport :: FilePath -> IO () +testReport dir = do + rep <- S.report (fixtureBuilder dir) + let actual = canonicalReport rep + expected <- readJson (dir "expected_report.json") + expect (actual == expected) (mismatch "expected_report.json" actual expected) + +fixtureBuilder :: FilePath -> S.Builder +fixtureBuilder dir = + S.builder + & S.withPath (T.pack (dir "secretspec.toml")) + & S.withProvider (T.pack ("dotenv://" ++ (dir ".env"))) + & S.withReason "conformance" + +canonical :: S.Resolved -> IO Value +canonical r = do + entries <- + forM (Map.toList (S.resolvedSecrets r)) $ \(name, secret) -> do + value <- + if S.secretAsPath secret + then TIO.readFile (T.unpack (fromMaybe "" (S.secretPath secret))) + else pure (fromMaybe "" (S.secretValue secret)) + pure + ( Key.fromText name + .= object + [ "value" .= value + , "source" .= S.secretSource secret + , "as_path" .= S.secretAsPath secret + ] + ) + pure $ + object + [ "profile" .= S.resolvedProfile r + , "secrets" .= object entries + , "missing_required" .= ([] :: [Text]) + , "missing_optional" .= sort (S.resolvedMissingOptional r) + ] + +canonicalReport :: S.Report -> Value +canonicalReport rep = + object + [ "profile" .= S.reportProfile rep + , "secrets" + .= object + [ Key.fromText (S.srName s) + .= object + [ "status" .= S.srStatus s + , "required" .= S.srRequired s + , "as_path" .= S.srAsPath s + , "generated" .= S.srGenerated s + , "default_applied" .= S.srDefaultApplied s + , -- Present-or-not (not the path-dependent value) so the vector + -- is machine-independent yet still catches a dropped provider. + "source_provider" .= isJust (S.srSourceProvider s) + ] + | s <- S.reportSecrets rep + ] + ] + +readJson :: FilePath -> IO Value +readJson p = do + bytes <- BS.readFile p + either (ioError . userError) pure (eitherDecodeStrict bytes) + +mismatch :: String -> Value -> Value -> String +mismatch name actual expected = + name ++ " mismatch\n got: " ++ show actual ++ "\nwant: " ++ show expected + +lastSegment :: FilePath -> String +lastSegment = reverse . takeWhile (/= '/') . reverse