From 5359cd2afb4aa072a7c9eb5449497061c9b3eeac Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Fri, 11 Feb 2022 11:35:16 +0000 Subject: [PATCH 1/7] Add editor mode --- app/Main.hs | 7 +- coffer.cabal | 13 +++ lib/CLI/EditorMode.hs | 164 ++++++++++++++++++++++++++++++ lib/CLI/Parser.hs | 66 ++++++++++-- lib/CLI/Types.hs | 2 +- package.yaml | 12 ++- tests/test/Test/CLI/EditorMode.hs | 150 +++++++++++++++++++++++++++ tests/test/Test/Util.hs | 103 +++++++++++++++++++ 8 files changed, 507 insertions(+), 10 deletions(-) create mode 100644 lib/CLI/EditorMode.hs create mode 100644 tests/test/Test/CLI/EditorMode.hs create mode 100644 tests/test/Test/Util.hs diff --git a/app/Main.hs b/app/Main.hs index 496a8a1e..769e9a72 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,6 +7,7 @@ module Main where import Backend import Backend.Commands as Commands import Backend.Interpreter +import CLI.EditorMode import CLI.Parser import CLI.PrettyPrint import CLI.Types @@ -79,7 +80,11 @@ main = do VREntryNoFieldMatch path fieldName -> printError $ "The entry at '" +| path |+ "' does not have a field '" +| fieldName |+ "'." - SomeCommand cmd@(CmdCreate opts) -> do + SomeCommand (CmdCreate opts) -> do + cmd <- CmdCreate <$> + if coEdit opts + then embed (editorMode opts) + else pure opts runCommand config cmd >>= \case CRSuccess _ -> printSuccess $ "Entry created at '" +| coQPath opts |+ "'." CRCreateError error -> do diff --git a/coffer.cabal b/coffer.cabal index cb9cbf2d..514db484 100644 --- a/coffer.cabal +++ b/coffer.cabal @@ -26,6 +26,7 @@ library Backend.Vault.Kv.Internal BackendName Backends + CLI.EditorMode CLI.Parser CLI.PrettyPrint CLI.Types @@ -102,15 +103,18 @@ library , http-client , http-client-tls , http-types + , interpolate , lens , lens-aeson , megaparsec , mtl , optparse-applicative , polysemy + , process , servant , servant-client , servant-client-core + , temporary , text , time , time-compat @@ -255,6 +259,8 @@ test-suite test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Test.CLI.EditorMode + Test.Util Tree Paths_coffer hs-source-dirs: @@ -314,5 +320,12 @@ test-suite test tasty-discover:tasty-discover build-depends: base >=4.14.3.0 && <5 + , coffer + , hedgehog + , megaparsec + , raw-strings-qq , tasty + , tasty-hedgehog + , tasty-hunit + , text default-language: Haskell2010 diff --git a/lib/CLI/EditorMode.hs b/lib/CLI/EditorMode.hs new file mode 100644 index 00000000..f744b201 --- /dev/null +++ b/lib/CLI/EditorMode.hs @@ -0,0 +1,164 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module CLI.EditorMode where + +import CLI.Parser (parseEditorFile) +import CLI.Types +import Coffer.Path (EntryPath, QualifiedPath(qpPath)) +import Control.Lens +import Data.Foldable (foldl') +import Data.Maybe (fromMaybe) +import Data.String.Interpolate (i) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import Entry (FieldValue(unFieldValue)) +import Entry qualified as E +import Fmt (pretty) +import System.Environment (lookupEnv) +import System.IO (SeekMode(AbsoluteSeek), hFlush, hGetContents, hPutStr, hSeek) +import System.IO.Temp +import System.Process as Process +import Text.Megaparsec (ParseError, ParseErrorBundle, PosState) +import Text.Megaparsec qualified as P + +data AnnotatedLine = AnnotatedLine + { _alLine :: Text + , _alErrors :: [Text] + } + +makeLenses 'AnnotatedLine + +-- TODO: tags + +editorFileHeader :: EntryPath -> Text +editorFileHeader path = T.pack + [i|### Fields for '#{pretty path :: Text}' +### +### Examples: +### +### username = John Doe +### address = """ +### 123 Main Street +### Anytown +### """ +|] + +renderEditorFile :: EntryPath -> [FieldInfo] -> [FieldInfo] -> Text +renderEditorFile path fields privateFields = T.pack + [i|#{editorFileHeader path} +[Public fields] +#{T.unlines $ displayField <$> fields} +[Private fields] +#{T.unlines $ displayField <$> privateFields} +|] + where + displayField field = E.getFieldKey (fiName field) <> " = " <> displayFieldContents (unFieldValue . fiContents $ field) + + displayFieldContents contents = + -- If the field contents contain newline characters, + -- display them in multiple lines and wrapped with triple quotes. + if T.isInfixOf "\n" contents + then "\"\"\"\n" <> contents <> "\n\"\"\"" + else contents + +editorMode :: CreateOptions -> IO CreateOptions +editorMode opts = do + editorEnvVar <- lookupEnv "EDITOR" <&> fromMaybe "vi" + let entryPath = (qpPath . coQPath) opts + + let + go :: Text -> IO CreateOptions + go editorFileContents = do + withSystemTempFile "coffer" \fpath fhandle -> do + -- Write fields to temp file. + hPutStr fhandle $ T.unpack editorFileContents + hFlush fhandle + + -- Launch editor. + -- Note: The "editor" env variable may contain options/switches (e.g. `code --wait`), + -- so we have to split those. + let editorName = editorEnvVar ^?! to words . _head + let editorArgs = editorEnvVar ^?! to words . _tail <> [fpath] + putStrLn "Launching editor..." + Process.callProcess editorName editorArgs + + -- Read temp file. + hSeek fhandle AbsoluteSeek 0 + editorFileContents' <- T.pack <$> hGetContents fhandle + + -- Parse temp file contents. + case P.parse parseEditorFile fpath editorFileContents' of + Right (public, private) -> + pure opts + { coFields = public + , coPrivateFields = private + } + Left err -> do + putStrLn "Failed to parse file." + putStrLn $ P.errorBundlePretty err + + go $ editorFileContents' + & annotateEditorFile err -- Add annotations for parsing errors + & removeComments -- Remove parsing errors from previous attempts + & renderAnnotatedLines + & mappend (editorFileHeader entryPath) + + go $ renderEditorFile entryPath (coFields opts) (coPrivateFields opts) + +-- | Remove all lines that begin with `#`. +removeComments :: [AnnotatedLine] -> [AnnotatedLine] +removeComments als = + als & filter (\al -> al ^? alLine . _head /= Just '#') + +renderAnnotatedLines :: [AnnotatedLine] -> Text +renderAnnotatedLines als = + als + <&> (\al -> T.intercalate "\n" (al ^. alLine : al ^. alErrors)) + & T.unlines + +{- | For each error in the bunddle, adds a note with the parsing error +next to the offending line. E.g.: + +> pw 1234 +> # ^ +> # unexpected '1' +> # expecting '=' or white space +-} +annotateEditorFile :: ParseErrorBundle Text Void -> Text -> [AnnotatedLine] +annotateEditorFile bundle fileContents = + fileContents + & T.lines + -- Adding an extra empty line at the end. + -- If a parsing error occurs at EOF, we can annotate this line. + & (++ [""]) + <&> mkAnnotatedLine + & annotateLines bundle + where + mkAnnotatedLine :: Text -> AnnotatedLine + mkAnnotatedLine t = AnnotatedLine t [] + + annotateLines :: ParseErrorBundle Text Void -> [AnnotatedLine] -> [AnnotatedLine] + annotateLines bundle lines = + fst $ + foldl' annotateLine + (lines, P.bundlePosState bundle) + (P.bundleErrors bundle) + + -- | Finds the offending line, and adds one annotation with the parser error. + annotateLine :: ([AnnotatedLine], PosState Text) -> ParseError Text Void -> ([AnnotatedLine], PosState Text) + annotateLine (lines, posState) err = (lines', posState') + where + (_, posState') = P.reachOffset (P.errorOffset err) posState + lineNumber = P.unPos (P.sourceLine $ P.pstateSourcePos posState') - 1 + columnNumber = P.unPos (P.sourceColumn $ P.pstateSourcePos posState') - 1 + errMsg = + err + & P.parseErrorTextPretty + & T.pack + & T.lines + <&> mappend "# " + caretLine = "#" <> T.replicate (columnNumber - 1) " " <> "^" + lines' = lines & ix lineNumber . alErrors <>~ (caretLine : errMsg) diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index be3a2d45..f84b718c 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -5,7 +5,11 @@ {-# LANGUAGE OverloadedLists #-} module CLI.Parser - ( parserInfo + ( -- * optparse-applicative + parserInfo + -- * Megaparsec + , MParser + , parseEditorFile ) where import BackendName (BackendName, newBackendName) @@ -36,7 +40,7 @@ import Options.Applicative import Options.Applicative.Help.Pretty qualified as Pretty import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P -import Text.Megaparsec.Char.Lexer qualified as P +import Text.Megaparsec.Char.Lexer qualified as Lexer {-# ANN module ("HLint: ignore Use <$>" :: Text) #-} @@ -419,7 +423,7 @@ readFieldValue = str <&> FieldValue readFieldInfo :: ReadM FieldInfo readFieldInfo = do eitherReader \input -> - P.parse (parseFieldInfo <* P.eof) "" (T.pack input) & first \err -> unlines + P.parse (parseFieldInfo parseFieldContentsEof <* P.eof) "" (T.pack input) & first \err ->unlines [ "Invalid field format: " <> show input <> "." , "Expected format: 'fieldname=fieldcontents'." , "" @@ -543,7 +547,7 @@ type MParser = P.Parsec Void Text -- * @YYYY-MM-DD HH:MM:SS@ parseFilterDate :: MParser FilterDate parseFilterDate = do - y <- P.decimal + y <- Lexer.decimal optional (P.char '-') >>= \case Nothing -> pure $ FDYear y Just _ -> do @@ -618,11 +622,11 @@ parseFilterField = do localTime <- parseFilterDate pure $ FilterFieldByDate op localTime -parseFieldInfo :: MParser FieldInfo -parseFieldInfo = do +parseFieldInfo :: MParser FieldValue -> MParser FieldInfo +parseFieldInfo fieldContentsParser = do fieldName <- parseFieldNameWhile \c -> c /= '=' && not (Char.isSpace c) P.hspace >> P.char '=' >> P.hspace - fieldContents <- parseFieldContentsEof + fieldContents <- fieldContentsParser pure $ FieldInfo fieldName fieldContents parseFieldNameWhile :: (Char -> Bool) -> MParser FieldKey @@ -634,6 +638,54 @@ parseFieldNameWhile whileCond = do parseFieldContentsEof :: MParser FieldValue parseFieldContentsEof = FieldValue . T.pack <$> P.manyTill P.anySingle P.eof +-- | Parse the rest of the line as a field content. +parseFieldContentsSingleLine :: MParser FieldValue +parseFieldContentsSingleLine = FieldValue . T.pack <$> P.manyTill P.anySingle endOfLineOrFile + +-- | Parse a field content wrapped in triple quotes @"""@. E.g.: +-- +-- > """ +-- > line1 +-- > line2 +-- > """ +parseFieldContentsTripleQuotes :: MParser FieldValue +parseFieldContentsTripleQuotes = do + let beginBlock = tripleQuote >> void P.eol + let parseLine = P.manyTill P.anySingle P.eol + let endBlock = tripleQuote >> endOfLineOrFile + + res <- beginBlock >> P.manyTill parseLine endBlock + pure $ res <&> T.pack & T.intercalate "\n" & FieldValue + + where + tripleQuote :: MParser () + tripleQuote = void $ P.string "\"\"\"" + +parseEditorFile :: MParser ([FieldInfo], [FieldInfo]) +parseEditorFile = do + let parseFieldInfo' = parseFieldInfo (parseFieldContentsTripleQuotes <|> parseFieldContentsSingleLine) <* spaceConsumer + + spaceConsumer >> P.string "[Public fields]" >> spaceConsumer + publicFields <- many (P.notFollowedBy (P.char '[') >> parseFieldInfo') + spaceConsumer >> P.string "[Private fields]" >> spaceConsumer + privateFields <- many parseFieldInfo' + P.space >> P.eof + pure (publicFields, privateFields) + where + comment :: MParser () + comment = Lexer.skipLineComment "#" + + -- | Skip empty lines and comments. + spaceConsumer :: MParser () + spaceConsumer = Lexer.space + (void $ P.try $ P.hspace >> P.eol) + comment + empty + +-- | Matches on @eol@ or @eof@. +endOfLineOrFile :: MParser () +endOfLineOrFile = void P.eol <|> P.eof + ---------------------------------------------------------------------------- -- Utils ---------------------------------------------------------------------------- diff --git a/lib/CLI/Types.hs b/lib/CLI/Types.hs index 97cfbc49..95398742 100644 --- a/lib/CLI/Types.hs +++ b/lib/CLI/Types.hs @@ -167,7 +167,7 @@ data FieldInfo = FieldInfo { fiName :: FieldKey , fiContents :: FieldValue } - deriving stock Show + deriving stock (Show, Eq) data Direction = Asc | Desc deriving stock Show diff --git a/package.yaml b/package.yaml index a27623ae..e2e639d9 100644 --- a/package.yaml +++ b/package.yaml @@ -91,21 +91,23 @@ library: - ansi-terminal - containers - extra - - extra - fmt - hashable - http-client - http-client-tls - http-types + - interpolate - lens - lens-aeson - megaparsec - mtl - optparse-applicative - polysemy + - process - servant - servant-client - servant-client-core + - temporary - text - time - time-compat @@ -134,7 +136,15 @@ tests: ghc-options: - -threaded dependencies: + - coffer + - hedgehog + - megaparsec + - raw-strings-qq - tasty + - tasty-hedgehog + - tasty-hunit + - text + doctests: source-dirs: tests/doctests main: Doctests.hs diff --git a/tests/test/Test/CLI/EditorMode.hs b/tests/test/Test/CLI/EditorMode.hs new file mode 100644 index 00000000..4e70d7c1 --- /dev/null +++ b/tests/test/Test/CLI/EditorMode.hs @@ -0,0 +1,150 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module Test.CLI.EditorMode where + +import CLI.EditorMode (renderEditorFile) +import CLI.Parser +import CLI.Types (FieldInfo(..)) +import Entry (newFieldKey) +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Test.Util +import Text.RawString.QQ (r) + +hprop_render_parse_roundtrip :: Property +hprop_render_parse_roundtrip = property $ do + entryPath <- forAll genEntryPath + publicFields <- forAll $ Gen.list (Range.linear 0 5) genFieldInfo + privateFields <- forAll $ Gen.list (Range.linear 0 5) genFieldInfo + + let rendered = renderEditorFile entryPath publicFields privateFields + hparserShouldSucceed parseEditorFile rendered (publicFields, privateFields) + +unit_parse_editor_file :: IO () +unit_parse_editor_file = do + parserShouldSucceed parseEditorFile + [r| + +# comment1 +[Public fields] + +# comment2 +field1 = f1 + +# comment3 +field2=f2 + +field3 = + +field4 = """ +first line: + second line + third line + +""" + +field5 = Γ’Π”πŸ˜±πŸ‘ͺζ—₯本 + +[Private fields] + +# comment4 +privatefield1 = pf1 +# comment5 +privatefield2 = pf2 + + |] + ( [ FieldInfo (unsafeFromRight $ newFieldKey "field1") "f1" + , FieldInfo (unsafeFromRight $ newFieldKey "field2") "f2" + , FieldInfo (unsafeFromRight $ newFieldKey "field3") "" + , FieldInfo (unsafeFromRight $ newFieldKey "field4") "first line:\n second line\n third line\n" + , FieldInfo (unsafeFromRight $ newFieldKey "field5") "Γ’Π”πŸ˜±πŸ‘ͺζ—₯本" + ] + , [ FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") "pf1" + , FieldInfo (unsafeFromRight $ newFieldKey "privatefield2") "pf2" + + ] + ) + +unit_parses_file_without_trailing_newline :: IO () +unit_parses_file_without_trailing_newline = do + parserShouldSucceed parseEditorFile + [r|[Public fields] +[Private fields]|] + ( [] + , [] + ) + + parserShouldSucceed parseEditorFile + [r|[Public fields] +[Private fields] +privatefield1=pf1|] + ( [] + , [ FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") "pf1" + ] + ) + + parserShouldSucceed parseEditorFile + [r|[Public fields] +[Private fields] +privatefield1=""" +pf1 +"""|] + ( [] + , [ FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") "pf1" + ] + ) + +unit_parse_minimal_editor_file :: IO () +unit_parse_minimal_editor_file = do + parserShouldSucceed parseEditorFile + [r|[Public fields] +[Private fields]|] + ( [] + , [] + ) + +unit_fieldname_and_fieldcontents_must_be_on_the_same_line :: IO () +unit_fieldname_and_fieldcontents_must_be_on_the_same_line = do + parserShouldFail parseEditorFile + [r|[Public fields] +name = + contents +[Private fields]|] + + [r|3:1: + | +3 | contents + | ^^^^^^^^^^^ +unexpected " contents[Priv" +expecting "[Private fields]" or fieldname +|] + +unit_fieldname_must_be_0_indented :: IO () +unit_fieldname_must_be_0_indented = do + parserShouldFail parseEditorFile + [r|[Public fields] +name1 = contents1 + name2 = contents2 +[Private fields]|] + [r|3:1: + | +3 | name2 = contents2 + | ^^^^^^^^^^^^^^^^ +unexpected " name2 = conten" +expecting "[Private fields]" or fieldname +|] + + parserShouldFail parseEditorFile + [r|[Public fields] + name = contents +[Private fields]|] + [r|2:1: + | +2 | name = contents + | ^^^^^^^^^^^^^^^^ +unexpected " name = content" +expecting "[Private fields]" or fieldname +|] diff --git a/tests/test/Test/Util.hs b/tests/test/Test/Util.hs new file mode 100644 index 00000000..4f2984a3 --- /dev/null +++ b/tests/test/Test/Util.hs @@ -0,0 +1,103 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module Test.Util + ( unsafeFromRight + + -- * hunit helpers + , parserShouldSucceed + , parserShouldFail + + -- * hedgehog helpers + , hparserShouldSucceed + + -- * hedgehog generators + , genEntryPath + , genFieldInfo + ) where + +import CLI.Parser +import CLI.Types (FieldInfo(..)) +import Coffer.Path (EntryPath(..), PathSegment, mkPathSegment, pathSegmentAllowedCharacters) +import Data.Text (Text) +import Entry (FieldKey, keyCharSet, newFieldKey) +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Test.Tasty.HUnit +import Text.Megaparsec (errorBundlePretty) +import Text.Megaparsec qualified as P + +unsafeFromRight :: (HasCallStack, Show a) => Either a b -> b +unsafeFromRight = \case + Right b -> b + Left a -> error $ "Expected Right, got Left: " <> show a + +---------------------------------------------------------------------------- +-- HUnit helpers +---------------------------------------------------------------------------- + +parserShouldSucceed :: (HasCallStack, Show a, Eq a) => MParser a -> Text -> a -> IO () +parserShouldSucceed p input expected = + case P.parse p "" input of + Right actual -> actual @?= expected + Left err -> assertFailure $ unlines + [ "Failed to parse input." + , "" + , errorBundlePretty err + ] + +parserShouldFail :: (HasCallStack, Show a) => MParser a -> Text -> String -> IO () +parserShouldFail p input expectedErr = + case P.parse p "" input of + Right actual -> assertFailure $ unlines + [ "Expected parser to fail, but it succeeded." + , "" + , show actual + ] + Left err -> errorBundlePretty err @?= expectedErr + +---------------------------------------------------------------------------- +-- Hedgehog helpers +---------------------------------------------------------------------------- + +hparserShouldSucceed :: (HasCallStack, Show a, Eq a, MonadTest m) => MParser a -> Text -> a -> m () +hparserShouldSucceed p input expected = + case P.parse p "" input of + Right actual -> actual === expected + Left err -> do + annotate $ unlines + [ "Failed to parse input." + , "" + , errorBundlePretty err + ] + failure + +---------------------------------------------------------------------------- +-- Hedgehog generators +---------------------------------------------------------------------------- + +genEntryPath :: Gen EntryPath +genEntryPath = EntryPath <$> Gen.nonEmpty (Range.linear 1 3) genPathSegment + +genPathSegment :: Gen PathSegment +genPathSegment = + unsafeFromRight . mkPathSegment <$> + Gen.text (Range.linear 1 5) (Gen.element pathSegmentAllowedCharacters) + +genFieldKey :: Gen FieldKey +genFieldKey = + unsafeFromRight . newFieldKey <$> + Gen.text (Range.linear 1 20) (Gen.element keyCharSet) + +genFieldInfo :: Gen FieldInfo +genFieldInfo = + FieldInfo + <$> genFieldKey + <*> Gen.text (Range.linear 0 20) + (Gen.frequency + [ (4, Gen.unicode) + , (1, pure '\n') + ] + ) From 6e9b9c7d2601846e9d5e4d537856bbfb4818e4d3 Mon Sep 17 00:00:00 2001 From: Leonid Vasilev Date: Mon, 11 Apr 2022 14:22:23 +0300 Subject: [PATCH 2/7] Editor mode enhancement Problem: at this moment we use our own format in editor mode. Reinventing the wheel can be hard and time consuming. Solution: changed this format to `TOML`. --- app/Main.hs | 3 +- coffer.cabal | 4 +- lib/CLI/EditorMode.hs | 186 +++++++++++++++++--------------- lib/CLI/EntryView.hs | 80 ++++++++++++++ lib/CLI/ParseError.hs | 47 ++++++++ lib/CLI/Parser.hs | 121 +++------------------ lib/Coffer/Path.hs | 28 ++++- package.yaml | 2 +- stack.yaml | 2 + stack.yaml.lock | 14 +++ tests/golden/common/common.bats | 12 ++- 11 files changed, 298 insertions(+), 201 deletions(-) create mode 100644 lib/CLI/EntryView.hs create mode 100644 lib/CLI/ParseError.hs diff --git a/app/Main.hs b/app/Main.hs index 769e9a72..c4bc5a64 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -81,10 +81,11 @@ main = do "The entry at '" +| path |+ "' does not have a field '" +| fieldName |+ "'." SomeCommand (CmdCreate opts) -> do - cmd <- CmdCreate <$> + opts <- if coEdit opts then embed (editorMode opts) else pure opts + let cmd = CmdCreate opts runCommand config cmd >>= \case CRSuccess _ -> printSuccess $ "Entry created at '" +| coQPath opts |+ "'." CRCreateError error -> do diff --git a/coffer.cabal b/coffer.cabal index 514db484..1faa16c8 100644 --- a/coffer.cabal +++ b/coffer.cabal @@ -27,6 +27,8 @@ library BackendName Backends CLI.EditorMode + CLI.EntryView + CLI.ParseError CLI.Parser CLI.PrettyPrint CLI.Types @@ -103,11 +105,11 @@ library , http-client , http-client-tls , http-types - , interpolate , lens , lens-aeson , megaparsec , mtl + , nyan-interpolation , optparse-applicative , polysemy , process diff --git a/lib/CLI/EditorMode.hs b/lib/CLI/EditorMode.hs index f744b201..0c016bde 100644 --- a/lib/CLI/EditorMode.hs +++ b/lib/CLI/EditorMode.hs @@ -4,25 +4,23 @@ module CLI.EditorMode where -import CLI.Parser (parseEditorFile) +import CLI.EntryView +import CLI.ParseError import CLI.Types -import Coffer.Path (EntryPath, QualifiedPath(qpPath)) import Control.Lens +import Data.Bifunctor (Bifunctor(first)) +import Data.Either (lefts, rights) import Data.Foldable (foldl') import Data.Maybe (fromMaybe) -import Data.String.Interpolate (i) import Data.Text (Text) import Data.Text qualified as T -import Data.Void (Void) -import Entry (FieldValue(unFieldValue)) -import Entry qualified as E -import Fmt (pretty) import System.Environment (lookupEnv) import System.IO (SeekMode(AbsoluteSeek), hFlush, hGetContents, hPutStr, hSeek) import System.IO.Temp import System.Process as Process -import Text.Megaparsec (ParseError, ParseErrorBundle, PosState) +import Text.Interpolation.Nyan import Text.Megaparsec qualified as P +import Toml qualified data AnnotatedLine = AnnotatedLine { _alLine :: Text @@ -31,43 +29,52 @@ data AnnotatedLine = AnnotatedLine makeLenses 'AnnotatedLine --- TODO: tags - -editorFileHeader :: EntryPath -> Text -editorFileHeader path = T.pack - [i|### Fields for '#{pretty path :: Text}' -### -### Examples: -### -### username = John Doe -### address = """ -### 123 Main Street -### Anytown -### """ +mkAnnotatedLine :: Text -> AnnotatedLine +mkAnnotatedLine t = AnnotatedLine t [] + +headerExample :: Text +headerExample = [int|s| +# Example: +# +# path = "/path/to/secret/entry" +# tags = [ +# "first tag", +# "important" +# ] +# +# [[field]] +# name = "test field" +# private = false +# contents = """ +# Some +# multiline +# thing +# """ |] -renderEditorFile :: EntryPath -> [FieldInfo] -> [FieldInfo] -> Text -renderEditorFile path fields privateFields = T.pack - [i|#{editorFileHeader path} -[Public fields] -#{T.unlines $ displayField <$> fields} -[Private fields] -#{T.unlines $ displayField <$> privateFields} -|] +renderEditorFile :: CreateOptions -> Text +renderEditorFile opts = Toml.encode entryViewCodec entryView where - displayField field = E.getFieldKey (fiName field) <> " = " <> displayFieldContents (unFieldValue . fiContents $ field) - - displayFieldContents contents = - -- If the field contents contain newline characters, - -- display them in multiple lines and wrapped with triple quotes. - if T.isInfixOf "\n" contents - then "\"\"\"\n" <> contents <> "\n\"\"\"" - else contents + publicFields = coFields opts <&> \field -> FieldInfoView field False + privateFields = coPrivateFields opts <&> \field -> FieldInfoView field True + entryView = EntryView (coQPath opts) (coTags opts) (publicFields <> privateFields) + +setOpts :: CreateOptions -> EntryView -> CreateOptions +setOpts opts entryView = opts + { coQPath = qPath + , coTags = tags + , coFields = publicFields + , coPrivateFields = privateFields + } + where + qPath = entryView ^. qEntryPath + tags = entryView ^. entryTags + publicFields = entryView ^.. fields . each . filtered (not . view private) . fieldInfo + privateFields = entryView ^.. fields . each . filtered (view private) . fieldInfo editorMode :: CreateOptions -> IO CreateOptions editorMode opts = do editorEnvVar <- lookupEnv "EDITOR" <&> fromMaybe "vi" - let entryPath = (qpPath . coQPath) opts let go :: Text -> IO CreateOptions @@ -89,29 +96,17 @@ editorMode opts = do hSeek fhandle AbsoluteSeek 0 editorFileContents' <- T.pack <$> hGetContents fhandle - -- Parse temp file contents. - case P.parse parseEditorFile fpath editorFileContents' of - Right (public, private) -> - pure opts - { coFields = public - , coPrivateFields = private - } - Left err -> do + case Toml.decode entryViewCodec editorFileContents' of + Right entryView -> do + pure $ setOpts opts entryView + Left errors -> do putStrLn "Failed to parse file." - putStrLn $ P.errorBundlePretty err - go $ editorFileContents' - & annotateEditorFile err -- Add annotations for parsing errors - & removeComments -- Remove parsing errors from previous attempts + & annotateEditorFile errors -- Add annotations for parsing errors & renderAnnotatedLines - & mappend (editorFileHeader entryPath) - - go $ renderEditorFile entryPath (coFields opts) (coPrivateFields opts) + & T.strip --- | Remove all lines that begin with `#`. -removeComments :: [AnnotatedLine] -> [AnnotatedLine] -removeComments als = - als & filter (\al -> al ^? alLine . _head /= Just '#') + go $ headerExample <> "\n\n" <> renderEditorFile opts renderAnnotatedLines :: [AnnotatedLine] -> Text renderAnnotatedLines als = @@ -119,7 +114,17 @@ renderAnnotatedLines als = <&> (\al -> T.intercalate "\n" (al ^. alLine : al ^. alErrors)) & T.unlines -{- | For each error in the bunddle, adds a note with the parsing error +annotateEditorFile :: [Toml.TomlDecodeError] -> Text -> [AnnotatedLine] +annotateEditorFile errors contents = + contents + & T.lines + -- Adding an extra empty line at the end. + -- If a parsing error occurs at EOF, we can annotate this line. + & (++ [""]) + <&> mkAnnotatedLine + & annotateErrors errors + +{- | For each @ParseError@, adds a note with the parsing error next to the offending line. E.g.: > pw 1234 @@ -127,38 +132,45 @@ next to the offending line. E.g.: > # unexpected '1' > # expecting '=' or white space -} -annotateEditorFile :: ParseErrorBundle Text Void -> Text -> [AnnotatedLine] -annotateEditorFile bundle fileContents = - fileContents - & T.lines - -- Adding an extra empty line at the end. - -- If a parsing error occurs at EOF, we can annotate this line. - & (++ [""]) - <&> mkAnnotatedLine - & annotateLines bundle +annotateParseErrors :: [ParseError] -> [AnnotatedLine] -> [AnnotatedLine] +annotateParseErrors errors lines = foldl' annotateParseError lines errors where - mkAnnotatedLine :: Text -> AnnotatedLine - mkAnnotatedLine t = AnnotatedLine t [] - - annotateLines :: ParseErrorBundle Text Void -> [AnnotatedLine] -> [AnnotatedLine] - annotateLines bundle lines = - fst $ - foldl' annotateLine - (lines, P.bundlePosState bundle) - (P.bundleErrors bundle) - -- | Finds the offending line, and adds one annotation with the parser error. - annotateLine :: ([AnnotatedLine], PosState Text) -> ParseError Text Void -> ([AnnotatedLine], PosState Text) - annotateLine (lines, posState) err = (lines', posState') + annotateParseError :: [AnnotatedLine] -> ParseError -> [AnnotatedLine] + annotateParseError lines error = lines & ix (error ^. line - 1) . alErrors <>~ (caretLine : errMsg) where - (_, posState') = P.reachOffset (P.errorOffset err) posState - lineNumber = P.unPos (P.sourceLine $ P.pstateSourcePos posState') - 1 - columnNumber = P.unPos (P.sourceColumn $ P.pstateSourcePos posState') - 1 + caretLine = "#" <> T.replicate (error ^. offset - 2) " " <> "^" errMsg = - err - & P.parseErrorTextPretty - & T.pack + error ^. errorMessage & T.lines <&> mappend "# " - caretLine = "#" <> T.replicate (columnNumber - 1) " " <> "^" - lines' = lines & ix lineNumber . alErrors <>~ (caretLine : errMsg) + +annotateOtherErrors :: [Toml.TomlDecodeError] -> [AnnotatedLine] -> [AnnotatedLine] +annotateOtherErrors errors lines = lines <> [AnnotatedLine "" errorLines] + where + prettifiedErrors = Toml.prettyTomlDecodeErrors errors + errorLines + | null errors = [] + | otherwise = + prettifiedErrors + & T.lines + <&> mappend "# " + +annotateErrors :: [Toml.TomlDecodeError] -> [AnnotatedLine] -> [AnnotatedLine] +annotateErrors errors lines = + lines + & annotateParseErrors parseErrors + & annotateOtherErrors otherErrors + where + parseAndOtherErrors :: [Either Toml.TomlDecodeError ParseError] + parseAndOtherErrors = + flip map errors \case + parseErr@(Toml.ParseError (Toml.TomlParseError err)) -> + P.parse (parseParseError <* P.eof) "" err & first (const parseErr) + otherErr -> Left otherErr + + parseErrors :: [ParseError] + parseErrors = rights parseAndOtherErrors + + otherErrors :: [Toml.TomlDecodeError] + otherErrors = lefts parseAndOtherErrors diff --git a/lib/CLI/EntryView.hs b/lib/CLI/EntryView.hs new file mode 100644 index 00000000..5df5fc0b --- /dev/null +++ b/lib/CLI/EntryView.hs @@ -0,0 +1,80 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module CLI.EntryView + ( FieldInfoView (..) + , fieldInfo + , private + , EntryView (..) + , qEntryPath + , entryTags + , fields + , entryViewCodec + ) where + +import CLI.Types (FieldInfo(FieldInfo, fiContents, fiName)) +import Coffer.Path (EntryPath, QualifiedPath, mkQualifiedEntryPath) +import Coffer.Util (didimatch) +import Control.Lens +import Data.Bifunctor (Bifunctor(first)) +import Data.Set (Set) +import Entry + (EntryTag, FieldKey, FieldValue(FieldValue, unFieldValue), getEntryTag, getFieldKey, newEntryTag, + newFieldKey) +import Fmt (Buildable(build), fmt) +import Toml qualified + +data FieldInfoView = FieldInfoView + { fivFieldInfo :: FieldInfo + , fivPrivate :: Bool + } + deriving stock (Show) +makeLensesWith abbreviatedFields ''FieldInfoView + +data EntryView = EntryView + { evQEntryPath :: QualifiedPath EntryPath + , evEntryTags :: Set EntryTag + , evFields :: [FieldInfoView] + } + deriving stock (Show) +makeLensesWith abbreviatedFields ''EntryView + +fieldInfoViewCodec :: Toml.TomlCodec FieldInfoView +fieldInfoViewCodec = FieldInfoView + <$> fieldInfoCodec Toml..= fivFieldInfo + <*> Toml.bool "private" Toml..= fivPrivate + where + fieldKeyCodec :: Toml.TomlCodec FieldKey + fieldKeyCodec = didimatch (Right . getFieldKey) newFieldKey (Toml.text "name") + + fieldValueCodec :: Toml.TomlCodec FieldValue + fieldValueCodec = Toml.dimap unFieldValue FieldValue (Toml.text "contents") + + fieldInfoCodec :: Toml.TomlCodec FieldInfo + fieldInfoCodec = FieldInfo + <$> fieldKeyCodec Toml..= fiName + <*> fieldValueCodec Toml..= fiContents + +entryPathCodec :: Toml.TomlCodec (QualifiedPath EntryPath) +entryPathCodec = didimatch (Right . fmt . build) mkQualifiedEntryPath (Toml.text "path") + +_entryTag :: Toml.TomlBiMap EntryTag Toml.AnyValue +_entryTag = Toml.BiMap to from + where + to :: EntryTag -> Either Toml.TomlBiMapError Toml.AnyValue + to = Toml.forward Toml._Text . getEntryTag + + from :: Toml.AnyValue -> Either Toml.TomlBiMapError EntryTag + from value = do + txt <- Toml.backward Toml._Text value + newEntryTag txt & first Toml.ArbitraryError + +entryTagsCodec :: Toml.TomlCodec (Set EntryTag) +entryTagsCodec = Toml.arraySetOf _entryTag "tags" + +entryViewCodec :: Toml.TomlCodec EntryView +entryViewCodec = EntryView + <$> entryPathCodec Toml..= evQEntryPath + <*> entryTagsCodec Toml..= evEntryTags + <*> Toml.list fieldInfoViewCodec "field" Toml..= evFields diff --git a/lib/CLI/ParseError.hs b/lib/CLI/ParseError.hs new file mode 100644 index 00000000..4079a3f4 --- /dev/null +++ b/lib/CLI/ParseError.hs @@ -0,0 +1,47 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module CLI.ParseError + ( ParseError (..) + , line + , offset + , errorMessage + , parseParseError + ) where + +import CLI.Parser (MParser) +import Control.Lens +import Control.Monad (void) +import Data.Text (Text) +import Text.Megaparsec qualified as P +import Text.Megaparsec.Char qualified as P +import Text.Megaparsec.Char.Lexer qualified as L + +data ParseError = ParseError + { peLine :: Int + , peOffset :: Int + , peErrorMessage :: Text + } + deriving stock (Show) +makeLensesWith abbreviatedFields ''ParseError + +spaceConsumer :: MParser () +spaceConsumer = L.space P.space1 P.empty P.empty + +lexeme :: MParser a -> MParser a +lexeme = L.lexeme spaceConsumer + +symbol :: Text -> MParser Text +symbol = L.symbol spaceConsumer + +parseInt :: MParser Int +parseInt = lexeme L.decimal + +parseParseError :: MParser ParseError +parseParseError = do + line <- parseInt + void $ symbol ":" + offset <- parseInt + P.manyTill (P.satisfy $ const True) (P.lookAhead $ P.string "unexpected") + ParseError line offset <$> P.takeRest diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index f84b718c..9d0c8868 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -9,12 +9,8 @@ module CLI.Parser parserInfo -- * Megaparsec , MParser - , parseEditorFile ) where -import BackendName (BackendName, newBackendName) -import CLI.Types -import Coffer.Path (EntryPath, Path, QualifiedPath(QualifiedPath), mkEntryPath, mkPath) import Control.Arrow ((>>>)) import Control.Monad (guard, void) import Data.Bifunctor (first) @@ -33,15 +29,18 @@ import Data.Time.Calendar.Compat (fromGregorianValid) import Data.Time.Calendar.Month.Compat (fromYearMonthValid) import Data.Time.Compat (LocalTime(..), localTimeToUTC, makeTimeOfDayValid, utc) import Data.Void (Void) -import Entry - (EntryTag, FieldKey, FieldValue(FieldValue), FieldVisibility(Private, Public), newEntryTag, - newFieldKey) import Options.Applicative import Options.Applicative.Help.Pretty qualified as Pretty import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P import Text.Megaparsec.Char.Lexer qualified as Lexer +import CLI.Types +import Coffer.Path (EntryPath, Path, QualifiedPath, mkQualifiedEntryPath, mkQualifiedPath) +import Entry + (EntryTag, FieldKey, FieldValue(FieldValue), FieldVisibility(Private, Public), newEntryTag, + newFieldKey) + {-# ANN module ("HLint: ignore Use <$>" :: Text) #-} parserInfo :: ParserInfo Options @@ -332,23 +331,6 @@ tagOptions = -- Common ---------------------------------------------------------------------------- -readPath' :: Text -> Either String Path -readPath' input = - mkPath input & first \err -> unlines - [ "Invalid path: " <> show input <> "." - , T.unpack err - ] - -readEntryPath' :: Text -> Either String EntryPath -readEntryPath' input = - mkEntryPath input & first \err -> unlines - [ "Invalid entry path: " <> show input <> "." - , T.unpack err - ] - -_readEntryPath :: ReadM EntryPath -_readEntryPath = str >>= toReader . readEntryPath' - readEntryTag :: ReadM EntryTag readEntryTag = do eitherReader \input -> @@ -357,13 +339,6 @@ readEntryTag = do , T.unpack err ] -readBackendName' :: Text -> Either String BackendName -readBackendName' input = - newBackendName input & first \err -> unlines - [ "Invalid backend name: " <> show input <> "." - , T.unpack err - ] - readFieldVisibility :: ReadM FieldVisibility readFieldVisibility = eitherReader $ readSum "visibility" @@ -386,36 +361,20 @@ readFieldKey' input = do readQualifiedEntryPath :: ReadM (QualifiedPath EntryPath) readQualifiedEntryPath = do eitherReader \input -> - case T.splitOn "#" (T.pack input) of - [backendNameStr, entryPathStr] -> do - backendName <- readBackendName' backendNameStr - entryPath <- readEntryPath' entryPathStr - pure $ QualifiedPath (Just backendName) entryPath - [entryPathStr] -> do - entryPath <- readEntryPath' entryPathStr - pure $ QualifiedPath Nothing entryPath - _ -> - Left $ unlines - [ "Invalid qualified entry path format: " <> show input <> "." - , show expectedQualifiedEntryPathFormat - ] + mkQualifiedEntryPath (T.pack input) & first \err -> unlines + [ "Invalid qualified entry path format: '" <> show input <> "'." + , T.unpack err + , show expectedQualifiedEntryPathFormat + ] readQualifiedPath :: ReadM (QualifiedPath Path) readQualifiedPath = do eitherReader \input -> - case T.splitOn "#" (T.pack input) of - [backendNameStr, pathStr] -> do - backendName <- readBackendName' backendNameStr - path <- readPath' pathStr - pure $ QualifiedPath (Just backendName) path - [pathStr] -> do - path <- readPath' pathStr - pure $ QualifiedPath Nothing path - _ -> - Left $ unlines - [ "Invalid qualified path format: " <> show input <> "." - , show expectedQualifiedPathFormat - ] + mkQualifiedPath (T.pack input) & first \err -> unlines + [ "Invalid qualified path format: '" <> show input <> "'." + , T.unpack err + , show expectedQualifiedPathFormat + ] readFieldValue :: ReadM FieldValue readFieldValue = str <&> FieldValue @@ -638,54 +597,6 @@ parseFieldNameWhile whileCond = do parseFieldContentsEof :: MParser FieldValue parseFieldContentsEof = FieldValue . T.pack <$> P.manyTill P.anySingle P.eof --- | Parse the rest of the line as a field content. -parseFieldContentsSingleLine :: MParser FieldValue -parseFieldContentsSingleLine = FieldValue . T.pack <$> P.manyTill P.anySingle endOfLineOrFile - --- | Parse a field content wrapped in triple quotes @"""@. E.g.: --- --- > """ --- > line1 --- > line2 --- > """ -parseFieldContentsTripleQuotes :: MParser FieldValue -parseFieldContentsTripleQuotes = do - let beginBlock = tripleQuote >> void P.eol - let parseLine = P.manyTill P.anySingle P.eol - let endBlock = tripleQuote >> endOfLineOrFile - - res <- beginBlock >> P.manyTill parseLine endBlock - pure $ res <&> T.pack & T.intercalate "\n" & FieldValue - - where - tripleQuote :: MParser () - tripleQuote = void $ P.string "\"\"\"" - -parseEditorFile :: MParser ([FieldInfo], [FieldInfo]) -parseEditorFile = do - let parseFieldInfo' = parseFieldInfo (parseFieldContentsTripleQuotes <|> parseFieldContentsSingleLine) <* spaceConsumer - - spaceConsumer >> P.string "[Public fields]" >> spaceConsumer - publicFields <- many (P.notFollowedBy (P.char '[') >> parseFieldInfo') - spaceConsumer >> P.string "[Private fields]" >> spaceConsumer - privateFields <- many parseFieldInfo' - P.space >> P.eof - pure (publicFields, privateFields) - where - comment :: MParser () - comment = Lexer.skipLineComment "#" - - -- | Skip empty lines and comments. - spaceConsumer :: MParser () - spaceConsumer = Lexer.space - (void $ P.try $ P.hspace >> P.eol) - comment - empty - --- | Matches on @eol@ or @eof@. -endOfLineOrFile :: MParser () -endOfLineOrFile = void P.eol <|> P.eof - ---------------------------------------------------------------------------- -- Utils ---------------------------------------------------------------------------- diff --git a/lib/Coffer/Path.hs b/lib/Coffer/Path.hs index fdd6cfcc..69e0f4bc 100644 --- a/lib/Coffer/Path.hs +++ b/lib/Coffer/Path.hs @@ -20,9 +20,11 @@ module Coffer.Path , entryPathAsPath , replacePathPrefix , QualifiedPath (..) + , mkQualifiedPath + , mkQualifiedEntryPath ) where -import BackendName (BackendName) +import BackendName (BackendName, newBackendName) import Control.Lens import Control.Monad ((>=>)) import Data.Hashable (Hashable) @@ -185,6 +187,30 @@ instance (Buildable path) => Buildable (QualifiedPath path) where Just backendName -> build backendName <> "#" <> build path Nothing -> build path +mkQualifiedPath :: Text -> Either Text (QualifiedPath Path) +mkQualifiedPath qPath = + case T.splitOn "#" qPath of + [backendNameStr, pathStr] -> do + backendName <- newBackendName backendNameStr + path <- mkPath pathStr + pure $ QualifiedPath (Just backendName) path + [pathStr] -> do + path <- mkPath pathStr + pure $ QualifiedPath Nothing path + _ -> Left "Unexpected qualified path format. Expected [BACKENDNAME#]PATH" + +mkQualifiedEntryPath :: Text -> Either Text (QualifiedPath EntryPath) +mkQualifiedEntryPath qEntryPath = do + case T.splitOn "#" qEntryPath of + [backendNameStr, entryPathStr] -> do + backendName <- newBackendName backendNameStr + entryPath <- mkEntryPath entryPathStr + pure $ QualifiedPath (Just backendName) entryPath + [entryPathStr] -> do + entryPath <- mkEntryPath entryPathStr + pure $ QualifiedPath Nothing entryPath + _ -> Left "Unexpected qualified entry path format. Expected [BACKENDNAME#]ENTRYPATH" + ---------------------------------------------------------------------------- -- Optics ---------------------------------------------------------------------------- diff --git a/package.yaml b/package.yaml index e2e639d9..01f890c4 100644 --- a/package.yaml +++ b/package.yaml @@ -96,11 +96,11 @@ library: - http-client - http-client-tls - http-types - - interpolate - lens - lens-aeson - megaparsec - mtl + - nyan-interpolation - optparse-applicative - polysemy - process diff --git a/stack.yaml b/stack.yaml index 734e7142..6c34eead 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,6 +18,8 @@ extra-deps: - generic-lens-core-2.2.0.0@sha256:b6b69e992f15fa80001de737f41f2123059011a1163d6c8941ce2e3ab44f8c03,2913 - hashable-1.3.5.0@sha256:47d1232d9788bb909cfbd80618de18dcdfb925609593e202912bd5841db138c1,4193 - lens-5.1@sha256:eb01fc4b1cfbad0e94c497eaf7b9f0e9b6c3dc7645c8b4597da7dc9d579f8500,14519 +- nyan-interpolation-0.9@sha256:8cf238be4c04746e4e9eabb34001c990c23e5837a19eb8652c584e57e92ecb41,3797 +- nyan-interpolation-core-0.9.0.1@sha256:1bda0e90d2045eb18c905f905082f4098829c1bdcbc4012663686a1c503b4ded,4067 - polysemy-1.7.1.0@sha256:3ead7a332abd70b202920ed3bf2e36866de163f821e643adfdcc9d39867b8033,5977 - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033 - tomland-1.3.3.1@sha256:83a8fd26a97164100541f7b26aa40ffdc6f230b21e94cbb3eae1fb7093c4356e,8924 diff --git a/stack.yaml.lock b/stack.yaml.lock index 4d72cfb2..de4d1fda 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -32,6 +32,20 @@ packages: sha256: 6236dbada87c86dfc74c3260acc674145b2773b354ac040c65abc54740452e07 original: hackage: lens-5.1@sha256:eb01fc4b1cfbad0e94c497eaf7b9f0e9b6c3dc7645c8b4597da7dc9d579f8500,14519 +- completed: + hackage: nyan-interpolation-0.9@sha256:8cf238be4c04746e4e9eabb34001c990c23e5837a19eb8652c584e57e92ecb41,3797 + pantry-tree: + size: 661 + sha256: 1ba3d0b9c1dd65cd6c8a3e10dc31261c70366d5822281176b84617b6c7b7bbc1 + original: + hackage: nyan-interpolation-0.9@sha256:8cf238be4c04746e4e9eabb34001c990c23e5837a19eb8652c584e57e92ecb41,3797 +- completed: + hackage: nyan-interpolation-core-0.9.0.1@sha256:1bda0e90d2045eb18c905f905082f4098829c1bdcbc4012663686a1c503b4ded,4067 + pantry-tree: + size: 1463 + sha256: 2a1a8d8b66746a246b3c0a4cd07daa6b961c9911676d30bc308a8a2682353b2b + original: + hackage: nyan-interpolation-core-0.9.0.1@sha256:1bda0e90d2045eb18c905f905082f4098829c1bdcbc4012663686a1c503b4ded,4067 - completed: hackage: polysemy-1.7.1.0@sha256:3ead7a332abd70b202920ed3bf2e36866de163f821e643adfdcc9d39867b8033,5977 pantry-tree: diff --git a/tests/golden/common/common.bats b/tests/golden/common/common.bats index ec73b9e4..549bd8f8 100644 --- a/tests/golden/common/common.bats +++ b/tests/golden/common/common.bats @@ -13,7 +13,7 @@ load '../helpers' assert_failure assert_output --partial - <#]. can be a string of the following characters: [a-zA-Z0-9] and symbols '-', '_', ';'. Examples: 'vault_kv-backend#secrets/google', 'my/passwords/entry'. @@ -75,7 +76,8 @@ EOF assert_failure assert_output --partial - <#]. can be a string of the following characters: [a-zA-Z0-9] and symbols '-', '_', ';'. Examples: 'vault_kv-backend#secrets/google', 'my/passwords/mypage/'. From 526a1fa30c42f9916c6df730ceffcd6629781ef4 Mon Sep 17 00:00:00 2001 From: Leonid Vasilev Date: Mon, 11 Apr 2022 14:45:59 +0300 Subject: [PATCH 3/7] fixup! Editor mode enhancement --- lib/CLI/Parser.hs | 4 ++-- tests/golden/common/common.bats | 10 +++++----- tests/golden/create-command/create-command.bats | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index 9d0c8868..a7d61432 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -362,7 +362,7 @@ readQualifiedEntryPath :: ReadM (QualifiedPath EntryPath) readQualifiedEntryPath = do eitherReader \input -> mkQualifiedEntryPath (T.pack input) & first \err -> unlines - [ "Invalid qualified entry path format: '" <> show input <> "'." + [ "Invalid qualified entry path format: " <> show input <> "." , T.unpack err , show expectedQualifiedEntryPathFormat ] @@ -371,7 +371,7 @@ readQualifiedPath :: ReadM (QualifiedPath Path) readQualifiedPath = do eitherReader \input -> mkQualifiedPath (T.pack input) & first \err -> unlines - [ "Invalid qualified path format: '" <> show input <> "'." + [ "Invalid qualified path format: " <> show input <> "." , T.unpack err , show expectedQualifiedPathFormat ] diff --git a/tests/golden/common/common.bats b/tests/golden/common/common.bats index 549bd8f8..27c6323a 100644 --- a/tests/golden/common/common.bats +++ b/tests/golden/common/common.bats @@ -13,7 +13,7 @@ load '../helpers' assert_failure assert_output --partial - <#]. can be a string of the following characters: [a-zA-Z0-9] and symbols '-', '_', ';'. @@ -76,7 +76,7 @@ EOF assert_failure assert_output --partial - <#]. can be a string of the following characters: [a-zA-Z0-9] and symbols '-', '_', ';'. diff --git a/tests/golden/create-command/create-command.bats b/tests/golden/create-command/create-command.bats index 66346acd..80137e87 100644 --- a/tests/golden/create-command/create-command.bats +++ b/tests/golden/create-command/create-command.bats @@ -13,7 +13,7 @@ load '../helpers' assert_failure assert_output --partial - < Date: Mon, 11 Apr 2022 14:46:36 +0300 Subject: [PATCH 4/7] Optional entry path in `create` command Problem: at this moment `entry path` is required argument. Sometimes we don't want to specify entry path in editor mode while creating entry. Solution: made `entry path` in `create` command optional argument. --- app/Main.hs | 1 + lib/Backend/Commands.hs | 3 ++- lib/CLI/EditorMode.hs | 12 ++++++++++-- lib/CLI/Parser.hs | 14 ++++++++------ lib/CLI/Types.hs | 3 ++- 5 files changed, 23 insertions(+), 10 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c4bc5a64..e4e471ae 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -88,6 +88,7 @@ main = do let cmd = CmdCreate opts runCommand config cmd >>= \case CRSuccess _ -> printSuccess $ "Entry created at '" +| coQPath opts |+ "'." + CREntryPathIsMissing -> printError "Please, specify the entry path." CRCreateError error -> do let errorMsg = createErrorToBuilder error printError $ unlinesF @_ @Builder $ "The entry cannot be created:" : "" : [errorMsg] diff --git a/lib/Backend/Commands.hs b/lib/Backend/Commands.hs index 2be08634..f1e90c3e 100644 --- a/lib/Backend/Commands.hs +++ b/lib/Backend/Commands.hs @@ -93,8 +93,9 @@ createCmd => Config -> CreateOptions -> Sem r CreateResult createCmd config - (CreateOptions (QualifiedPath backendNameMb entryPath) _edit force tags fields privateFields) + (CreateOptions mQEntryPath _edit force tags fields privateFields) = do + (QualifiedPath backendNameMb entryPath) <- maybe (throw CREntryPathIsMissing) pure mQEntryPath backend <- getBackend config backendNameMb nowUtc <- embed getCurrentTime let diff --git a/lib/CLI/EditorMode.hs b/lib/CLI/EditorMode.hs index 0c016bde..7d48d8d3 100644 --- a/lib/CLI/EditorMode.hs +++ b/lib/CLI/EditorMode.hs @@ -7,6 +7,7 @@ module CLI.EditorMode where import CLI.EntryView import CLI.ParseError import CLI.Types +import Coffer.Path (EntryPath, QualifiedPath, mkQualifiedEntryPath) import Control.Lens import Data.Bifunctor (Bifunctor(first)) import Data.Either (lefts, rights) @@ -52,16 +53,23 @@ headerExample = [int|s| # """ |] +examplePath :: QualifiedPath EntryPath +examplePath = + case mkQualifiedEntryPath "/example/path" of + Right entryPath -> entryPath + _ -> undefined -- Idk what I should do in this case + renderEditorFile :: CreateOptions -> Text renderEditorFile opts = Toml.encode entryViewCodec entryView where publicFields = coFields opts <&> \field -> FieldInfoView field False privateFields = coPrivateFields opts <&> \field -> FieldInfoView field True - entryView = EntryView (coQPath opts) (coTags opts) (publicFields <> privateFields) + entryPath = fromMaybe examplePath (coQPath opts) + entryView = EntryView entryPath (coTags opts) (publicFields <> privateFields) setOpts :: CreateOptions -> EntryView -> CreateOptions setOpts opts entryView = opts - { coQPath = qPath + { coQPath = Just qPath , coTags = tags , coFields = publicFields , coPrivateFields = privateFields diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index a7d61432..68c63659 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -121,12 +121,14 @@ viewOptions = do createOptions :: Parser CreateOptions createOptions = CreateOptions - <$> argument readQualifiedEntryPath ( mconcat - [ metavar "ENTRYPATH" - , help - "The path to insert the new entry into, this must not already be \ - \a directory or an entry unless `-f` is specified" - ]) + <$> optional + ( argument readQualifiedEntryPath ( mconcat + [ metavar "ENTRYPATH" + , help + "The path to insert the new entry into, this must not already be \ + \a directory or an entry unless `-f` is specified" + ]) + ) <*> switch ( mconcat [ long "edit" , short 'e' diff --git a/lib/CLI/Types.hs b/lib/CLI/Types.hs index 95398742..245e01d2 100644 --- a/lib/CLI/Types.hs +++ b/lib/CLI/Types.hs @@ -55,6 +55,7 @@ data CreateError data CreateResult = CRSuccess Entry + | CREntryPathIsMissing | CRCreateError CreateError data SetFieldResult @@ -97,7 +98,7 @@ data ViewOptions = ViewOptions deriving stock Show data CreateOptions = CreateOptions - { coQPath :: QualifiedPath EntryPath + { coQPath :: Maybe (QualifiedPath EntryPath) , coEdit :: Bool , coForce :: Bool , coTags :: Set EntryTag From 1d40f9854d00b783db5467d9b67781872b2f2e2f Mon Sep 17 00:00:00 2001 From: Leonid Vasilev Date: Mon, 25 Apr 2022 17:56:48 +0300 Subject: [PATCH 5/7] Editor mode rollback + tags support Problem: `tomland` is bugging on non-ascii characters and `toml` spec doesn't support some escape sequences like `\NUL` or `\DEL`. Solution: rollbacked on our homebrewed editor file format and added tags support. --- coffer.cabal | 2 +- lib/CLI/EditorMode.hs | 130 ++++++++++------------- lib/CLI/EntryView.hs | 181 ++++++++++++++++++++++++-------- lib/CLI/ParseError.hs | 47 --------- lib/CLI/Parser.hs | 5 + lib/Coffer/Path.hs | 2 +- lib/Entry.hs | 4 +- nix/sources.json | 30 +++--- package.yaml | 1 + tests/golden/common/common.bats | 2 +- 10 files changed, 216 insertions(+), 188 deletions(-) delete mode 100644 lib/CLI/ParseError.hs diff --git a/coffer.cabal b/coffer.cabal index 1faa16c8..dbb406e6 100644 --- a/coffer.cabal +++ b/coffer.cabal @@ -28,7 +28,6 @@ library Backends CLI.EditorMode CLI.EntryView - CLI.ParseError CLI.Parser CLI.PrettyPrint CLI.Types @@ -323,6 +322,7 @@ test-suite test build-depends: base >=4.14.3.0 && <5 , coffer + , containers , hedgehog , megaparsec , raw-strings-qq diff --git a/lib/CLI/EditorMode.hs b/lib/CLI/EditorMode.hs index 7d48d8d3..b61fe32f 100644 --- a/lib/CLI/EditorMode.hs +++ b/lib/CLI/EditorMode.hs @@ -5,23 +5,21 @@ module CLI.EditorMode where import CLI.EntryView -import CLI.ParseError import CLI.Types -import Coffer.Path (EntryPath, QualifiedPath, mkQualifiedEntryPath) import Control.Lens -import Data.Bifunctor (Bifunctor(first)) -import Data.Either (lefts, rights) import Data.Foldable (foldl') import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T +import Data.Void (Void) +import Fmt (pretty) import System.Environment (lookupEnv) import System.IO (SeekMode(AbsoluteSeek), hFlush, hGetContents, hPutStr, hSeek) import System.IO.Temp import System.Process as Process import Text.Interpolation.Nyan +import Text.Megaparsec (ParseError, ParseErrorBundle, PosState) import Text.Megaparsec qualified as P -import Toml qualified data AnnotatedLine = AnnotatedLine { _alLine :: Text @@ -37,45 +35,37 @@ headerExample :: Text headerExample = [int|s| # Example: # -# path = "/path/to/secret/entry" -# tags = [ -# "first tag", -# "important" -# ] +# path = backend#/path/to/entry # -# [[field]] -# name = "test field" -# private = false -# contents = """ -# Some +# [fields] +# public-field = public contents +# private-field =~ private contents +# multiline-thing = """ # multiline -# thing +# contents # """ +# +# [tags] +# first-tag +# important |] -examplePath :: QualifiedPath EntryPath -examplePath = - case mkQualifiedEntryPath "/example/path" of - Right entryPath -> entryPath - _ -> undefined -- Idk what I should do in this case - renderEditorFile :: CreateOptions -> Text -renderEditorFile opts = Toml.encode entryViewCodec entryView +renderEditorFile opts = pretty entryView where publicFields = coFields opts <&> \field -> FieldInfoView field False privateFields = coPrivateFields opts <&> \field -> FieldInfoView field True - entryPath = fromMaybe examplePath (coQPath opts) - entryView = EntryView entryPath (coTags opts) (publicFields <> privateFields) + entryView = EntryView (coQPath opts) (publicFields <> privateFields) (coTags opts) setOpts :: CreateOptions -> EntryView -> CreateOptions setOpts opts entryView = opts - { coQPath = Just qPath + { coQPath = qPath , coTags = tags , coFields = publicFields , coPrivateFields = privateFields } where - qPath = entryView ^. qEntryPath + qPath = entryView ^. mQEntryPath tags = entryView ^. entryTags publicFields = entryView ^.. fields . each . filtered (not . view private) . fieldInfo privateFields = entryView ^.. fields . each . filtered (view private) . fieldInfo @@ -104,11 +94,12 @@ editorMode opts = do hSeek fhandle AbsoluteSeek 0 editorFileContents' <- T.pack <$> hGetContents fhandle - case Toml.decode entryViewCodec editorFileContents' of + case P.parse parseEntryView fpath editorFileContents' of Right entryView -> do pure $ setOpts opts entryView Left errors -> do putStrLn "Failed to parse file." + putStrLn $ P.errorBundlePretty errors go $ editorFileContents' & annotateEditorFile errors -- Add annotations for parsing errors & renderAnnotatedLines @@ -116,69 +107,56 @@ editorMode opts = do go $ headerExample <> "\n\n" <> renderEditorFile opts +-- | Remove all lines that begin with `#`. +removeComments :: [AnnotatedLine] -> [AnnotatedLine] +removeComments als = + als & filter (\al -> al ^? alLine . _head /= Just '#') + renderAnnotatedLines :: [AnnotatedLine] -> Text renderAnnotatedLines als = als <&> (\al -> T.intercalate "\n" (al ^. alLine : al ^. alErrors)) & T.unlines -annotateEditorFile :: [Toml.TomlDecodeError] -> Text -> [AnnotatedLine] -annotateEditorFile errors contents = - contents - & T.lines - -- Adding an extra empty line at the end. - -- If a parsing error occurs at EOF, we can annotate this line. - & (++ [""]) - <&> mkAnnotatedLine - & annotateErrors errors - -{- | For each @ParseError@, adds a note with the parsing error +{- | For each error in the bunddle, adds a note with the parsing error next to the offending line. E.g.: - > pw 1234 > # ^ > # unexpected '1' > # expecting '=' or white space -} -annotateParseErrors :: [ParseError] -> [AnnotatedLine] -> [AnnotatedLine] -annotateParseErrors errors lines = foldl' annotateParseError lines errors +annotateEditorFile :: ParseErrorBundle Text Void -> Text -> [AnnotatedLine] +annotateEditorFile bundle fileContents = + fileContents + & T.lines + -- Adding an extra empty line at the end. + -- If a parsing error occurs at EOF, we can annotate this line. + & (++ [""]) + <&> mkAnnotatedLine + & annotateLines bundle where + mkAnnotatedLine :: Text -> AnnotatedLine + mkAnnotatedLine t = AnnotatedLine t [] + + annotateLines :: ParseErrorBundle Text Void -> [AnnotatedLine] -> [AnnotatedLine] + annotateLines bundle lines = + fst $ + foldl' annotateLine + (lines, P.bundlePosState bundle) + (P.bundleErrors bundle) + -- | Finds the offending line, and adds one annotation with the parser error. - annotateParseError :: [AnnotatedLine] -> ParseError -> [AnnotatedLine] - annotateParseError lines error = lines & ix (error ^. line - 1) . alErrors <>~ (caretLine : errMsg) + annotateLine :: ([AnnotatedLine], PosState Text) -> ParseError Text Void -> ([AnnotatedLine], PosState Text) + annotateLine (lines, posState) err = (lines', posState') where - caretLine = "#" <> T.replicate (error ^. offset - 2) " " <> "^" + (_, posState') = P.reachOffset (P.errorOffset err) posState + lineNumber = P.unPos (P.sourceLine $ P.pstateSourcePos posState') - 1 + columnNumber = P.unPos (P.sourceColumn $ P.pstateSourcePos posState') - 1 errMsg = - error ^. errorMessage + err + & P.parseErrorTextPretty + & T.pack & T.lines <&> mappend "# " - -annotateOtherErrors :: [Toml.TomlDecodeError] -> [AnnotatedLine] -> [AnnotatedLine] -annotateOtherErrors errors lines = lines <> [AnnotatedLine "" errorLines] - where - prettifiedErrors = Toml.prettyTomlDecodeErrors errors - errorLines - | null errors = [] - | otherwise = - prettifiedErrors - & T.lines - <&> mappend "# " - -annotateErrors :: [Toml.TomlDecodeError] -> [AnnotatedLine] -> [AnnotatedLine] -annotateErrors errors lines = - lines - & annotateParseErrors parseErrors - & annotateOtherErrors otherErrors - where - parseAndOtherErrors :: [Either Toml.TomlDecodeError ParseError] - parseAndOtherErrors = - flip map errors \case - parseErr@(Toml.ParseError (Toml.TomlParseError err)) -> - P.parse (parseParseError <* P.eof) "" err & first (const parseErr) - otherErr -> Left otherErr - - parseErrors :: [ParseError] - parseErrors = rights parseAndOtherErrors - - otherErrors :: [Toml.TomlDecodeError] - otherErrors = lefts parseAndOtherErrors + caretLine = "#" <> T.replicate (columnNumber - 1) " " <> "^" + lines' = lines & ix lineNumber . alErrors <>~ (caretLine : errMsg) diff --git a/lib/CLI/EntryView.hs b/lib/CLI/EntryView.hs index 5df5fc0b..510f35e2 100644 --- a/lib/CLI/EntryView.hs +++ b/lib/CLI/EntryView.hs @@ -7,74 +7,165 @@ module CLI.EntryView , fieldInfo , private , EntryView (..) - , qEntryPath + , mQEntryPath , entryTags , fields - , entryViewCodec + , parseEntryView ) where +import CLI.Parser (MParser, endOfLineOrFile) import CLI.Types (FieldInfo(FieldInfo, fiContents, fiName)) import Coffer.Path (EntryPath, QualifiedPath, mkQualifiedEntryPath) -import Coffer.Util (didimatch) +import Control.Applicative (Alternative(many, (<|>)), empty) import Control.Lens -import Data.Bifunctor (Bifunctor(first)) +import Control.Monad (void) import Data.Set (Set) -import Entry - (EntryTag, FieldKey, FieldValue(FieldValue, unFieldValue), getEntryTag, getFieldKey, newEntryTag, - newFieldKey) -import Fmt (Buildable(build), fmt) -import Toml qualified +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import Entry (EntryTag, FieldValue(FieldValue), fieldValue, newEntryTag, newFieldKey) +import Fmt (Buildable(build), unlinesF) +import Text.Interpolation.Nyan +import Text.Megaparsec qualified as P +import Text.Megaparsec.Char qualified as P +import Text.Megaparsec.Char.Lexer qualified as Lexer data FieldInfoView = FieldInfoView { fivFieldInfo :: FieldInfo , fivPrivate :: Bool } - deriving stock (Show) + deriving stock (Show, Eq) makeLensesWith abbreviatedFields ''FieldInfoView +instance Buildable FieldInfoView where + build (FieldInfoView fieldInfo private) = build fieldName <> delimeter <> buildedFieldContents + where + fieldName = fiName fieldInfo + fieldContents = fiContents fieldInfo + + buildedFieldContents + | _ : _ : _ <- T.split (== '\n') (fieldContents ^. fieldValue) = [int|s| +""" +#{fieldContents} +""" +|] + | otherwise = build fieldContents + + delimeter + | private = " =~ " + | otherwise = " = " + data EntryView = EntryView - { evQEntryPath :: QualifiedPath EntryPath - , evEntryTags :: Set EntryTag + { evMQEntryPath :: Maybe (QualifiedPath EntryPath) , evFields :: [FieldInfoView] + , evEntryTags :: Set EntryTag } - deriving stock (Show) + deriving stock (Show, Eq) makeLensesWith abbreviatedFields ''EntryView -fieldInfoViewCodec :: Toml.TomlCodec FieldInfoView -fieldInfoViewCodec = FieldInfoView - <$> fieldInfoCodec Toml..= fivFieldInfo - <*> Toml.bool "private" Toml..= fivPrivate +instance Buildable EntryView where + build (EntryView mQEntryPath fields entryTags) = [int|s| +#{buildedPath} + +[fields] +#{buildedFields} +[tags] +#{buildedEntryTags} +|] + where + buildedPath = + case mQEntryPath of + Nothing -> "path = # <-- write your qualified entry path here" + Just qPath -> "path = " <> build qPath + + buildedFields = + fields + <&> build + & unlinesF + + buildedEntryTags = + entryTags + & S.toList + <&> build + & unlinesF + +spaceConsumer :: MParser () +spaceConsumer = Lexer.space + P.space1 + (Lexer.skipLineComment "#") + empty + +lexeme :: MParser a -> MParser a +lexeme = Lexer.lexeme spaceConsumer + +symbol :: Text -> MParser Text +symbol = Lexer.symbol spaceConsumer + +eitherToMParser :: Int -> Either Text a -> MParser a +eitherToMParser offset = either failAction pure where - fieldKeyCodec :: Toml.TomlCodec FieldKey - fieldKeyCodec = didimatch (Right . getFieldKey) newFieldKey (Toml.text "name") + failAction :: Text -> MParser a + failAction errMsg = do + P.setOffset offset + fail $ T.unpack errMsg - fieldValueCodec :: Toml.TomlCodec FieldValue - fieldValueCodec = Toml.dimap unFieldValue FieldValue (Toml.text "contents") +parseQualifiedPath :: MParser (Maybe (QualifiedPath EntryPath)) +parseQualifiedPath = do + offset <- P.getOffset + void $ symbol "path" >> symbol "=" + qPathStr <- many (P.notFollowedBy P.space1 >> P.anySingle) <&> T.strip . T.pack + eitherToMParser offset (mkQualifiedEntryPath qPathStr) <&> Just - fieldInfoCodec :: Toml.TomlCodec FieldInfo - fieldInfoCodec = FieldInfo - <$> fieldKeyCodec Toml..= fiName - <*> fieldValueCodec Toml..= fiContents +parseFieldInfoView :: MParser FieldInfoView +parseFieldInfoView = do + offset <- P.getOffset + fieldNameStr <- lexeme $ many (P.notFollowedBy (P.space1 <|> void (P.char '=')) >> P.anySingle) <&> T.pack + fieldName <- eitherToMParser offset $ newFieldKey fieldNameStr + delimeter <- P.string "=~" <|> P.string "=" + void $ many P.hspace1 + fieldContents <- lexeme (parseFieldContentsTripleQuotes <|> parseFieldContentsSingleLine) -entryPathCodec :: Toml.TomlCodec (QualifiedPath EntryPath) -entryPathCodec = didimatch (Right . fmt . build) mkQualifiedEntryPath (Toml.text "path") + let fieldInfo = FieldInfo fieldName fieldContents + let private = delimeter == "=~" -_entryTag :: Toml.TomlBiMap EntryTag Toml.AnyValue -_entryTag = Toml.BiMap to from + pure $ FieldInfoView fieldInfo private where - to :: EntryTag -> Either Toml.TomlBiMapError Toml.AnyValue - to = Toml.forward Toml._Text . getEntryTag - - from :: Toml.AnyValue -> Either Toml.TomlBiMapError EntryTag - from value = do - txt <- Toml.backward Toml._Text value - newEntryTag txt & first Toml.ArbitraryError - -entryTagsCodec :: Toml.TomlCodec (Set EntryTag) -entryTagsCodec = Toml.arraySetOf _entryTag "tags" - -entryViewCodec :: Toml.TomlCodec EntryView -entryViewCodec = EntryView - <$> entryPathCodec Toml..= evQEntryPath - <*> entryTagsCodec Toml..= evEntryTags - <*> Toml.list fieldInfoViewCodec "field" Toml..= evFields + -- | Parse the rest of the line as a field content. + parseFieldContentsSingleLine :: MParser FieldValue + parseFieldContentsSingleLine = FieldValue . T.pack <$> P.manyTill P.anySingle endOfLineOrFile + + -- | Parse a field content wrapped in triple quotes @"""@. E.g.: + -- + -- > """ + -- > line1 + -- > line2 + -- > """ + parseFieldContentsTripleQuotes :: MParser FieldValue + parseFieldContentsTripleQuotes = do + let beginBlock = tripleQuote >> void P.eol + let parseLine = P.manyTill P.anySingle P.eol + let endBlock = tripleQuote >> endOfLineOrFile + + res <- beginBlock >> P.manyTill parseLine endBlock + pure $ res <&> T.pack & T.intercalate "\n" & FieldValue + + where + tripleQuote :: MParser () + tripleQuote = void $ P.string "\"\"\"" + +parseEntryTag :: MParser EntryTag +parseEntryTag = do + offset <- P.getOffset + entryTagStr <- lexeme $ P.manyTill P.anySingle endOfLineOrFile <&> T.pack + eitherToMParser offset $ newEntryTag entryTagStr + +parseEntryView :: MParser EntryView +parseEntryView = do + spaceConsumer + qEntryPath <- lexeme parseQualifiedPath + void $ symbol "[fields]" + fieldInfoViews <- P.manyTill (lexeme parseFieldInfoView) (P.char '[') + void $ symbol "tags]" + entryTags <- lexeme (many parseEntryTag) <&> S.fromList + endOfLineOrFile + pure $ EntryView qEntryPath fieldInfoViews entryTags diff --git a/lib/CLI/ParseError.hs b/lib/CLI/ParseError.hs deleted file mode 100644 index 4079a3f4..00000000 --- a/lib/CLI/ParseError.hs +++ /dev/null @@ -1,47 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Serokell --- --- SPDX-License-Identifier: MPL-2.0 - -module CLI.ParseError - ( ParseError (..) - , line - , offset - , errorMessage - , parseParseError - ) where - -import CLI.Parser (MParser) -import Control.Lens -import Control.Monad (void) -import Data.Text (Text) -import Text.Megaparsec qualified as P -import Text.Megaparsec.Char qualified as P -import Text.Megaparsec.Char.Lexer qualified as L - -data ParseError = ParseError - { peLine :: Int - , peOffset :: Int - , peErrorMessage :: Text - } - deriving stock (Show) -makeLensesWith abbreviatedFields ''ParseError - -spaceConsumer :: MParser () -spaceConsumer = L.space P.space1 P.empty P.empty - -lexeme :: MParser a -> MParser a -lexeme = L.lexeme spaceConsumer - -symbol :: Text -> MParser Text -symbol = L.symbol spaceConsumer - -parseInt :: MParser Int -parseInt = lexeme L.decimal - -parseParseError :: MParser ParseError -parseParseError = do - line <- parseInt - void $ symbol ":" - offset <- parseInt - P.manyTill (P.satisfy $ const True) (P.lookAhead $ P.string "unexpected") - ParseError line offset <$> P.takeRest diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index 68c63659..534f58f9 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -9,6 +9,7 @@ module CLI.Parser parserInfo -- * Megaparsec , MParser + , endOfLineOrFile ) where import Control.Arrow ((>>>)) @@ -599,6 +600,10 @@ parseFieldNameWhile whileCond = do parseFieldContentsEof :: MParser FieldValue parseFieldContentsEof = FieldValue . T.pack <$> P.manyTill P.anySingle P.eof +-- | Matches on @eol@ or @eof@. +endOfLineOrFile :: MParser () +endOfLineOrFile = void P.eol <|> P.eof + ---------------------------------------------------------------------------- -- Utils ---------------------------------------------------------------------------- diff --git a/lib/Coffer/Path.hs b/lib/Coffer/Path.hs index 69e0f4bc..918247d3 100644 --- a/lib/Coffer/Path.hs +++ b/lib/Coffer/Path.hs @@ -179,7 +179,7 @@ data QualifiedPath path = QualifiedPath { qpBackendName :: Maybe BackendName , qpPath :: path } - deriving stock (Show, Functor) + deriving stock (Show, Functor, Eq) instance (Buildable path) => Buildable (QualifiedPath path) where build (QualifiedPath backendNameMb path) = diff --git a/lib/Entry.hs b/lib/Entry.hs index 539d8e11..fbd7eff2 100644 --- a/lib/Entry.hs +++ b/lib/Entry.hs @@ -53,9 +53,9 @@ keyCharSet = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_;" newFieldKey :: Text -> Either Text FieldKey newFieldKey t | T.null t = - Left "Tags must contain at least 1 character" + Left "Field name must contain at least 1 character" | T.any (`notElem` keyCharSet) t = - Left $ "Tags can only contain the following characters: '" <> T.pack keyCharSet <> "'" + Left $ "Field name can only contain the following characters: '" <> T.pack keyCharSet <> "'" | otherwise = Right $ UnsafeFieldKey t getFieldKey :: FieldKey -> Text diff --git a/nix/sources.json b/nix/sources.json index 8be0a48e..4813ed92 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -5,10 +5,10 @@ "homepage": "", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "4cf90b36955597d0151940eabfb1b61a8ec42256", - "sha256": "1gdy89dgv2n5ibb6lc03y6k0y9pcacdrlfgv6ipd9bwrivkhdaa9", + "rev": "cf5c7528576058a86f5c0e801549e4ccb8e7b73c", + "sha256": "1bgrg4v21pf9kbzamic4w0ylpnjw36fd56ghk08qqb1h8linp8m4", "type": "tarball", - "url": "https://github.com/input-output-hk/hackage.nix/archive/4cf90b36955597d0151940eabfb1b61a8ec42256.tar.gz", + "url": "https://github.com/input-output-hk/hackage.nix/archive/cf5c7528576058a86f5c0e801549e4ccb8e7b73c.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, "haskell-nix-weeder": { @@ -47,18 +47,6 @@ "url": "https://github.com/serokell/nixpkgs/archive/1714a2ead1a18678afa3cbf75dff3f024c579061.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, - "serokell.nix": { - "branch": "master", - "description": "Serokell Nix infrastructure library", - "homepage": null, - "owner": "serokell", - "repo": "serokell.nix", - "rev": "652105c5fc5564f5d8e682d61bdc0d51bbc1f939", - "sha256": "19zkjhyjbksf2fw32h7m3x0v8nvgdy2qkjkxg2qzzb25as245vmj", - "type": "tarball", - "url": "https://github.com/serokell/serokell.nix/archive/652105c5fc5564f5d8e682d61bdc0d51bbc1f939.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, "nixpkgs-stylish": { "branch": "master", "description": "Nix Packages collection", @@ -71,6 +59,18 @@ "url": "https://github.com/NixOS/nixpkgs/archive/19574af0af3ffaf7c9e359744ed32556f34536bd.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, + "serokell.nix": { + "branch": "master", + "description": "Serokell Nix infrastructure library", + "homepage": null, + "owner": "serokell", + "repo": "serokell.nix", + "rev": "652105c5fc5564f5d8e682d61bdc0d51bbc1f939", + "sha256": "19zkjhyjbksf2fw32h7m3x0v8nvgdy2qkjkxg2qzzb25as245vmj", + "type": "tarball", + "url": "https://github.com/serokell/serokell.nix/archive/652105c5fc5564f5d8e682d61bdc0d51bbc1f939.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" + }, "stackage.nix": { "branch": "master", "description": "Automatically generated Nix expressions of Stackage snapshots", diff --git a/package.yaml b/package.yaml index 01f890c4..4d771552 100644 --- a/package.yaml +++ b/package.yaml @@ -137,6 +137,7 @@ tests: - -threaded dependencies: - coffer + - containers - hedgehog - megaparsec - raw-strings-qq diff --git a/tests/golden/common/common.bats b/tests/golden/common/common.bats index 27c6323a..6e174ddb 100644 --- a/tests/golden/common/common.bats +++ b/tests/golden/common/common.bats @@ -54,7 +54,7 @@ EOF assert_failure assert_output --partial - < Date: Mon, 25 Apr 2022 17:59:24 +0300 Subject: [PATCH 6/7] HUnit and hedgehog tests fix Problem: after changes in editor mode unit and property tests are not compiling. Moreover, they are outdated. Solution: updated these tests. --- tests/test/Test/CLI/EditorMode.hs | 195 +++++++++++++++++------------- tests/test/Test/Util.hs | 55 ++++++--- 2 files changed, 152 insertions(+), 98 deletions(-) diff --git a/tests/test/Test/CLI/EditorMode.hs b/tests/test/Test/CLI/EditorMode.hs index 4e70d7c1..e70beaa6 100644 --- a/tests/test/Test/CLI/EditorMode.hs +++ b/tests/test/Test/CLI/EditorMode.hs @@ -5,9 +5,12 @@ module Test.CLI.EditorMode where import CLI.EditorMode (renderEditorFile) -import CLI.Parser -import CLI.Types (FieldInfo(..)) -import Entry (newFieldKey) +import CLI.EntryView (EntryView(EntryView), FieldInfoView(FieldInfoView), parseEntryView) +import CLI.Types (CreateOptions(CreateOptions), FieldInfo(..)) +import Coffer.Path (mkQualifiedEntryPath) +import Data.Functor ((<&>)) +import Data.Set qualified as S +import Entry (FieldValue(FieldValue), newEntryTag, newFieldKey) import Hedgehog import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -16,20 +19,29 @@ import Text.RawString.QQ (r) hprop_render_parse_roundtrip :: Property hprop_render_parse_roundtrip = property $ do - entryPath <- forAll genEntryPath + qEntryPath <- forAll genQualifiedEntryPath publicFields <- forAll $ Gen.list (Range.linear 0 5) genFieldInfo privateFields <- forAll $ Gen.list (Range.linear 0 5) genFieldInfo + entryTags <- forAll $ Gen.set (Range.linear 0 5) genEntryTag - let rendered = renderEditorFile entryPath publicFields privateFields - hparserShouldSucceed parseEditorFile rendered (publicFields, privateFields) + let opts = CreateOptions (Just qEntryPath) True False entryTags publicFields privateFields + let rendered = renderEditorFile opts + + let publicFieldInfoViews = publicFields <&> \field -> FieldInfoView field False + let privateFieldInfoViews = privateFields <&> \field -> FieldInfoView field True + + let entryView = EntryView (Just qEntryPath) (publicFieldInfoViews <> privateFieldInfoViews) entryTags + + hparserShouldSucceed parseEntryView rendered entryView unit_parse_editor_file :: IO () unit_parse_editor_file = do - parserShouldSucceed parseEditorFile + parserShouldSucceed parseEntryView [r| +path = /entry/path # comment1 -[Public fields] +[fields] # comment2 field1 = f1 @@ -46,105 +58,122 @@ first line: """ -field5 = Γ’Π”πŸ˜±πŸ‘ͺζ—₯本 - -[Private fields] - +field5 = Γ’ΠŸΡ€ΠΈΠ²Π΅Ρ‚πŸ˜±πŸ‘ͺζ—₯ζœ¬πŸ€”πŸ€” # comment4 -privatefield1 = pf1 +privatefield1 =~ pf1 # comment5 -privatefield2 = pf2 +privatefield2 =~ pf2 + +[tags] +tag1 +important |] - ( [ FieldInfo (unsafeFromRight $ newFieldKey "field1") "f1" - , FieldInfo (unsafeFromRight $ newFieldKey "field2") "f2" - , FieldInfo (unsafeFromRight $ newFieldKey "field3") "" - , FieldInfo (unsafeFromRight $ newFieldKey "field4") "first line:\n second line\n third line\n" - , FieldInfo (unsafeFromRight $ newFieldKey "field5") "Γ’Π”πŸ˜±πŸ‘ͺζ—₯本" - ] - , [ FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") "pf1" - , FieldInfo (unsafeFromRight $ newFieldKey "privatefield2") "pf2" - - ] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/entry/path")) + [ FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "field1") (FieldValue "f1")) False + , FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "field2") (FieldValue "f2")) False + , FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "field3") (FieldValue "")) False + , FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "field4") (FieldValue "first line:\n second line\n third line\n")) False + , FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "field5") (FieldValue "Γ’ΠŸΡ€ΠΈΠ²Π΅Ρ‚πŸ˜±πŸ‘ͺζ—₯ζœ¬πŸ€”πŸ€”")) False + , FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") (FieldValue "pf1")) True + , FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "privatefield2") (FieldValue "pf2")) True + ] + ( S.fromList + [ unsafeFromRight $ newEntryTag "tag1" + , unsafeFromRight $ newEntryTag "important" + ] + ) ) unit_parses_file_without_trailing_newline :: IO () unit_parses_file_without_trailing_newline = do - parserShouldSucceed parseEditorFile - [r|[Public fields] -[Private fields]|] - ( [] - , [] + parserShouldSucceed parseEntryView + [r|path = /path +[fields] +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [] + S.empty ) - parserShouldSucceed parseEditorFile - [r|[Public fields] -[Private fields] -privatefield1=pf1|] - ( [] - , [ FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") "pf1" - ] + parserShouldSucceed parseEntryView + [r|path = /path +[fields] +privatefield1=~pf1 +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") (FieldValue "pf1")) True] + S.empty ) - parserShouldSucceed parseEditorFile - [r|[Public fields] -[Private fields] -privatefield1=""" + parserShouldSucceed parseEntryView + [r|path = /path +[fields] +privatefield1=~""" pf1 -"""|] - ( [] - , [ FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") "pf1" - ] +""" +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "privatefield1") (FieldValue "pf1")) True] + S.empty ) unit_parse_minimal_editor_file :: IO () unit_parse_minimal_editor_file = do - parserShouldSucceed parseEditorFile - [r|[Public fields] -[Private fields]|] - ( [] - , [] + parserShouldSucceed parseEntryView + [r|path = /path +[fields] +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [] + S.empty ) -unit_fieldname_and_fieldcontents_must_be_on_the_same_line :: IO () -unit_fieldname_and_fieldcontents_must_be_on_the_same_line = do - parserShouldFail parseEditorFile - [r|[Public fields] -name = - contents -[Private fields]|] +unit_fieldname_and_fieldcontents_must_be_separated_by_eq_sign :: IO () +unit_fieldname_and_fieldcontents_must_be_separated_by_eq_sign = do + parserShouldFail parseEntryView + [r|path = /path +[fields] +name contents +[tags]|] - [r|3:1: + [r|3:6: | -3 | contents - | ^^^^^^^^^^^ -unexpected " contents[Priv" -expecting "[Private fields]" or fieldname +3 | name contents + | ^^ +unexpected "co" +expecting "=~" or '=' |] -unit_fieldname_must_be_0_indented :: IO () -unit_fieldname_must_be_0_indented = do - parserShouldFail parseEditorFile - [r|[Public fields] +unit_fieldname_may_not_be_0_indented :: IO () +unit_fieldname_may_not_be_0_indented = do + parserShouldSucceed parseEntryView + [r|path = /path +[fields] name1 = contents1 name2 = contents2 -[Private fields]|] - [r|3:1: - | -3 | name2 = contents2 - | ^^^^^^^^^^^^^^^^ -unexpected " name2 = conten" -expecting "[Private fields]" or fieldname -|] +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [ FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "name1") (FieldValue "contents1")) False + , FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "name2") (FieldValue "contents2")) False + ] + S.empty + ) + - parserShouldFail parseEditorFile - [r|[Public fields] + parserShouldSucceed parseEntryView + [r|path = /path +[fields] name = contents -[Private fields]|] - [r|2:1: - | -2 | name = contents - | ^^^^^^^^^^^^^^^^ -unexpected " name = content" -expecting "[Private fields]" or fieldname -|] +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "name") (FieldValue "contents")) False] + S.empty + ) diff --git a/tests/test/Test/Util.hs b/tests/test/Test/Util.hs index 4f2984a3..389405b3 100644 --- a/tests/test/Test/Util.hs +++ b/tests/test/Test/Util.hs @@ -13,15 +13,19 @@ module Test.Util , hparserShouldSucceed -- * hedgehog generators - , genEntryPath + , genQualifiedEntryPath , genFieldInfo + , genEntryTag ) where +import BackendName (BackendName, backendNameCharSet, newBackendName) import CLI.Parser import CLI.Types (FieldInfo(..)) -import Coffer.Path (EntryPath(..), PathSegment, mkPathSegment, pathSegmentAllowedCharacters) +import Coffer.Path + (EntryPath(..), PathSegment, QualifiedPath(QualifiedPath), mkPathSegment, + pathSegmentAllowedCharacters) import Data.Text (Text) -import Entry (FieldKey, keyCharSet, newFieldKey) +import Entry (EntryTag, FieldKey, FieldValue(FieldValue), keyCharSet, newEntryTag, newFieldKey) import Hedgehog import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -74,6 +78,11 @@ hparserShouldSucceed p input expected = ] failure +genFromCharSet :: Int -> Int -> [Char] -> (Text -> Either Text a) -> Gen a +genFromCharSet from to charSet smartCtor = + unsafeFromRight . smartCtor <$> + Gen.text (Range.linear from to) (Gen.element charSet) + ---------------------------------------------------------------------------- -- Hedgehog generators ---------------------------------------------------------------------------- @@ -82,22 +91,38 @@ genEntryPath :: Gen EntryPath genEntryPath = EntryPath <$> Gen.nonEmpty (Range.linear 1 3) genPathSegment genPathSegment :: Gen PathSegment -genPathSegment = - unsafeFromRight . mkPathSegment <$> - Gen.text (Range.linear 1 5) (Gen.element pathSegmentAllowedCharacters) +genPathSegment = genFromCharSet 1 5 pathSegmentAllowedCharacters mkPathSegment genFieldKey :: Gen FieldKey -genFieldKey = - unsafeFromRight . newFieldKey <$> - Gen.text (Range.linear 1 20) (Gen.element keyCharSet) +genFieldKey = genFromCharSet 1 20 keyCharSet newFieldKey + +genMaybeBackendName :: Gen (Maybe BackendName) +genMaybeBackendName = Gen.maybe genBackendName + where + genBackendName :: Gen BackendName + genBackendName = genFromCharSet 1 10 backendNameCharSet newBackendName + +genQualifiedEntryPath :: Gen (QualifiedPath EntryPath) +genQualifiedEntryPath = + QualifiedPath + <$> genMaybeBackendName + <*> genEntryPath genFieldInfo :: Gen FieldInfo genFieldInfo = FieldInfo <$> genFieldKey - <*> Gen.text (Range.linear 0 20) - (Gen.frequency - [ (4, Gen.unicode) - , (1, pure '\n') - ] - ) + <*> genFieldContents + where + genFieldContents :: Gen FieldValue + genFieldContents = + FieldValue + <$> Gen.text (Range.linear 0 20) + (Gen.frequency + [ (4, Gen.unicode) + , (1, pure '\n') + ] + ) + +genEntryTag :: Gen EntryTag +genEntryTag = genFromCharSet 1 5 keyCharSet newEntryTag From ed028d24c70c680dc30b4de29c00592d6e69f4e1 Mon Sep 17 00:00:00 2001 From: Leonid Vasilev Date: Tue, 26 Apr 2022 14:47:36 +0300 Subject: [PATCH 7/7] fixup! Editor mode rollback + tags support --- .hlint.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.hlint.yaml b/.hlint.yaml index 7ecaa7f9..180cc78a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -6,7 +6,7 @@ # Settings ########################################################################### -- arguments: [-XTypeApplications, -XRecursiveDo, -XBlockArguments] +- arguments: [-XTypeApplications, -XRecursiveDo, -XBlockArguments, -XQuasiQuotes] # These are just too annoying - ignore: { name: Redundant do }