Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

[#39] String interpolation in coffer output messages #63

Merged
merged 1 commit into from
May 5, 2022
Merged

[#39] String interpolation in coffer output messages #63

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion .hlint.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@
# Settings
dcastro marked this conversation as resolved.
Show resolved Hide resolved
###########################################################################

- arguments: [-XTypeApplications, -XRecursiveDo, -XBlockArguments]
- arguments: [-XTypeApplications, -XRecursiveDo, -XBlockArguments, -XQuasiQuotes]

# These are just too annoying
- ignore: { name: Redundant do }
Expand Down
125 changes: 72 additions & 53 deletions app/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ import Coffer.Directory qualified as Dir
import Coffer.Path (EntryPath, Path, QualifiedPath(qpPath))
import Config (Config(..), configCodec)
import Control.Lens
import Control.Monad (forM, forM_, when)
import Control.Monad (forM_, when)
import Data.Maybe (fromMaybe)
import Data.Text (pack)
import Data.Text.IO qualified as TIO
Expand All @@ -26,6 +26,7 @@ import Polysemy
import Polysemy.Error (Error, errorToIOFinal)
import System.Environment (lookupEnv)
import System.Exit (die, exitFailure)
import Text.Interpolation.Nyan
import Toml qualified

runBackendIO
Expand Down Expand Up @@ -74,43 +75,52 @@ main = do
VREntry entry -> pprint $ buildDirectory $ Dir.singleton entry
VRField _ field -> pprint $ build $ field ^. E.contents
VRPathNotFound path -> pathNotFound path
VRDirectoryNoFieldMatch path fieldName -> printError $
"There are no entries at path '" +| path |+ "' with the field '" +| fieldName |+ "'."
VREntryNoFieldMatch path fieldName -> printError $
"The entry at '" +| path |+ "' does not have a field '" +| fieldName |+ "'."
VRDirectoryNoFieldMatch path fieldName -> printError [int|s|
There are no entries at path '#{path}' with the field '#{fieldName}'.
|]

VREntryNoFieldMatch path fieldName -> printError [int|s|
The entry at '#{path}' does not have a field '#{fieldName}'.
|]

SomeCommand cmd@(CmdCreate opts) -> do
runCommand config cmd >>= \case
CRSuccess _ -> printSuccess $ "Entry created at '" +| coQPath opts |+ "'."
CRSuccess _ -> printSuccess [int|s|Entry created at '#{coQPath opts}'.|]
CRCreateError error -> do
let errorMsg = createErrorToBuilder error
printError $ unlinesF @_ @Builder $ "The entry cannot be created:" : "" : [errorMsg]
printError [int|s|
The entry cannot be created:

#{errorMsg}
|]

SomeCommand cmd@(CmdSetField opts) -> do
let fieldName = sfoFieldName opts
runCommand config cmd >>= \case
SFREntryNotFound path -> entryNotFound path
SFRMissingFieldContents path -> printError $ unlinesF @_ @Builder
[ "The entry at '" +| path |+ "' does not yet have a field '" +| fieldName |+ "'."
, "In order to create a new field, please include the 'FIELDCONTENTS' argument."
]
SFRMissingFieldContents path -> printError [int|s|
The entry at '#{path}' does not yet have a field '#{fieldName}'.
In order to create a new field, please include the 'FIELDCONTENTS' argument.
|]
SFRSuccess qEntry -> do
let entry = qpPath qEntry
let qPath = view E.path <$> qEntry
let field = entry ^?! E.fields . ix fieldName
printSuccess $
"Set field '" +| fieldName |+
"' (" +| (field ^. E.visibility) |+
") at '" +| qPath |+
"' to:\n" +| (field ^. E.contents) |+ ""
printSuccess [int|s|
Set field '#{fieldName}' (#{field ^. E.visibility}) \
at '#{qPath}' to:
#{field ^. E.contents}
|]

SomeCommand cmd@(CmdDeleteField opts) -> do
runCommand config cmd >>= \case
DFREntryNotFound path -> entryNotFound path
DFRFieldNotFound fieldName -> printError $
"Entry does not have a field with name '" +| fieldName |+ "'."
DFRSuccess _ -> printSuccess $
"Deleted field '" +| dfoFieldName opts |+ "' from '" +| dfoQPath opts |+ "'."
DFRFieldNotFound fieldName -> printError [int|s|
Entry does not have a field with name '#{fieldName}'.
|]
DFRSuccess _ -> printSuccess [int|s|
Deleted field '#{dfoFieldName opts}' from '#{dfoQPath opts}'.
|]

SomeCommand cmd@CmdFind{} -> do
runCommand config cmd >>= \case
Expand All @@ -123,13 +133,17 @@ main = do
when (roDryRun opts) do
pprint "These actions would be done:"
forM_ copiedPaths \(from, to) ->
printSuccess $ "Renamed '" +| from |+ "' to '" +| to |+ "'."
printSuccess [int|s|Renamed '#{from}' to '#{to}'.|]
CPRPathNotFound path -> pathNotFound path
CPRMissingEntryName -> printError
"The destination path is not a valid entry path. Please specify the new name of the entry."
CPRCreateErrors errors -> do
errorMsgs <- buildErrorMessages errors
printError $ unlinesF @_ @Builder $ "The following entries cannot be renamed:" : "" : errorMsgs
let errorMsgs = buildErrorMessages errors
printError [int|s|
The following entries cannot be renamed:

#{unlinesF errorMsgs}
|]
CPRSamePath path -> samePaths path

SomeCommand cmd@(CmdCopy opts) -> do
Expand All @@ -138,39 +152,43 @@ main = do
when (cpoDryRun opts) do
pprint "These actions would be done:"
forM_ copiedPaths \(from, to) ->
printSuccess $ "Copied '" +| from |+ "' to '" +| to |+ "'."
printSuccess [int|s|Copied '#{from}' to '#{to}'.|]
CPRPathNotFound path -> pathNotFound path
CPRMissingEntryName -> printError
"The destination path is not a valid entry path. Please specify the new name of the entry."
CPRCreateErrors errors -> do
errorMsgs <- buildErrorMessages errors
printError $ unlinesF @_ @Builder $ "The following entries cannot be copied:" : "" : errorMsgs
let errorMsgs = buildErrorMessages errors
printError [int|s|
The following entries cannot be copied:

#{unlinesF errorMsgs}
|]
CPRSamePath path -> samePaths path

SomeCommand cmd@(CmdDelete opts) -> do
runCommand config cmd >>= \case
DRPathNotFound path -> pathNotFound path
DRDirectoryFound path -> printError $ unlinesF @_ @Builder
[ "The path '" +| path |+ "' is a directory."
, "Use '--recursive' or '-r' to recursively delete all entries."
]
DRDirectoryFound path -> printError [int|s|
The path '#{path}' is a directory.
Use '--recursive' or '-r' to recursively delete all entries.
|]
DRSuccess paths -> do
when (doDryRun opts) do
pprint "These actions would be done:"
forM_ paths \path ->
printSuccess $ "Deleted '" +| path |+ "'."
printSuccess [int|s|Deleted '#{path}'.|]

SomeCommand cmd@(CmdTag opts) -> do
runCommand config cmd >>= \case
TREntryNotFound path -> entryNotFound path
TRSuccess _ ->
if toDelete opts
then printSuccess $ "Removed tag '" +| toTagName opts |+ "' from '" +| toQPath opts |+ "'."
else printSuccess $ "Added tag '" +| toTagName opts |+ "' to '" +| toQPath opts |+ "'."
TRTagNotFound tag -> printError $
"Entry does not have the tag '" +| tag |+ "'."
TRDuplicateTag tag -> printError $
"Entry already has the tag '" +| tag |+ "'."
then printSuccess [int|s|Removed tag '#{toTagName opts}' from '#{toQPath opts}'.|]
else printSuccess [int|s|Added tag '#{toTagName opts}' to '#{toQPath opts}'.|]
TRTagNotFound tag -> printError
[int|s|Entry does not have the tag '#{tag}'.|]
TRDuplicateTag tag -> printError
[int|s|Entry already has the tag '#{tag}'.|]
where
-- | Pretty-print a message.
pprint :: Member (Embed IO) r => Builder -> Sem r ()
Expand All @@ -185,35 +203,36 @@ main = do
printError msg = embed $ die $ "[ERROR] " <> fmt msg

entryNotFound :: Member (Embed IO) r => QualifiedPath EntryPath -> Sem r ()
entryNotFound path = printError $ "Entry not found at '" +| path |+ "'."
entryNotFound path = printError [int|s|Entry not found at '#{path}'.|]

pathNotFound :: Member (Embed IO) r => QualifiedPath Path -> Sem r ()
pathNotFound path = printError $ "Entry or directory not found at '" +| path |+ "'."
pathNotFound path = printError [int|s|Entry or directory not found at '#{path}'.|]

samePaths :: Member (Embed IO) r => QualifiedPath Path -> Sem r ()
samePaths path =
printError $ "'" +| path |+ "' and '" +| path |+ "' are the same path."
printError [int|s|'#{path}' and '#{path}' are the same path.|]

createErrorToBuilder :: CreateError -> Builder
createErrorToBuilder = \case
CEEntryAlreadyExists entryPath -> unlinesF @_ @Builder
[ "An entry already exists at '" +| entryPath |+ "'."
, "Use '--force' or '-f' to overwrite existing entries."
]
CEDestinationIsDirectory entryPath -> "'" +| entryPath |+ "' is a directory."
CEEntryAlreadyExists entryPath -> [int|s|
An entry already exists at '#{entryPath}'.
Use '--force' or '-f' to overwrite existing entries.
|]
CEDestinationIsDirectory entryPath -> [int|s|'#{entryPath}' is a directory.|]
CEParentDirectoryIsEntry (_, clashed) ->
"Attempted to create the directory '" +| clashed |+ "' but an entry exists at that path."
[int|s|Attempted to create the directory '#{clashed}' but an entry exists at that path.|]

getEntryFromCreateError :: CreateError -> QualifiedPath EntryPath
getEntryFromCreateError = \case
CEParentDirectoryIsEntry (entryPath, _) -> entryPath
CEDestinationIsDirectory entryPath -> entryPath
CEEntryAlreadyExists entryPath -> entryPath

buildErrorMessages :: [(QualifiedPath EntryPath, CreateError)] -> Sem r [Builder]
buildErrorMessages errors = do
forM errors \(from, err) -> do
let entryPath = getEntryFromCreateError err
let header = "'" +| from |+ "' to '" +| entryPath |+ "':"
let errorMsg = createErrorToBuilder err
pure $ unlinesF @_ @Builder $ header : [indentF 2 errorMsg]
buildErrorMessages :: [(QualifiedPath EntryPath, CreateError)] -> [Builder]
buildErrorMessages =
fmap \(from, err) ->
let
entryPath = getEntryFromCreateError err
header = [int|s|'#{from}' to '#{entryPath}':|]
errorMsg = createErrorToBuilder err
in unlinesF @_ @Builder $ header : [indentF 2 errorMsg]
2 changes: 2 additions & 0 deletions cabal.project.freeze
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1713,6 +1713,8 @@ constraints: any.AC-Angle ==1.0,
any.nvim-hs ==2.1.0.4,
any.nvim-hs-contrib ==2.0.0.0,
any.nvim-hs-ghcid ==2.0.0.0,
any.nyan-interpolation ==0.9,
any.nyan-interpolation-core ==0.9.0.1,
any.o-clock ==1.2.1,
any.oauthenticated ==0.2.1.0,
any.odbc ==0.2.5,
Expand Down
2 changes: 2 additions & 0 deletions coffer.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -106,6 +106,7 @@ library
, lens-aeson
, megaparsec
, mtl
, nyan-interpolation
, optparse-applicative
, polysemy
, servant
Expand Down Expand Up @@ -181,6 +182,7 @@ executable coffer
, coffer
, fmt
, lens
, nyan-interpolation
, optparse-applicative
, polysemy
, text
Expand Down
61 changes: 31 additions & 30 deletions lib/Backend/Vault/Kv.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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

Expand All @@ -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
Expand Down
Loading