Skip to content

Commit

Permalink
[#39] String interpolation in coffer output messages
Browse files Browse the repository at this point in the history 
Problem: at this moment constructing some messages in `Main.hs`
looks very convoluted (e.g. message in `set-field` command).

Solution: used `nyan-interpolation` package in `Main.hs`.
  • Loading branch information
@DK318
DK318 committed May 5, 2022
1 parent 05844ec commit 0608ae9
Show file tree
Hide file tree
Showing 11 changed files with 200 additions and 155 deletions.
2 changes: 1 addition & 1 deletion .hlint.yaml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@
# Settings
###########################################################################

- 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
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
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
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
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

0 comments on commit 0608ae9

Please sign in to comment.