diff --git a/app/Main.hs b/app/Main.hs index 02bbf5f2..c164ee89 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,28 +7,27 @@ module Main where import Backend import Backend.Commands as Commands import Backend.Interpreter -import Control.Lens -import Control.Monad (forM_, when) -import Data.Text (pack) -import Data.Text.IO qualified as TIO -import Fmt -import Options.Applicative (execParser) -import Polysemy -import Polysemy.Error (Error, errorToIOFinal) -import System.Exit (die, exitFailure) -import Toml qualified - import CLI.Parser import CLI.PrettyPrint import CLI.Types import Coffer.Directory qualified as Dir import Coffer.Path (EntryPath, Path, QualifiedPath(qpPath)) import Config (Config(..), configCodec) +import Control.Lens +import Control.Monad (forM_, when) import Data.Maybe (fromMaybe) +import Data.Text (pack) +import Data.Text.IO qualified as TIO import Entry qualified as E import Error +import Fmt +import Options.Applicative (execParser) +import Polysemy +import Polysemy.Error (Error, errorToIOFinal) import System.Environment (lookupEnv) +import System.Exit (die, exitFailure) import Text.Interpolation.Nyan +import Toml qualified runBackendIO :: Sem '[BackendEffect, Error CofferError, Embed IO, Final IO ] a diff --git a/coffer.cabal b/coffer.cabal index c7bc1976..172125a5 100644 --- a/coffer.cabal +++ b/coffer.cabal @@ -106,6 +106,7 @@ library , lens-aeson , megaparsec , mtl + , nyan-interpolation , optparse-applicative , polysemy , servant diff --git a/lib/Backend/Vault/Kv.hs b/lib/Backend/Vault/Kv.hs index 5a67c618..e7f07be9 100644 --- a/lib/Backend/Vault/Kv.hs +++ b/lib/Backend/Vault/Kv.hs @@ -31,7 +31,7 @@ import Data.Time (UTCTime) import Entry (Entry, Field, FieldContents(FieldContents), FieldName, FieldVisibility) import Entry qualified as E import Error (BackendError, CofferError(..)) -import Fmt (Buildable(build), Builder, indentF, unlinesF, (+|), (|+)) +import Fmt (Buildable(build)) import GHC.Generics (Generic) import Network.HTTP.Client (defaultManagerSettings, newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) @@ -42,6 +42,7 @@ import Servant.Client (BaseUrl(BaseUrl), ClientEnv, ClientError(..), Scheme(Http, Https), mkClientEnv, parseBaseUrl, showBaseUrl) import Servant.Client.Core.Response (responseStatusCode) +import Text.Interpolation.Nyan import Toml (TomlCodec, (.=)) import Toml qualified @@ -64,41 +65,41 @@ data VaultError instance Buildable VaultError where build = \case ServantError (FailureResponse request response) -> - unlinesF @_ @Builder - [ "Request:" - , indentF 2 ((build . show) request) - , "failed with response:" - , indentF 2 ((build . show) response) - ] + [int|s| + Request: + #{show request} + failed with response: + #{show response} + |] ServantError (DecodeFailure body response) -> - unlinesF @_ @Builder - [ "The body could not be decoded at the expected type." - , "Body: " <> build body - , "Response:" - , indentF 2 ((build . show) response) - ] + [int|s| + The body could not be decoded at the expected type. + Body: #{body} + Response: + #{show response} + |] ServantError (UnsupportedContentType mediatype response) -> - unlinesF @_ @Builder - [ "The content-type '" <> (build . show) mediatype <> "' of the response is not supported." - , "Response:" - , indentF 2 ((build . show) response) - ] + [int|s| + The content-type '#{show mediatype}' of the response is not supported. + Response: + #{show response} + |] ServantError (InvalidContentTypeHeader response) -> - unlinesF @_ @Builder - [ "The content-type header is invalid." - , "Response:" - , indentF 2 ((build . show) response) - ] + [int|s| + The content-type header is invalid. + Response: + #{show response} + |] ServantError (ConnectionError exception) -> - unlinesF @_ @Builder - [ "Connection error. No response was received." - , (build . show) exception - ] + [int|s| + Connection error. No response was received. + #{show exception} + |] FieldMetadataNotFound entryPath fieldName -> - "Could not find coffer metadata for field '" +| fieldName - |+ "' at '" +| entryPath |+ "'" + [int|s|Could not find coffer metadata for field \ + '#{fieldName}' at '#{entryPath}'|] CofferSpecialsNotFound entryPath -> - "Could not find key '#$coffer' in the kv entry at '" +| entryPath |+ "'." + [int|s|Could not find key '#$coffer' in the kv entry at '#{entryPath}'.|] BadCofferSpecialsError err -> build err instance BackendError VaultError diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index 481e307e..2759f72e 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -35,6 +35,7 @@ import Entry import Fmt (pretty) import Options.Applicative import Options.Applicative.Help.Pretty qualified as Pretty +import Text.Interpolation.Nyan import Text.Megaparsec (try) import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P @@ -60,11 +61,11 @@ parser = Options [ long "config" , short 'c' , metavar "CONFIG" - , help $ unlines - [ "Specify config file path." - , "When this option is not set, the 'COFFER_CONFIG' environment variable will be used." - , "When neither is set, it will default to 'config.toml'." - ] + , help [int|s| + Specify config file path. + When this option is not set, the 'COFFER_CONFIG' environment variable will be used. + When neither is set, it will default to 'config.toml'. + |] ] commandParser :: Parser SomeCommand @@ -401,11 +402,10 @@ readQualifiedPath = do [pathStr] -> do path <- readPath' pathStr pure $ QualifiedPath Nothing path - _ -> - Left $ unlines - [ "Invalid qualified path format: " <> show input <> "." - , show expectedQualifiedPathFormat - ] + _ -> Left [int|s| + Invalid qualified path format: #{show input}. + #{show expectedQualifiedPathFormat} + |] readFieldContents :: ReadM FieldContents readFieldContents = str <&> FieldContents @@ -413,13 +413,14 @@ readFieldContents = str <&> FieldContents readFieldInfo :: ReadM FieldInfo readFieldInfo = do eitherReader \input -> - P.parse (parseFieldInfo <* P.eof) "" (T.pack input) & first \err -> unlines - [ "Invalid field format: " <> show input <> "." - , "Expected format: 'fieldname=fieldcontents'." - , "" - , "Parser error:" - , P.errorBundlePretty err - ] + P.parse (parseFieldInfo <* P.eof) "" (T.pack input) & first \err -> + [int|s| + Invalid field format: #{show input}. + Expected format: 'fieldname=fieldcontents'. + + Parser error: + #{P.errorBundlePretty err} + |] readSort :: ReadM (Sort, Direction) readSort = do @@ -430,28 +431,28 @@ readSort = do case means of "name" -> pure (SortByEntryName, direction') "date" -> pure (SortByEntryDate, direction') - _ -> Left $ unlines - [ "Invalid sort: " <> show means <> "." - , "Choose one of: 'name', 'date'." - , "" - , show expectedSortFormat - ] + _ -> Left [int|s| + Invalid sort: #{show means}. + Choose one of: 'name', 'date'. + + #{show expectedSortFormat} + |] [fieldName, means, direction] -> do fieldName' <- readFieldName' fieldName direction' <- readDirection direction case means of "contents" -> pure (SortByFieldContents fieldName', direction') "date" -> pure (SortByFieldDate fieldName', direction') - _ -> Left $ unlines - [ "Invalid sort: " <> show means <> "." - , "Choose one of: 'contents', 'date'." - , "" - , show expectedSortFormat - ] - _ -> Left $ unlines - [ "Invalid sort format: " <> show input <> "." - , show expectedSortFormat - ] + _ -> Left [int|s| + Invalid sort: #{show means}. + Choose one of: 'contents', 'date'. + + #{show expectedSortFormat} + |] + _ -> Left [int|s| + Invalid sort format: #{show input}. + #{show expectedSortFormat} + |] expectedSortFormat :: Pretty.Doc expectedSortFormat = Pretty.vsep @@ -474,13 +475,14 @@ readDirection = readFilter :: ReadM Filter readFilter = do eitherReader \input -> - P.parse (parseFilter <* P.eof) "" (T.pack input) & first \err -> unlines - [ "Invalid filter format: " <> show input <> "." - , show expectedFilterFormat - , "" - , "Parser error:" - , P.errorBundlePretty err - ] + P.parse (parseFilter <* P.eof) "" (T.pack input) & first \err -> + [int|s| + Invalid filter format: #{show input}. + #{show expectedFilterFormat} + + Parser error: + #{P.errorBundlePretty err} + |] expectedQualifiedEntryPathFormat :: Pretty.Doc expectedQualifiedEntryPathFormat = Pretty.vsep @@ -624,10 +626,10 @@ readSum sumDescription constructors input = case M.lookup input constructors of Just cons -> Right cons Nothing -> - Left $ unlines - [ "Invalid " <> sumDescription <> ": '" <> input <> "'." - , "Choose one of: " <> constructorNames <> "." - ] + Left [int|s| + Invalid #{sumDescription}: '#{input}'. + Choose one of: #{constructorNames}. + |] where constructorNames :: String constructorNames = diff --git a/lib/Error.hs b/lib/Error.hs index fbaae18e..710d3a2b 100644 --- a/lib/Error.hs +++ b/lib/Error.hs @@ -12,7 +12,8 @@ import BackendName (BackendName) import Coffer.Path (EntryPath, Path) import Data.Text (Text) import Entry (BadEntryTag, BadFieldName) -import Fmt (Buildable(build), Builder, pretty, unlinesF, (+|), (|+)) +import Fmt (Buildable(build)) +import Text.Interpolation.Nyan -- | GADT for coffer internal errors. -- It is backend-agnostic, so it doesn't know about specific backend errors. @@ -35,36 +36,36 @@ data InternalCommandsError instance Buildable InternalCommandsError where build = \case InvalidEntry entry -> - unlinesF @_ @Builder - [ "Backend returned a secret that is not a valid\ - \ entry or directory name." - , "Got: '" +| entry |+ "'." - ] + [int|s| + Backend returned a secret that is not a valid \ + entry or directory name. + Got: '#{entry}'. + |] EntryPathDoesntHavePrefix entryPath path -> - unlinesF @_ @Builder - [ "Expected path: '" <> pretty entryPath <> "'" - , "To have the prefix: '" <> pretty path <> "'" - ] + [int|s| + Expected path: '#{entryPath}' + To have the prefix: '#{path}' + |] instance Buildable CofferError where build = \case BackendError err -> - unlinesF @_ @Builder - [ "Internal backend error:" - , build err - ] + [int|s| + Internal backend error: + #{err} + |] InternalCommandsError err -> - unlinesF @_ @Builder - [ "Internal error:" - , build err - ] + [int|s| + Internal error: + #{err} + |] BackendNotFound backendName -> - "Backend with name '" <> build backendName <> "' not found." + [int|s|Backend with name '#{backendName}' not found.|] BadFieldNameError err -> build err BadMasterFieldName name err -> - unlinesF @_ @Builder - [ "Attempted to create new field name from '" +| name |+ "'" - , "" - , build err - ] + [int|s| + Attempted to create new field name from '#{name}' + + #{err} + |] BadEntryTagError err -> build err diff --git a/package.yaml b/package.yaml index 5c3f037e..6bb320d6 100644 --- a/package.yaml +++ b/package.yaml @@ -101,6 +101,7 @@ library: - lens-aeson - megaparsec - mtl + - nyan-interpolation - optparse-applicative - polysemy - servant