{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use maybe" #-} {-| Functions to import and export tasks -} module ImportExport where import Protolude ( Applicative (pure), Bool (..), Char, Either (..), Eq ((==)), FilePath, Foldable (foldl), Functor (fmap), Hashable (hash), IO, Integral (toInteger), Maybe (..), Num (abs), Semigroup ((<>)), Text, Traversable (sequence), die, fromMaybe, putErrLn, rightToMaybe, show, stderr, toStrict, ($), (&), (+), (.), (<$>), (<&>), (=<<), (||), ) import Protolude qualified as P import Config ( Config (dataDir, dbName, hooks), HookSet (post, pre), HooksConfig (modify), ) import Control.Arrow ((>>>)) import Control.Monad.Catch (catchAll) import Data.Aeson (Value, object, (.=)) import Data.Aeson as Aeson ( Value (Array, Object, String), eitherDecode, encode, ) import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types (Parser, parseMaybe) import Data.ByteString.Lazy qualified as BSL import Data.Csv qualified as Csv import Data.Hourglass ( TimeFormat (toFormat), timePrint, ) import Data.Monoid.Extra (mwhen) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL import Data.ULID (ulidFromInteger) import Data.ULID.TimeStamp (ULIDTimeStamp, getULIDTimeStamp) import Data.Vector qualified as V import Data.Yaml ( ParseException (InvalidYaml), YamlException (YamlException, YamlParseException), YamlMark (YamlMark), ) import Data.Yaml qualified as Yaml import Database.SQLite.Simple (Connection, Only (Only), query, query_) import Database.SQLite.Simple.QQ (sql) import FullTask (FullTask (..)) import Hooks (HookResult (message, task), executeHooks, formatHookResult) import ImportTask ( ImportTask (..), emptyImportTask, importTaskToFullTask, importUtcFormat, setMissingFields, ) import Lib ( addEmptyTask, execWithConn, execWithTask, insertNotes, insertRecord, insertTags, updateTask, ) import Note (Note (..)) import Prettyprinter ( Doc, Pretty (pretty), annotate, dquotes, hardline, vsep, (<+>), ) import Prettyprinter.Internal.Type (Doc (Empty)) import Prettyprinter.Render.Terminal ( AnsiStyle, Color (Red), hPutDoc, putDoc, ) import System.Directory (createDirectoryIfMissing, listDirectory, removeFile) import System.FilePath (isExtensionOf, takeExtension, ()) import System.Hourglass (timeCurrentP) import System.Posix.User (getEffectiveUserName) import System.Process (readProcess) import Task (Task (..), emptyTask, setMetadataField, taskToEditableMarkdown) import Text.Editor (runUserEditorDWIM, yamlTemplate) import Text.Parsec.Rfc2822 qualified as Email import Text.ParserCombinators.Parsec as Parsec (parse) import Text.PortableLines.ByteString.Lazy (lines8) import Time.System (dateCurrent, timeCurrent) import Utils ( IdText, colr, countCharTL, emptyUlid, formatElapsedP, setDateTime, ulidTextToDateTime, zeroUlidTxt, zonedTimeToDateTime, (), (<$$>), ) insertImportTask :: Config -> Connection -> ImportTask -> IO (Doc AnsiStyle) insertImportTask conf connection importTask = do effectiveUserName <- getEffectiveUserName let taskNorm = importTask.task { Task.user = if importTask.task.user == "" then T.pack effectiveUserName else importTask.task.user } insertRecord "tasks" connection taskNorm tagWarnings <- insertTags conf connection (ulidTextToDateTime taskNorm.ulid) taskNorm importTask.tags noteWarnings <- insertNotes conf connection (ulidTextToDateTime taskNorm.ulid) taskNorm importTask.notes pure $ tagWarnings <$$> noteWarnings <$$> "📥 Imported task" <+> dquotes (pretty taskNorm.body) <+> "with ulid" <+> dquotes (pretty taskNorm.ulid) <+> hardline importJson :: Config -> Connection -> IO (Doc AnsiStyle) importJson conf connection = do content <- BSL.getContents case Aeson.eitherDecode content of Left error -> die $ T.pack error <> " in task \n" <> show content Right importTaskRec -> do importTaskNorm <- importTaskRec & setMissingFields insertImportTask conf connection importTaskNorm decodeAndInsertYaml :: Config -> Connection -> BSL.LazyByteString -> IO (Doc AnsiStyle) decodeAndInsertYaml conf conn content = do case content & BSL.toStrict & Yaml.decodeEither' of Left error -> die $ T.pack $ Yaml.prettyPrintParseException error Right importTaskRec -> do importTaskNorm <- importTaskRec & setMissingFields insertImportTask conf conn importTaskNorm importYaml :: Config -> Connection -> IO (Doc AnsiStyle) importYaml conf conn = do content <- BSL.getContents decodeAndInsertYaml conf conn content parseMarkdownWithFrontMatter :: BSL.LazyByteString -> Either Text (BSL.LazyByteString, Text) parseMarkdownWithFrontMatter content = do let contentText = TL.decodeUtf8 content contentLines = TL.lines contentText isClosingDelimiter line = line == "---" || line == "..." case contentLines of ("---" : rest) -> do let (frontMatterLines, bodyLines) = P.break isClosingDelimiter rest case bodyLines of (closingDelim : actualBody) | isClosingDelimiter closingDelim -> do let frontMatterYaml = TL.intercalate "\n" frontMatterLines bodyTextLazy = actualBody & TL.intercalate "\n" & TL.strip -- Only keep trailing newlines for multiline bodies noTrailingNewline = countCharTL '\n' bodyTextLazy == 0 bodyText = bodyTextLazy & TL.toStrict frontMatterWithBody = frontMatterYaml <> "\nbody: |" <> mwhen noTrailingNewline "-" <> "\n" <> TL.fromStrict (bodyText & T.lines <&> (" " <>) & T.unlines) Right (TL.encodeUtf8 frontMatterWithBody, bodyText) _ -> Left "Missing closing front-matter delimiter '---' or '...'" _ -> do let bodyText = TL.toStrict contentText yamlWithBody = "body: |\n" <> TL.fromStrict (T.unlines $ T.lines bodyText <&> (" " <>)) Right (TL.encodeUtf8 yamlWithBody, bodyText) importMarkdown :: Config -> Connection -> IO (Doc AnsiStyle) importMarkdown conf conn = do content <- BSL.getContents case parseMarkdownWithFrontMatter content of Left error -> die error Right (yamlContent, _) -> decodeAndInsertYaml conf conn yamlContent importEml :: Config -> Connection -> IO (Doc AnsiStyle) importEml conf connection = do content <- BSL.getContents case Parsec.parse Email.message "" content of Left error -> die $ show error Right email -> insertImportTask conf connection $ emailToImportTask email emailToImportTask :: Email.GenericMessage BSL.ByteString -> ImportTask emailToImportTask email@(Email.Message headerFields msgBody) = let addBody (ImportTask task notes tags) = ImportTask task { Task.body = task.body <> ( msgBody & lines8 <&> (TL.decodeUtf8 >>> toStrict) & T.unlines & T.dropEnd 1 ) } notes tags namesToJson names = Array $ V.fromList $ names <&> ( \(Email.NameAddr name emailAddress) -> Object $ KeyMap.fromList [ ("name", Aeson.String $ T.pack $ fromMaybe "" name) , ("email", Aeson.String $ T.pack emailAddress) ] ) addHeaderToTask :: ImportTask -> Email.Field -> ImportTask addHeaderToTask impTask@(ImportTask task notes tags) headerValue = case headerValue of Email.Date emailDate -> let utc = zonedTimeToDateTime emailDate ulidGeneratedRes = (email & show :: Text) & (hash >>> toInteger >>> abs >>> ulidFromInteger) ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` utc in ImportTask task { Task.ulid = T.toLower $ show ulidCombined , Task.modified_utc = T.pack $ timePrint (toFormat importUtcFormat) utc } notes tags Email.From names -> ImportTask (setMetadataField "from" (namesToJson names) task) notes tags Email.To names -> ImportTask (setMetadataField "to" (namesToJson names) task) notes tags Email.MessageID msgId -> ImportTask (setMetadataField "messageId" (Aeson.String $ T.pack msgId) task) notes tags Email.Subject subj -> ImportTask task{Task.body = task.body <> T.pack subj} notes tags Email.Keywords kwords -> ImportTask task notes (tags <> fmap (T.unwords . fmap T.pack) kwords) Email.Comments cmnts -> ImportTask (setMetadataField "comments" (Aeson.String $ T.pack cmnts) task) notes tags _ -> impTask in foldl addHeaderToTask (addBody emptyImportTask) headerFields isDirError :: Config -> FilePath -> P.SomeException -> IO (Doc AnsiStyle) isDirError conf filePath exception = do if "is a directory" `T.isInfixOf` show exception then do hPutDoc stderr $ annotate (colr conf Red) $ ("ERROR: \"" <> pretty filePath <> "\" is a directory. ") <> "Use `importdir` instead." die "" else die $ show exception importFile :: Config -> Connection -> FilePath -> IO (Doc AnsiStyle) importFile conf conn filePath = do let decodeAndInsertMd content = case parseMarkdownWithFrontMatter content of Left error -> die error Right (yamlContent, _) -> decodeAndInsertYaml conf conn yamlContent catchAll ( do content <- BSL.readFile filePath let fileExt = filePath & takeExtension case fileExt of ".json" -> do let decodeResult = Aeson.eitherDecode content case decodeResult of Left error -> die $ T.pack error <> " in task \n" <> show content Right importTaskRec -> do importTaskNorm <- importTaskRec & setMissingFields insertImportTask conf conn importTaskNorm ".yaml" -> decodeAndInsertYaml conf conn content ".yml" -> decodeAndInsertYaml conf conn content ".md" -> decodeAndInsertMd content ".markdown" -> decodeAndInsertMd content ".eml" -> case Parsec.parse Email.message filePath content of Left error -> die $ show error Right email -> insertImportTask conf conn $ emailToImportTask email _ -> die $ T.pack $ "File type " <> fileExt <> " is not supported" ) (isDirError conf filePath) filterImportable :: FilePath -> Bool filterImportable filePath = (".json" `isExtensionOf` filePath) || (".yaml" `isExtensionOf` filePath) || (".yml" `isExtensionOf` filePath) || (".md" `isExtensionOf` filePath) || (".markdown" `isExtensionOf` filePath) || (".eml" `isExtensionOf` filePath) importDir :: Config -> Connection -> FilePath -> IO (Doc AnsiStyle) importDir conf connection dirPath = do files <- listDirectory dirPath resultDocs <- files & P.filter filterImportable <&> (dirPath ) & P.mapM (importFile conf connection) pure $ P.fold resultDocs ingestFile :: Config -> Connection -> FilePath -> IO (Doc AnsiStyle) ingestFile conf connection filePath = do let ingestYaml content = do let decodeResult = Yaml.decodeEither' (BSL.toStrict content) case decodeResult of Left error -> die $ T.pack $ Yaml.prettyPrintParseException error Right importTaskRec -> do importTaskNorm <- importTaskRec & setMissingFields sequence [ insertImportTask conf connection importTaskNorm , editTaskByTask conf OpenEditor connection importTaskNorm.task ] ingestMd content = do case parseMarkdownWithFrontMatter content of Left error -> die error Right (yamlContent, _) -> ingestYaml yamlContent catchAll ( do content <- BSL.readFile filePath resultDocs <- case takeExtension filePath of ".json" -> do let decodeResult = Aeson.eitherDecode content case decodeResult of Left error -> die $ T.pack error <> " in task \n" <> show content Right importTaskRec -> do importTaskNorm <- importTaskRec & setMissingFields sequence [ insertImportTask conf connection importTaskNorm , editTaskByTask conf OpenEditor connection importTaskNorm.task ] ".yaml" -> ingestYaml content ".yml" -> ingestYaml content ".md" -> ingestMd content ".markdown" -> ingestMd content ".eml" -> case Parsec.parse Email.message filePath content of Left error -> die $ show error Right email -> do let taskRecord@ImportTask{task} = emailToImportTask email sequence [ insertImportTask conf connection taskRecord , editTaskByTask conf OpenEditor connection task ] fileExt -> die $ T.pack $ "File type " <> fileExt <> " is not supported" removeFile filePath pure $ P.fold resultDocs <> ("❌ Deleted file" <+> dquotes (pretty filePath)) ) (isDirError conf filePath) ingestDir :: Config -> Connection -> FilePath -> IO (Doc AnsiStyle) ingestDir conf connection dirPath = do files <- listDirectory dirPath resultDocs <- files & P.filter filterImportable <&> (dirPath ) & P.mapM (ingestFile conf connection) pure $ P.fold resultDocs -- TODO: Use Task instead of FullTask to fix broken notes export dumpCsv :: Config -> IO (Doc AnsiStyle) dumpCsv conf = do execWithConn conf $ \connection -> do rows :: [FullTask] <- query_ connection "SELECT * FROM tasks_view" pure $ pretty $ TL.decodeUtf8 $ Csv.encodeDefaultOrderedByName rows getNdjsonLines :: Connection -> IO [Doc AnsiStyle] getNdjsonLines conn = do -- TODO: Fix after tasks_view is updated to include notes tasksWithoutNotes :: [FullTask] <- query_ conn "SELECT * FROM tasks_view" tasks <- tasksWithoutNotes & P.mapM ( \task -> do notes <- query conn [sql| SELECT ulid, note FROM task_to_note WHERE task_ulid == ? |] (Only task.ulid) pure $ task { FullTask.notes = if P.null notes then Nothing else Just notes } ) pure $ tasks <&> (Aeson.encode >>> TL.decodeUtf8 >>> pretty) dumpNdjson :: Config -> IO (Doc AnsiStyle) dumpNdjson conf = do execWithConn conf $ \conn -> do lines <- getNdjsonLines conn pure $ vsep lines dumpJson :: Config -> IO (Doc AnsiStyle) dumpJson conf = do -- TODO: Use Task instead of FullTask to fix broken notes export execWithConn conf $ \connection -> do tasks :: [FullTask] <- query_ connection "SELECT * FROM tasks_view" pure $ pretty $ fmap (TL.decodeUtf8 . Aeson.encode) tasks dumpSql :: Config -> IO (Doc AnsiStyle) dumpSql conf = do result <- readProcess "sqlite3" [ conf.dataDir conf.dbName , ".dump" ] [] pure $ pretty result backupDatabase :: Config -> IO (Doc AnsiStyle) backupDatabase conf = do now <- timeCurrent let fileUtcFormat = toFormat ("YYYY-MM-DDtHMI" :: [Char]) backupDirName = "backups" backupDirPath = conf.dataDir backupDirName backupFilePath = backupDirPath timePrint fileUtcFormat now <> ".db" -- Create directory (and parents because of True) createDirectoryIfMissing True backupDirPath result <- pretty <$> readProcess "sqlite3" [ conf.dataDir conf.dbName , ".backup '" <> backupFilePath <> "'" ] [] pure $ result <> hardline <> pretty ( "✅ Backed up database \"" <> conf.dbName <> "\" to \"" <> backupFilePath <> "\"" ) data EditMode = ApplyPreEdit (P.ByteString -> P.ByteString) | OpenEditor | OpenEditorRequireEdit {-| Edit task until it's valid Markdown with frontmatter and can be decoded. | Return the the tuple `(task, valid YAML content from frontmatter)` -} editUntilValidMarkdown :: EditMode -> Connection -> P.ByteString -> P.ByteString -> IO (Either ParseException (ImportTask, P.ByteString)) editUntilValidMarkdown editMode conn initialMarkdown wipMarkdown = do markdownAfterEdit <- case editMode of ApplyPreEdit editFunc -> pure $ editFunc wipMarkdown OpenEditor -> runUserEditorDWIM yamlTemplate wipMarkdown OpenEditorRequireEdit -> runUserEditorDWIM yamlTemplate wipMarkdown if markdownAfterEdit == initialMarkdown then pure $ Left $ InvalidYaml $ Just $ YamlException $ case editMode of -- Content doesn't have to be changed -> log nothing OpenEditor -> "" _ -> "⚠️ Nothing changed" else do case markdownAfterEdit & BSL.fromStrict & parseMarkdownWithFrontMatter of Left error -> do putErrLn $ error <> "\n" editUntilValidMarkdown editMode conn initialMarkdown markdownAfterEdit Right (yamlContent, _) -> do case BSL.toStrict yamlContent & Yaml.decodeEither' of Left error -> do case error of -- Adjust the line and column numbers to be 1-based InvalidYaml (Just (YamlParseException prblm ctxt (YamlMark idx line col))) -> let yamlMark = YamlMark (idx + 1) (line + 1) (col + 1) in putErrLn $ Yaml.prettyPrintParseException ( InvalidYaml (Just (YamlParseException prblm ctxt yamlMark)) ) <> "\n" _ -> putErrLn $ Yaml.prettyPrintParseException error <> "\n" editUntilValidMarkdown editMode conn initialMarkdown markdownAfterEdit Right newTask -> do pure $ Right (newTask, BSL.toStrict yamlContent) insertTaskFromEdit :: Config -> Connection -> ImportTask -> P.ByteString -> P.Text -> IO (Doc AnsiStyle) insertTaskFromEdit conf conn importTaskRec newContent modified_utc = do -- Insert empty task if the edited task was newly created ulid <- if T.null importTaskRec.task.ulid then addEmptyTask conf conn <&> Task.ulid else pure importTaskRec.task.ulid effectiveUserName <- getEffectiveUserName now <- getULIDTimeStamp <&> (show @ULIDTimeStamp >>> T.toLower) let parseMetadata :: Value -> Parser Bool parseMetadata val = case val of Object obj -> do let mdataMaybe = KeyMap.lookup "metadata" obj pure $ case mdataMaybe of Just (Object _) -> True _ -> False _ -> pure False hasMetadata = parseMaybe parseMetadata =<< rightToMaybe (Yaml.decodeEither' newContent) taskFixed = importTaskRec.task { Task.ulid = ulid , Task.user = if importTaskRec.task.user == "" then T.pack effectiveUserName else importTaskRec.task.user , Task.metadata = if hasMetadata == Just True then importTaskRec.task.metadata else Nothing , -- Set to previous value to force SQL trigger to update it Task.modified_utc = modified_utc } notesCorrectUtc = importTaskRec.notes <&> ( \note -> note { Note.ulid = if zeroUlidTxt `T.isPrefixOf` note.ulid then note.ulid & T.replace zeroUlidTxt now else note.ulid } ) updateTask conn taskFixed nowDateTime <- dateCurrent let taskFixedUtc = if P.isNothing taskFixed.closed_utc then taskFixed else taskFixed { Task.modified_utc = nowDateTime & timePrint (toFormat importUtcFormat) & T.pack } -- TODO: Remove after it was added to `createSetClosedUtcTrigger` -- Update again with the same `state` field to avoid firing -- SQL trigger which would overwrite the `closed_utc` field. P.when (P.isJust taskFixed.closed_utc) $ do updateTask conn taskFixedUtc tagWarnings <- insertTags conf conn Nothing taskFixedUtc importTaskRec.tags noteWarnings <- insertNotes conf conn Nothing taskFixedUtc notesCorrectUtc args <- P.getArgs postModifyResults <- executeHooks ( TL.toStrict $ TL.decodeUtf8 $ Aeson.encode $ object [ "arguments" .= args , "taskModified" .= taskFixedUtc -- TODO: Add tags and notes to task ] ) conf.hooks.modify.post let postModifyHookMsg = ( postModifyResults <&> \case Left error -> "ERROR:" <+> pretty error Right hookResult -> pretty hookResult.message & P.fold ) <> hardline pure $ tagWarnings <$$> noteWarnings <$$> "✏️ Edited task" <+> dquotes (pretty taskFixed.body) <+> "with ulid" <+> dquotes (pretty taskFixed.ulid) postModifyHookMsg enterTask :: Config -> Connection -> IO (Doc AnsiStyle) enterTask conf conn = do taskMarkdown <- taskToEditableMarkdown conn emptyTask taskMarkdownTupleRes <- editUntilValidMarkdown OpenEditorRequireEdit conn taskMarkdown taskMarkdown case taskMarkdownTupleRes of Left error -> case error of InvalidYaml (Just (YamlException "")) -> pure P.mempty _ -> pure $ pretty $ Yaml.prettyPrintParseException error Right (importTaskRec, newContent) -> do modified_utc <- formatElapsedP conf timeCurrentP insertTaskFromEdit conf conn importTaskRec newContent modified_utc editTaskByTask :: Config -> EditMode -> Connection -> Task -> IO (Doc AnsiStyle) editTaskByTask conf editMode conn taskToEdit = do taskMarkdown <- taskToEditableMarkdown conn taskToEdit taskMarkdownTupleRes <- editUntilValidMarkdown editMode conn taskMarkdown taskMarkdown case taskMarkdownTupleRes of Left error -> case error of InvalidYaml (Just (YamlException "")) -> pure P.mempty _ -> pure $ pretty $ Yaml.prettyPrintParseException error Right (importTaskRec, newContent) -> do insertTaskFromEdit conf conn importTaskRec newContent taskToEdit.modified_utc -- TODO: Eliminate code duplications with `addTask` editTask :: Config -> Connection -> IdText -> IO (Doc AnsiStyle) editTask conf conn idSubstr = do execWithTask conf conn idSubstr $ \taskToEdit -> do let importTaskDraft = emptyImportTask { ImportTask.task = taskToEdit , ImportTask.tags = [] , ImportTask.notes = [] } args <- P.getArgs preModifyResults <- executeHooks ( TL.toStrict $ TL.decodeUtf8 $ Aeson.encode $ object [ "arguments" .= args , "taskToModify" .= importTaskToFullTask importTaskDraft ] ) conf.hooks.modify.pre -- Maybe the task was changed by the hook (importTask, preModifyHookMsg) <- case preModifyResults of [] -> pure (importTaskDraft, Empty) [Left error] -> do _ <- P.exitFailure pure (importTaskDraft, pretty error) [Right hookResult] -> do case hookResult.task of Nothing -> pure (importTaskDraft, Empty) Just importTask -> do fullImportTask <- setMissingFields importTask { ImportTask.task = importTask.task{Task.ulid = taskToEdit.ulid} } pure (fullImportTask, formatHookResult conf hookResult) _ -> do pure ( importTaskDraft , annotate (colr conf Red) $ "ERROR: Multiple pre-add hooks are not supported yet. " <> "None of the hooks were executed." ) updateTask conn importTask.task warnings <- insertTags conf conn Nothing importTask.task importTask.tags putDoc $ preModifyHookMsg warnings hardline editTaskByTask conf OpenEditorRequireEdit conn importTask.task