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 } diff --git a/app/Main.hs b/app/Main.hs index 496a8a1e..e4e471ae 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,9 +80,15 @@ 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 + 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 |+ "'." + 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/coffer.cabal b/coffer.cabal index cb9cbf2d..dbb406e6 100644 --- a/coffer.cabal +++ b/coffer.cabal @@ -26,6 +26,8 @@ library Backend.Vault.Kv.Internal BackendName Backends + CLI.EditorMode + CLI.EntryView CLI.Parser CLI.PrettyPrint CLI.Types @@ -106,11 +108,14 @@ library , lens-aeson , megaparsec , mtl + , nyan-interpolation , optparse-applicative , polysemy + , process , servant , servant-client , servant-client-core + , temporary , text , time , time-compat @@ -255,6 +260,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 +321,13 @@ test-suite test tasty-discover:tasty-discover build-depends: base >=4.14.3.0 && <5 + , coffer + , containers + , hedgehog + , megaparsec + , raw-strings-qq , tasty + , tasty-hedgehog + , tasty-hunit + , text default-language: Haskell2010 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 new file mode 100644 index 00000000..b61fe32f --- /dev/null +++ b/lib/CLI/EditorMode.hs @@ -0,0 +1,162 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module CLI.EditorMode where + +import CLI.EntryView +import CLI.Types +import Control.Lens +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 + +data AnnotatedLine = AnnotatedLine + { _alLine :: Text + , _alErrors :: [Text] + } + +makeLenses 'AnnotatedLine + +mkAnnotatedLine :: Text -> AnnotatedLine +mkAnnotatedLine t = AnnotatedLine t [] + +headerExample :: Text +headerExample = [int|s| +# Example: +# +# path = backend#/path/to/entry +# +# [fields] +# public-field = public contents +# private-field =~ private contents +# multiline-thing = """ +# multiline +# contents +# """ +# +# [tags] +# first-tag +# important +|] + +renderEditorFile :: CreateOptions -> Text +renderEditorFile opts = pretty entryView + where + publicFields = coFields opts <&> \field -> FieldInfoView field False + privateFields = coPrivateFields opts <&> \field -> FieldInfoView field True + entryView = EntryView (coQPath opts) (publicFields <> privateFields) (coTags opts) + +setOpts :: CreateOptions -> EntryView -> CreateOptions +setOpts opts entryView = opts + { coQPath = qPath + , coTags = tags + , coFields = publicFields + , coPrivateFields = privateFields + } + where + qPath = entryView ^. mQEntryPath + 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 + 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 + + 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 + & T.strip + + 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 + +{- | 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/EntryView.hs b/lib/CLI/EntryView.hs new file mode 100644 index 00000000..510f35e2 --- /dev/null +++ b/lib/CLI/EntryView.hs @@ -0,0 +1,171 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module CLI.EntryView + ( FieldInfoView (..) + , fieldInfo + , private + , EntryView (..) + , mQEntryPath + , entryTags + , fields + , parseEntryView + ) where + +import CLI.Parser (MParser, endOfLineOrFile) +import CLI.Types (FieldInfo(FieldInfo, fiContents, fiName)) +import Coffer.Path (EntryPath, QualifiedPath, mkQualifiedEntryPath) +import Control.Applicative (Alternative(many, (<|>)), empty) +import Control.Lens +import Control.Monad (void) +import Data.Set (Set) +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, 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 + { evMQEntryPath :: Maybe (QualifiedPath EntryPath) + , evFields :: [FieldInfoView] + , evEntryTags :: Set EntryTag + } + deriving stock (Show, Eq) +makeLensesWith abbreviatedFields ''EntryView + +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 + failAction :: Text -> MParser a + failAction errMsg = do + P.setOffset offset + fail $ T.unpack errMsg + +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 + +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) + + let fieldInfo = FieldInfo fieldName fieldContents + let private = delimeter == "=~" + + pure $ FieldInfoView fieldInfo private + where + -- | 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/Parser.hs b/lib/CLI/Parser.hs index be3a2d45..534f58f9 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -5,12 +5,13 @@ {-# LANGUAGE OverloadedLists #-} module CLI.Parser - ( parserInfo + ( -- * optparse-applicative + parserInfo + -- * Megaparsec + , MParser + , endOfLineOrFile ) 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) @@ -29,14 +30,17 @@ 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 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) #-} @@ -118,12 +122,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' @@ -328,23 +334,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 -> @@ -353,13 +342,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" @@ -382,36 +364,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 @@ -419,7 +385,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 +509,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 +584,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 +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/CLI/Types.hs b/lib/CLI/Types.hs index 97cfbc49..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 @@ -167,7 +168,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/lib/Coffer/Path.hs b/lib/Coffer/Path.hs index fdd6cfcc..918247d3 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) @@ -177,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) = @@ -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/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 a27623ae..4d771552 100644 --- a/package.yaml +++ b/package.yaml @@ -91,7 +91,6 @@ library: - ansi-terminal - containers - extra - - extra - fmt - hashable - http-client @@ -101,11 +100,14 @@ library: - lens-aeson - megaparsec - mtl + - nyan-interpolation - optparse-applicative - polysemy + - process - servant - servant-client - servant-client-core + - temporary - text - time - time-compat @@ -134,7 +136,16 @@ tests: ghc-options: - -threaded dependencies: + - coffer + - containers + - hedgehog + - megaparsec + - raw-strings-qq - tasty + - tasty-hedgehog + - tasty-hunit + - text + doctests: source-dirs: tests/doctests main: Doctests.hs 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..6e174ddb 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'. @@ -76,6 +77,7 @@ 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/'. 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 - < +-- +-- SPDX-License-Identifier: MPL-2.0 + +module Test.CLI.EditorMode where + +import CLI.EditorMode (renderEditorFile) +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 +import Test.Util +import Text.RawString.QQ (r) + +hprop_render_parse_roundtrip :: Property +hprop_render_parse_roundtrip = property $ do + 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 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 parseEntryView + [r| +path = /entry/path + +# comment1 +[fields] + +# comment2 +field1 = f1 + +# comment3 +field2=f2 + +field3 = + +field4 = """ +first line: + second line + third line + +""" + +field5 = âПривет😱👪日本🤔🤔 +# comment4 +privatefield1 =~ pf1 +# comment5 +privatefield2 =~ pf2 + +[tags] +tag1 +important + + |] + ( 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 parseEntryView + [r|path = /path +[fields] +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [] + S.empty + ) + + 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 parseEntryView + [r|path = /path +[fields] +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 parseEntryView + [r|path = /path +[fields] +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [] + S.empty + ) + +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:6: + | +3 | name contents + | ^^ +unexpected "co" +expecting "=~" or '=' +|] + +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 +[tags]|] + ( EntryView + (Just (unsafeFromRight $ mkQualifiedEntryPath "/path")) + [ FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "name1") (FieldValue "contents1")) False + , FieldInfoView (FieldInfo (unsafeFromRight $ newFieldKey "name2") (FieldValue "contents2")) False + ] + S.empty + ) + + + parserShouldSucceed parseEntryView + [r|path = /path +[fields] + name = contents +[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 new file mode 100644 index 00000000..389405b3 --- /dev/null +++ b/tests/test/Test/Util.hs @@ -0,0 +1,128 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module Test.Util + ( unsafeFromRight + + -- * hunit helpers + , parserShouldSucceed + , parserShouldFail + + -- * hedgehog helpers + , hparserShouldSucceed + + -- * hedgehog generators + , genQualifiedEntryPath + , genFieldInfo + , genEntryTag + ) where + +import BackendName (BackendName, backendNameCharSet, newBackendName) +import CLI.Parser +import CLI.Types (FieldInfo(..)) +import Coffer.Path + (EntryPath(..), PathSegment, QualifiedPath(QualifiedPath), mkPathSegment, + pathSegmentAllowedCharacters) +import Data.Text (Text) +import Entry (EntryTag, FieldKey, FieldValue(FieldValue), keyCharSet, newEntryTag, 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 + +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 +---------------------------------------------------------------------------- + +genEntryPath :: Gen EntryPath +genEntryPath = EntryPath <$> Gen.nonEmpty (Range.linear 1 3) genPathSegment + +genPathSegment :: Gen PathSegment +genPathSegment = genFromCharSet 1 5 pathSegmentAllowedCharacters mkPathSegment + +genFieldKey :: Gen FieldKey +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 + <*> 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