Editor mode implemented

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

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]

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

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

lib/CLI/EditorMode.hs

@@ -0,0 +1,162 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io>
+--
+-- 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)