tasklite-core 0.3.0.0 → 0.5.0.0
raw patch · 19 files changed
+6673/−4562 lines, 19 filesdep +MissingHdep +extradep +terminal-sizedep ~ansi-terminaldep ~bytestringdep ~criterion
Dependencies added: MissingH, extra, terminal-size
Dependency ranges changed: ansi-terminal, bytestring, criterion, hspec, iso8601-duration, neat-interpolation, ulid
Files
- example-config.yaml +9/−0
- source/Cli.hs +269/−108
- source/Config.hs +89/−35
- source/FullTask.hs +2/−2
- source/Hooks.hs +157/−0
- source/ImportExport.hs +840/−792
- source/ImportTask.hs +502/−0
- source/Lib.hs +3541/−2941
- source/Migrations.hs +2/−2
- source/Task.hs +80/−59
- source/Utils.hs +90/−55
- tasklite-core.cabal +19/−7
- test/ImportExportSpec.hs +315/−0
- test/LibSpec.hs +619/−67
- test/MigrationsSpec.hs +22/−0
- test/Spec.hs +1/−444
- test/SpecHook.hs +7/−0
- test/TypesSpec.hs +54/−50
- test/UtilsSpec.hs +55/−0
example-config.yaml view
@@ -1,4 +1,9 @@ tableName: tasks++# Select columns and their order for the table view.+# `body` should be the last column, as its width varies for each task.+columns: [id, prio, openedUtc, age, body]+ idWidth: 4 idStyle: green priorityStyle: magenta@@ -8,6 +13,10 @@ closedStyle: dull black dueStyle: yellow overdueStyle: red+# Shows `Opened UTC` column per default.+# Set this to `true` to show an `Age` column with a+# human readable duration of the task's age.+# useDuration: false tagStyle: blue utcFormat: YYYY-MM-DD H:MI:S #| FIXME: Blocked by https://github.com/vincenthz/hs-hourglass/issue
source/Cli.hs view
@@ -4,6 +4,7 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use camelCase" #-}+{-# HLINT ignore "Replace case with maybe" #-} module Cli where @@ -38,6 +39,8 @@ ($), (&), (&&),+ (*),+ (-), (.), (<$>), (<&>),@@ -86,6 +89,7 @@ idm, info, internal,+ long, maybeReader, metavar, noIntersperse,@@ -94,19 +98,24 @@ progDescDoc, renderFailure, strArgument,+ switch, ) import Options.Applicative.Help.Chunk (Chunk (Chunk), (<<+>>)) import Options.Applicative.Help.Core (parserHelp) import Paths_tasklite_core (version) import Prettyprinter ( Doc,+ LayoutOptions (layoutPageWidth),+ PageWidth (AvailablePerLine), Pretty (pretty), annotate,+ defaultLayoutOptions, dquotes, enclose, hardline, hcat, indent,+ layoutPretty, parens, (<+>), )@@ -115,10 +124,10 @@ Color (Black, Blue, Cyan, Red, Yellow), bold, color,- colorDull, hPutDoc,- putDoc,+ renderIO, )+import System.Console.Terminal.Size (Window (Window, height, width), size) import System.Directory ( Permissions, XdgDirectory (..),@@ -129,7 +138,8 @@ getXdgDirectory, listDirectory, )-import System.FilePath ((</>))+import System.FilePath (hasExtension, (</>))+import System.IO (stdout) import System.Process (readProcess) import Time.System (timeCurrentP) @@ -138,7 +148,10 @@ HookSet (..), HooksConfig (..), addHookFilesToConfig,+ defaultConfig, )+import Control.Arrow ((>>>))+import Hooks (executeHooks, formatHookResult) import ImportExport ( backupDatabase, dumpCsv,@@ -146,9 +159,14 @@ dumpNdjson, dumpSql, editTask,+ enterTask,+ importDir, importEml, importFile, importJson,+ importMarkdown,+ importYaml,+ ingestDir, ingestFile, ) import Lib (@@ -171,6 +189,7 @@ infoTask, listAll, listNoTag,+ listNotes, listOldTasks, listProjects, listReady,@@ -216,14 +235,17 @@ ) import Migrations (runMigrations) import Server (startServer)-import System.Environment (getProgName)+import System.Environment (getProgName, lookupEnv) import Utils ( IdText, ListModifiedFlag (AllItems, ModifiedItemsOnly), TagText,- executeHooks,+ colr,+ colrDull, parseUtc,- ulid2utc,+ removeColorsIfNecessary,+ ulidText2utc,+ (<!!>), ) @@ -242,7 +264,8 @@ | AddSell [Text] | AddPay [Text] | AddShip [Text]- | LogTask [Text] --+ | LogTask [Text]+ | EnterTask -- {- Modify -} | ReadyOn DateTime [IdText] | WaitTasks [IdText]@@ -252,6 +275,7 @@ | DoTasks [IdText] | DoOneTask IdText (Maybe [Text]) | EndTasks [IdText]+ | EndOneTask IdText (Maybe [Text]) | TrashTasks [IdText] | DeleteTasks [IdText] | RepeatTasks Iso.Duration [IdText]@@ -276,13 +300,17 @@ -- \| Undo -- Revert last change InfoTask IdText | NextTask- | RandomTask+ | RandomTask (Maybe [Text]) | FindTask Text -- {- I/O -} | ImportFile FilePath+ | ImportDir FilePath | ImportJson+ | ImportYaml+ | ImportMarkdown | ImportEml | IngestFile FilePath+ | IngestDir FilePath | Csv | Json | Ndjson@@ -294,7 +322,7 @@ | ListHead | ListNewFiltered (Maybe [Text]) | ListOld- | ListOpen+ | ListOpen (Maybe [Text]) | ListModified | ListModifiedOnly | ListDone@@ -314,6 +342,7 @@ -- \| Views -- List all available views | Tags -- List all used tags | Projects -- List all active tags+ | Notes -- List all notes | Stats -- List statistics about tasks {- Unset -} | -- \| Active -- Started tasks@@ -345,6 +374,13 @@ deriving (Show, Eq) +data CliOptions = CliOptions+ { noColorFlag :: Bool+ , cliCommand :: Command+ }+ deriving (Show, Eq)++ nameToAliasList :: [(Text, Text)] nameToAliasList = [ ("annotate", "note")@@ -387,7 +423,7 @@ <+> "Use" <+> dquotes (pretty alias) <+> "instead."- <> hardline+ <> hardline getCommand :: (Text, Text) -> Mod CommandFields Command@@ -422,8 +458,8 @@ , advanced_sec , alias_sec , unset_sec- , utils_sec- :: (Text, Text)+ , utils_sec ::+ (Text, Text) basic_sec = ("{{basic_sec}}", "Basic Commands") shortcut_sec = ("{{shortcut_sec}}", "Shortcuts to Add a Task") list_sec = ("{{list_sec}}", "List Commands")@@ -441,11 +477,21 @@ & fromString & Iso.parseDuration ++cliOptionsParser :: Config -> Parser CliOptions+cliOptionsParser conf =+ CliOptions+ <$> switch+ ( long "no-color"+ <> help "Disable color output. Can be set via NO_COLOR env var."+ )+ <*> commandParser conf+ {- FOURMOLU_DISABLE -} commandParser :: Config -> Parser Command commandParser conf = let- numTasks = show (headCount conf)+ numTasks = show conf.headCount in pure ListReady <|>@@ -464,6 +510,9 @@ (metavar "BODY" <> help "Body of the task"))) "Log an already completed task") + <> command "enter" (toParserInfo (pure EnterTask)+ "Open your default editor with an empty task template")+ <> command "readyon" (toParserInfo (ReadyOn <$> argument (maybeReader (parseUtc . T.pack)) (metavar "READY_UTC" <> help "Timestamp when task is ready")@@ -504,7 +553,13 @@ <> command "doall" (toParserInfo (DoTasks <$> some (strArgument idsVar)) "Mark one or more tasks as done") - <> command "end" (toParserInfo (EndTasks <$> some (strArgument idsVar))+ <> command "end" (toParserInfo (EndOneTask+ <$> strArgument idsVar+ <*> optional (some (strArgument (metavar "CLOSING_NOTE"+ <> help "Final note to explain why and how it was closed"))))+ "Mark a task as obsolete and add optional closing note")++ <> command "endall" (toParserInfo (EndTasks <$> some (strArgument idsVar)) "Mark a task as obsolete") <> command "edit" (toParserInfo (EditTask <$> strArgument idVar)@@ -557,8 +612,12 @@ <> command "next" (toParserInfo (pure NextTask) "Show the task with the highest priority") - <> command "random" (toParserInfo (pure RandomTask)- "Show a random open task")+ <> command "random"+ (toParserInfo+ (RandomTask <$> optional ( some+ (strArgument $ metavar "FILTER_EXP" <> help "Filter expressions")))+ "Show a random open task \+ \from the tasks filtered by the specified expressions") <> command "find" (toParserInfo (FindTask <$> strArgument (metavar "PATTERN" <> help "Search pattern"))@@ -661,8 +720,12 @@ <> command "all" (toParserInfo (pure ListAll) "List all tasks by creation UTC asc") - <> command "open" (toParserInfo (pure ListOpen)- "List all open tasks by priority desc")+ <> command "open"+ (toParserInfo+ (ListOpen <$> optional ( some+ (strArgument $ metavar "FILTER_EXP" <> help "Filter expressions")))+ "List all open tasks by priority desc \+ \filtered by the specified expression") <> command "modified" (toParserInfo (pure ListModified) "List all tasks by modified UTC desc")@@ -703,8 +766,7 @@ "List newest tasks by creation UTC desc (Open and Closed)") <> command "old" (toParserInfo (pure ListOld)- ("List " <> numTasks- <> " oldest open tasks by creation UTC asc"))+ ("List " <> numTasks <> " oldest open tasks by creation UTC asc")) -- <> command "asleep" (toParserInfo (pure ListAwake) -- "List all sleeping tasks by priority")@@ -723,14 +785,13 @@ <> command "done" (toParserInfo (pure ListDone)- ("List " <> numTasks- <> " done tasks by closing UTC desc"))+ ("List " <> numTasks <> " done tasks by closing UTC desc")) <> command "obsolete" (toParserInfo (pure ListObsolete)- "List all obsolete tasks by closing UTC")+ ("List " <> numTasks <> " obsolete tasks by closing UTC")) <> command "deletable" (toParserInfo (pure ListDeletable)- "List all deletable tasks by closing UTC")+ ("List " <> numTasks <> " deletable tasks by closing UTC")) -- <> command "expired" -- "List tasks which are obsolete, \@@ -752,7 +813,7 @@ (toParserInfo (RunFilter <$> some (strArgument $ metavar "FILTER_EXP" <> help "Filter expressions"))- "Get all tasks filtered by the specified expressions \+ "Get all tasks filtered by the specified expression \ \by priority") -- TODO: Replace with tasks and tags commands@@ -796,6 +857,9 @@ <> command "projects" (toParserInfo (pure Projects) "List all active tags (a.k.a projects) and their progress") + <> command "notes" (toParserInfo (pure Notes)+ "List all notes descending by creation UTC")+ <> command "stats" (toParserInfo (pure Stats) "Show statistics about tasks") @@ -807,19 +871,33 @@ <> command "import" (toParserInfo (ImportFile <$> strArgument (metavar "FILEPATH" <> help "Path to import file"))- "Import a .json or .eml file containing one task")+ "Import a .json, .yaml, .md, or .eml file containing one task") + <> command "importdir" (toParserInfo (ImportDir <$> strArgument+ (metavar "DIRECTORY_PATH" <> help "Path to directory"))+ "Import all .json, .yaml, .md, and .eml files in a directory")+ <> command "importjson" (toParserInfo (pure ImportJson) "Import one JSON object from stdin") + <> command "importyaml" (toParserInfo (pure ImportYaml)+ "Import one YAML object from stdin")++ <> command "importmd" (toParserInfo (pure ImportMarkdown)+ "Import one Markdown file (with optional YAML front-matter) from stdin")+ <> command "importeml" (toParserInfo (pure ImportEml) "Import one email from stdin") <> command "ingest" (toParserInfo (IngestFile <$> strArgument (metavar "FILEPATH" <> help "Path to file"))- ("Ingest a .json or .eml file containing one task "+ ("Ingest a .json, .yaml, .md, or .eml file containing one task " <> "(import, open in editor, delete the original file)")) + <> command "ingestdir" (toParserInfo (IngestDir <$> strArgument+ (metavar "DIRECTORY_PATH" <> help "Path to directory"))+ "Ingest all .json, .yaml, .md, and .eml files in a directory")+ <> command "csv" (toParserInfo (pure Csv) "Show tasks in CSV format") @@ -837,7 +915,9 @@ "Show SQL commands to create and populate database") <> command "backup" (toParserInfo (pure Backup)- "Create a backup of the tasks database at ~/tasklite/backups")+ ("Create a backup of the tasks database at "+ <> T.pack conf.dataDir <> "/backups"))+ ) <|> hsubparser@@ -956,7 +1036,7 @@ {- FOURMOLU_ENABLE -} -commandParserInfo :: Config -> ParserInfo Command+commandParserInfo :: Config -> ParserInfo CliOptions commandParserInfo conf = let versionDesc =@@ -966,21 +1046,21 @@ <> "\n" prettyVersion =- annotate (color Black) (pretty $ showVersion version)+ annotate (colr conf Black) (pretty $ showVersion version) header = annotate (bold <> color Blue) "TaskLite" <+> prettyVersion- <> hardline- <> hardline- <> annotate- (color Blue)- "Task-list manager powered by Haskell and SQLite"+ <> hardline+ <> hardline+ <> annotate+ (colr conf Blue)+ "Task-list manager powered by Haskell and SQLite" examples = do let mkBold = annotate bold . pretty . T.justifyRight 26 ' '- hiLite = enclose "`" "`" . annotate (color Cyan)+ hiLite = enclose "`" "`" . annotate (colr conf Cyan) "" <> hardline@@ -1005,7 +1085,7 @@ ) in info- (helper <*> commandParser conf)+ (helper <*> cliOptionsParser conf) ( noIntersperse <> briefDesc <> headerDoc (Just header)@@ -1045,8 +1125,8 @@ foldr replaceDocs docElems replacements -helpReplacements :: [(Text, Doc AnsiStyle)]-helpReplacements =+helpReplacements :: Config -> [(Text, Doc AnsiStyle)]+helpReplacements conf = [ basic_sec , shortcut_sec , list_sec@@ -1057,7 +1137,7 @@ , utils_sec , unset_sec ]- <&> (\(a, b) -> (a, annotate (colorDull Yellow) (pretty b <> ":")))+ <&> (\(a, b) -> (a, annotate (colrDull conf Yellow) (pretty b <> ":"))) getHelpText :: String -> Config -> Doc AnsiStyle@@ -1070,7 +1150,7 @@ & P.flip renderFailure progName & P.fst & T.pack- & spliceDocsIntoText helpReplacements+ & spliceDocsIntoText (helpReplacements conf) & hcat @@ -1092,7 +1172,7 @@ extendHelp theHelp = theHelp & show- & spliceDocsIntoText helpReplacements+ & spliceDocsIntoText (helpReplacements conf) & hcat handleException exception = do@@ -1101,13 +1181,11 @@ then pretty (show exception :: Text) else do let- theHelp =- parserHelp defaultPrefs $- (helper <*> commandParser conf)+ theHelp = parserHelp defaultPrefs (helper <*> cliOptionsParser conf) newHeader = Chunk ( Just $- annotate (color Red) $+ annotate (colr conf Red) $ "ERROR: Command \"" <> pretty cmd <> "\" does not exist"@@ -1123,15 +1201,20 @@ catchAll runCmd handleException -executeCLiCommand- :: Config- -> DateTime- -> Connection- -> String- -> [String]- -> IO (Doc AnsiStyle)-executeCLiCommand conf now connection progName args = do- let cliCommandRes = execParserPure defaultPrefs (commandParserInfo conf) args+executeCLiCommand ::+ Config ->+ DateTime ->+ Connection ->+ String ->+ [String] ->+ Maybe P.Int ->+ IO (Doc AnsiStyle)+executeCLiCommand config now connection progName args availableLinesMb = do+ let cliCommandRes =+ execParserPure+ defaultPrefs+ (commandParserInfo config)+ args case cliCommandRes of CompletionInvoked _ ->@@ -1142,42 +1225,50 @@ & P.flip renderFailure progName & P.fst & T.pack- & spliceDocsIntoText helpReplacements+ & spliceDocsIntoText (helpReplacements defaultConfig) & hcat & hPutDoc P.stderr P.exitFailure --- Success cliCommand -> do+ Success cliOptions -> do+ conf <-+ removeColorsIfNecessary+ config{noColor = config.noColor || cliOptions.noColorFlag} let addTaskC = addTask conf connection - case cliCommand of- ListAll -> listAll conf now connection- ListHead -> headTasks conf now connection- ListNewFiltered taskFilter -> newTasks conf now connection taskFilter- ListOld -> listOldTasks conf now connection- ListOpen -> openTasks conf now connection- ListModified -> modifiedTasks conf now connection AllItems- ListModifiedOnly -> modifiedTasks conf now connection ModifiedItemsOnly- ListOverdue -> overdueTasks conf now connection- ListRepeating -> listRepeating conf now connection- ListRecurring -> listRecurring conf now connection- ListReady -> listReady conf now connection- ListWaiting -> listWaiting conf now connection- ListDone -> doneTasks conf now connection- ListObsolete -> obsoleteTasks conf now connection- ListDeletable -> deletableTasks conf now connection- ListNoTag -> listNoTag conf now connection- ListWithTag tags -> listWithTag conf now connection tags+ case cliOptions.cliCommand of+ ListAll -> listAll conf now connection availableLinesMb+ ListHead -> headTasks conf now connection availableLinesMb+ ListNewFiltered taskFilter -> newTasks conf now connection taskFilter availableLinesMb+ ListOld -> listOldTasks conf now connection availableLinesMb+ ListOpen taskFilter -> openTasks conf now connection taskFilter availableLinesMb+ ListModified -> modifiedTasks conf now connection AllItems availableLinesMb+ ListModifiedOnly -> modifiedTasks conf now connection ModifiedItemsOnly availableLinesMb+ ListOverdue -> overdueTasks conf now connection availableLinesMb+ ListRepeating -> listRepeating conf now connection availableLinesMb+ ListRecurring -> listRecurring conf now connection availableLinesMb+ ListReady -> listReady conf now connection availableLinesMb+ ListWaiting -> listWaiting conf now connection availableLinesMb+ ListDone -> doneTasks conf now connection availableLinesMb+ ListObsolete -> obsoleteTasks conf now connection availableLinesMb+ ListDeletable -> deletableTasks conf now connection availableLinesMb+ ListNoTag -> listNoTag conf now connection availableLinesMb+ ListWithTag tags -> listWithTag conf now connection tags availableLinesMb QueryTasks query -> queryTasks conf now connection query RunSql query -> runSql conf query- RunFilter expressions -> runFilter conf now connection expressions+ RunFilter expressions -> runFilter conf now connection expressions availableLinesMb Tags -> listTags conf connection Projects -> listProjects conf connection+ Notes -> listNotes conf connection Stats -> getStats conf connection ImportFile filePath -> importFile conf connection filePath+ ImportDir filePath -> importDir conf connection filePath ImportJson -> importJson conf connection+ ImportYaml -> importYaml conf connection+ ImportMarkdown -> importMarkdown conf connection ImportEml -> importEml conf connection IngestFile filePath -> ingestFile conf connection filePath+ IngestDir filePath -> ingestDir conf connection filePath Csv -> dumpCsv conf Json -> dumpJson conf Ndjson -> dumpNdjson conf@@ -1194,6 +1285,7 @@ AddPay bodyWords -> addTaskC $ ["Pay"] <> bodyWords <> ["+pay"] AddShip bodyWords -> addTaskC $ ["Ship"] <> bodyWords <> ["+ship"] LogTask bodyWords -> logTask conf connection bodyWords+ EnterTask -> enterTask conf connection ReadyOn datetime ids -> setReadyUtc conf connection datetime ids WaitTasks ids -> waitTasks conf connection ids WaitFor duration ids -> waitFor conf connection duration ids@@ -1203,7 +1295,8 @@ ReviewTasksIn days ids -> reviewTasksIn conf connection days ids DoTasks ids -> doTasks conf connection Nothing ids DoOneTask id noteWords -> doTasks conf connection noteWords [id]- EndTasks ids -> endTasks conf connection ids+ EndTasks ids -> endTasks conf connection Nothing ids+ EndOneTask id noteWords -> endTasks conf connection noteWords [id] EditTask id -> editTask conf connection id TrashTasks ids -> trashTasks conf connection ids DeleteTasks ids -> deleteTasks conf connection ids@@ -1216,8 +1309,8 @@ Prioritize val ids -> adjustPriority conf val ids InfoTask idSubstr -> infoTask conf connection idSubstr NextTask -> nextTask conf connection- RandomTask -> randomTask conf connection- FindTask aPattern -> findTask connection aPattern+ RandomTask taskFilter -> randomTask conf connection taskFilter+ FindTask aPattern -> findTask conf connection aPattern AddTag tagText ids -> addTag conf connection tagText ids DeleteTag tagText ids -> deleteTag conf connection tagText ids AddNote noteText ids -> addNote conf connection noteText ids@@ -1243,26 +1336,27 @@ PrintConfig -> pure $ pretty conf StartServer -> startServer AirGQL.defaultConfig conf Alias alias _ -> pure $ aliasWarning alias- UlidToUtc ulid -> pure $ pretty $ ulid2utc ulid+ UlidToUtc ulid -> pure $ pretty $ ulidText2utc ulid ExternalCommand cmd argsMb -> handleExternalCommand conf cmd argsMb -printOutput :: String -> Config -> IO ()-printOutput appName config = do- let dataPath = config.dataDir+printOutput :: String -> Maybe [String] -> Config -> IO ()+printOutput appName argsMb config = do+ noColorEnv <- lookupEnv "NO_COLOR"+ let conf = config{noColor = config.noColor || P.isJust noColorEnv} configNormDataDir <-- if null dataPath+ if null conf.dataDir then do xdgDataDir <- getXdgDirectory XdgData appName- pure $ config{dataDir = xdgDataDir}- else case T.stripPrefix "~/" $ T.pack dataPath of- Nothing -> pure config+ pure $ conf{dataDir = xdgDataDir}+ else case T.stripPrefix "~/" $ T.pack conf.dataDir of+ Nothing -> pure conf Just rest -> do homeDir <- getHomeDirectory- pure $ config{dataDir = homeDir </> T.unpack rest}+ pure $ conf{dataDir = homeDir </> T.unpack rest} - let hooksPath = configNormDataDir & hooks & directory+ let hooksPath = configNormDataDir.hooks.directory configNormHookDir <- if null hooksPath@@ -1270,8 +1364,8 @@ pure $ configNormDataDir { hooks =- (configNormDataDir & hooks)- { directory = dataDir configNormDataDir </> "hooks"+ configNormDataDir.hooks+ { directory = configNormDataDir.dataDir </> "hooks" } } else case T.stripPrefix "~/" $ T.pack hooksPath of@@ -1281,12 +1375,12 @@ pure $ configNormDataDir { hooks =- (configNormDataDir & hooks)+ configNormDataDir.hooks { directory = homeDir </> T.unpack rest } } - let hooksPathNorm = configNormHookDir & hooks & directory+ let hooksPathNorm = configNormHookDir.hooks.directory createDirectoryIfMissing True hooksPathNorm @@ -1307,17 +1401,31 @@ hookFilesPermContent <- hookFilesPerm- & filter (\(_, perm) -> executable perm)+ & filter (\(filePath, perm) -> hasExtension filePath || executable perm) & P.mapM ( \(filePath, perm) -> do fileContent <- readFile filePath pure (filePath, perm, fileContent) )-- let configNorm = addHookFilesToConfig configNormHookDir hookFilesPermContent+ let (configNorm, errors) =+ addHookFilesToConfig configNormHookDir hookFilesPermContent+ P.when (not $ null errors) $+ ["WARNING:\n"]+ <> errors+ & P.traverse_+ ( pretty+ >>> annotate (colr conf Yellow)+ >>> hPutDoc P.stderr+ ) - preLaunchResult <- executeHooks "" (configNorm.hooks & launch & pre)- putDoc preLaunchResult+ -- Run pre-launch hooks+ preLaunchResults <- executeHooks "" configNorm.hooks.launch.pre+ let preLaunchHookMsg =+ preLaunchResults+ <&> \case+ Left error -> pretty error+ Right hookResult -> formatHookResult conf hookResult+ & P.fold connection <- setupConnection configNorm @@ -1325,30 +1433,83 @@ -- SQLite.setTrace connection $ Just P.putStrLn migrationsStatus <- runMigrations configNorm connection- nowElapsed <- timeCurrentP - let- now = timeFromElapsedP nowElapsed :: DateTime-+ -- Run post-launch hooks progName <- getProgName- args <- getArgs- postLaunchResult <-+ args <- case argsMb of+ Just args -> pure args+ Nothing -> getArgs+ postLaunchResults <- executeHooks ( TL.toStrict $ TL.decodeUtf8 $ Aeson.encode $ object ["arguments" .= args] )- (configNorm.hooks & launch & post)- putDoc postLaunchResult+ configNorm.hooks.launch.post - doc <- executeCLiCommand configNorm now connection progName args+ let postLaunchHookMsg =+ postLaunchResults+ <&> \case+ Left error -> pretty error+ Right hookResult -> formatHookResult conf hookResult+ & P.fold + termSizeMb <- size+ let+ linesNumMb =+ -- Ignore available terminal lines if output isn't printed to a terminal+ termSizeMb <&> \(Window{height}) ->+ -- TODO: Use the correct number of terminal prompt lines+ -- and overflowing lines here.+ -- We're currently simply assuming+ -- that 20% of the lines will overflow.+ P.max 1 $ P.round $ (P.fromIntegral height - 5) * (0.8 :: P.Double)++ termWidthMb =+ termSizeMb <&> \(Window{width}) -> width++ outputWidth =+ case (termWidthMb, configNorm.maxWidth) of+ (Just termWidth, Just maxWidth) -> P.min termWidth maxWidth+ (Just termWidth, Nothing) -> termWidth+ (Nothing, Just maxWidth) -> maxWidth+ (Nothing, Nothing) -> P.maxBound @P.Int++ nowElapsed <- timeCurrentP+ let now = timeFromElapsedP nowElapsed :: DateTime++ doc <- executeCLiCommand configNorm now connection progName args linesNumMb+ -- TODO: Use withConnection instead SQLite.close connection + -- Run pre-exit hooks+ preExitResults <- executeHooks "" configNorm.hooks.exit.pre+ let+ preExitHookMsg =+ preExitResults+ <&> \case+ Left error -> pretty error+ Right hookResult -> formatHookResult conf hookResult+ & P.fold+ putDocCustom document =+ renderIO+ stdout+ $ layoutPretty+ ( defaultLayoutOptions+ { layoutPageWidth = AvailablePerLine outputWidth 1.0+ }+ )+ document+ -- TODO: Remove color when piping into other command- putDoc $ migrationsStatus <> doc <> hardline+ putDocCustom $+ preLaunchHookMsg+ <!!> migrationsStatus+ <!!> postLaunchHookMsg+ <!!> doc+ <!!> preExitHookMsg exampleConfig :: Text
source/Config.hs view
@@ -3,12 +3,12 @@ -} module Config where -import Protolude as P (+import Protolude ( Applicative (pure),+ Bool (False), Char, Eq ((==)), FilePath,- Foldable (foldl), Functor (fmap), Generic, Int,@@ -24,7 +24,10 @@ ($), (&), (.),+ (<=),+ (>>=), )+import Protolude qualified as P import Data.Aeson ( FromJSON (parseJSON),@@ -36,23 +39,11 @@ (.:?), ) import Data.Hourglass (TimeFormat (toFormat), TimeFormatString)-import Data.Text as T (- dropEnd,- isInfixOf,- pack,- replace,- split,- strip,- stripPrefix,- )+import Data.Text (dropEnd, pack, split, stripPrefix)+import Data.Text qualified as T import Data.Yaml (encode) import Prettyprinter.Internal (Pretty (pretty))-import Prettyprinter.Render.Terminal (- AnsiStyle,- Color (..),- color,- colorDull,- )+import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, colorDull) import Prettyprinter.Render.Terminal.Internal (ansiForeground) import System.FilePath (takeBaseName) @@ -142,8 +133,8 @@ } -addHookFilesToConfig :: Config -> [(FilePath, b, Text)] -> Config-addHookFilesToConfig =+addHookFilesToConfig :: Config -> [(FilePath, b, Text)] -> (Config, [Text])+addHookFilesToConfig config = do let buildHook :: FilePath -> Text -> Hook buildHook filePath content =@@ -189,21 +180,75 @@ { exit = addToHookSet hook stage (hConfig & exit) } _ -> hConfig- in- P.foldl $ \conf (filePath, _, fileContent) ->- case split (== '-') $ pack $ takeBaseName filePath of- [stage, event] ->- conf- { hooks =- addToHooksConfig- event- stage- (buildHook filePath fileContent)- conf.hooks- }- _ -> conf + getStageAndEvent :: FilePath -> [Text]+ getStageAndEvent filePath = do+ let fileName =+ filePath+ & takeBaseName+ & pack + -- Prefix with "_" to ignore files+ if "_" `T.isPrefixOf` fileName+ then []+ else+ fileName+ & split (== '_')+ & P.headMay+ & fromMaybe ""+ & split (== '-')++ P.foldl'+ ( \(conf, errors) (filePath, _, fileContent) ->+ case getStageAndEvent filePath of+ [stage, event] ->+ ( conf+ { hooks =+ addToHooksConfig+ event+ stage+ (buildHook filePath fileContent)+ conf.hooks+ }+ , errors <> []+ )+ [] -> (conf, errors)+ filenameParts ->+ ( conf+ , errors+ <> [ ("`" <> (filenameParts & T.intercalate "-") <> "` ")+ <> "is not a correct hook name.\n"+ <> "Hook file names must be in the format: "+ <> "<stage>-<event>_<description>.<ext>\n"+ <> "E.g `post-launch.v`, or `pre-exit.lua`.\n"+ ]+ )+ )+ (config, [])+++data Column = IdCol | PrioCol | OpenedUTCCol | AgeCol | BodyCol | EmptyCol+ deriving (Eq, Show, Generic)+++instance ToJSON Column where+ toJSON IdCol = String "id"+ toJSON PrioCol = String "prio"+ toJSON OpenedUTCCol = String "openedUtc"+ toJSON AgeCol = String "age"+ toJSON BodyCol = String "body"+ toJSON EmptyCol = String ""+instance FromJSON Column where+ parseJSON = withText "Column" $ \value -> do+ case value of+ "id" -> pure IdCol+ "prio" -> pure PrioCol+ "openedUtc" -> pure OpenedUTCCol+ "age" -> pure AgeCol+ "body" -> pure BodyCol+ _ -> pure EmptyCol++ data Config = Config { tableName :: Text , idStyle :: AnsiStyle@@ -217,15 +262,17 @@ , tagStyle :: AnsiStyle , utcFormat :: TimeFormatString , utcFormatShort :: TimeFormatString+ , columns :: [Column] , dataDir :: FilePath , dbName :: FilePath , dateWidth :: Int , bodyWidth :: Int , prioWidth :: Int , headCount :: Int- , maxWidth :: Int+ , maxWidth :: Maybe Int -- Automatically uses terminal width if not set , progressBarWidth :: Int , hooks :: HooksConfig+ , noColor :: Bool } deriving (Generic, Show) @@ -247,16 +294,21 @@ utcFormat <- o .:? "utcFormat" .!= defaultConfig.utcFormat utcFormatShort <- o .:? "utcFormatShort" .!= defaultConfig.utcFormatShort dataDir <- o .:? "dataDir" .!= defaultConfig.dataDir+ columns <- o .:? "columns" .!= defaultConfig.columns dbName <- o .:? "dbName" .!= defaultConfig.dbName dateWidth <- o .:? "dateWidth" .!= defaultConfig.dateWidth bodyWidth <- o .:? "bodyWidth" .!= defaultConfig.bodyWidth prioWidth <- o .:? "prioWidth" .!= defaultConfig.prioWidth headCount <- o .:? "headCount" .!= defaultConfig.headCount- maxWidth <- o .:? "maxWidth" .!= defaultConfig.maxWidth+ maxWidthMb <- o .:? "maxWidth" progressBarWidth <- o .:? "progressBarWidth" .!= defaultConfig.progressBarWidth hooks <- o .:? "hooks" .!= defaultConfig.hooks+ noColor <- o .:? "noColor" .!= defaultConfig.noColor + let maxWidth = maxWidthMb >>=+ \w -> if w <= 0 then defaultConfig.maxWidth else Just w+ pure $ Config{..} {- FOURMOLU_ENABLE -}@@ -339,13 +391,14 @@ , tagStyle = color Blue , utcFormat = toFormat ("YYYY-MM-DD H:MI:S" :: [Char]) , utcFormatShort = toFormat ("YYYY-MM-DD H:MI" :: [Char])+ , columns = [IdCol, PrioCol, OpenedUTCCol, BodyCol] , dataDir = "" , dbName = "main.db" , dateWidth = 10 , bodyWidth = 10 , prioWidth = 4 , headCount = 20- , maxWidth = 120+ , maxWidth = Nothing , progressBarWidth = 24 , hooks = HooksConfig@@ -355,4 +408,5 @@ , modify = emptyHookSet , exit = emptyHookSet }+ , noColor = False }
source/FullTask.hs view
@@ -63,7 +63,7 @@ waiting_utc ), TaskState,- zeroTask,+ emptyTask, ) @@ -235,7 +235,7 @@ cpTimesAndState :: FullTask -> Task cpTimesAndState (FullTask{..}) =- zeroTask+ emptyTask { Task.ulid , Task.modified_utc , Task.awake_utc
+ source/Hooks.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use maybe" #-}++module Hooks where++import Protolude (+ Applicative (pure),+ IO,+ Maybe (..),+ Show,+ otherwise,+ ($),+ (&),+ (<&>),+ )+import Protolude qualified as P++import Control.Arrow ((>>>))+import Data.Aeson qualified as Aeson+import Data.Text (Text)+import Data.Text qualified as T+import Options.Applicative.Arrows (left)+import Prettyprinter (Doc, annotate, pretty)+import Prettyprinter.Render.Terminal (AnsiStyle, Color (Red, Yellow))+import System.FilePath (takeExtension)+import System.Process (readProcess)++import Config (Config, Hook (body, filePath, interpreter))+import ImportTask (ImportTask)+import Utils (colr, (<!!>))+++data HookTiming = PreEvent | PostEvent+ deriving (Show)+++data HookType+ = LaunchHook+ | AddHook+ | ModifyHook+ | ExitHook+ deriving (Show)+++data HookEvent = HookEvent HookType HookTiming+ deriving (Show)+++-- | Output of a hook that must be parsed by TaskLite+data HookResult+ = BasicHookResult+ { message :: Maybe Text+ , warning :: Maybe Text+ , error :: Maybe Text+ }+ | TaskHookResult+ { task :: Maybe ImportTask+ , message :: Maybe Text+ , warning :: Maybe Text+ , error :: Maybe Text+ }+ deriving (Show, P.Generic)+++instance Aeson.FromJSON HookResult where+ parseJSON = Aeson.withObject "HookResult" $ \v -> do+ taskMb <- v Aeson..:? "task"+ messageMb <- v Aeson..:? "message"+ warningMb <- v Aeson..:? "warning"+ errorMb <- v Aeson..:? "error"++ case taskMb of+ Just task -> pure $ TaskHookResult task messageMb warningMb errorMb+ Nothing -> pure $ BasicHookResult messageMb warningMb errorMb+++data ExecMode = ExecFile | ExecStdin+++type String = [P.Char]+++executeHooks :: Text -> [Hook] -> IO [P.Either Text HookResult]+executeHooks stdinText hooks = do+ let+ stdinStr = T.unpack stdinText++ getInterpreter :: String -> (String, [String], ExecMode)+ getInterpreter s =+ if+ | s `P.elem` ["javascript", "js", "node", "node.js"] ->+ ("node", ["-e"], ExecStdin)+ | s `P.elem` ["lua"] ->+ ("lua", ["-e"], ExecStdin)+ | s `P.elem` ["python", "python3", "py"] ->+ ("python3", ["-c"], ExecStdin)+ | s `P.elem` ["ruby", "rb"] ->+ ("ruby", ["-e"], ExecStdin)+ | s `P.elem` ["v", "vsh"] ->+ -- `crun` keeps the binary after execution+ ("v", ["-raw-vsh-tmp-prefix", "_v_executable_"], ExecFile)+ | otherwise ->+ ("", [""], ExecFile)++ hookToResult <-+ P.sequence $+ hooks <&> \hook -> do+ case hook.filePath of+ Just fPath -> do+ case fPath & takeExtension & P.drop 1 of+ "" ->+ -- Is executed with shell+ readProcess fPath [] stdinStr+ ext -> do+ let (interpreter, cliFlags, execMode) = getInterpreter ext+ case execMode of+ ExecStdin -> do+ fileContent <- P.readFile fPath+ readProcess+ interpreter+ (P.concat [cliFlags, [T.unpack fileContent]])+ stdinStr+ ExecFile -> do+ readProcess+ interpreter+ (P.concat [cliFlags, [fPath]])+ stdinStr+ ---+ Nothing -> do+ let+ (interpreter, cliFlags, _) =+ getInterpreter (T.unpack hook.interpreter)+ readProcess+ interpreter+ (P.concat [cliFlags, [T.unpack hook.body]])+ stdinStr++ let parsedHookResults :: [P.Either Text HookResult] =+ hookToResult+ & P.filter (T.pack >>> T.strip >>> T.null >>> P.not)+ <&> ( ( \hookOutput -> do+ Aeson.eitherDecodeStrictText (T.pack hookOutput)+ )+ >>> left T.pack+ )++ pure parsedHookResults+++formatHookResult :: Config -> HookResult -> Doc AnsiStyle+formatHookResult conf hookResult =+ ""+ <!!> pretty hookResult.message+ <!!> annotate (colr conf Yellow) (pretty hookResult.warning)+ <!!> annotate (colr conf Red) (pretty hookResult.error)+ <!!> ""
source/ImportExport.hs view
@@ -1,792 +1,840 @@-{-|-Functions to import and export tasks--}-module ImportExport where--import Protolude (- Alternative ((<|>)),- Applicative (pure),- Bool (..),- Char,- Either (..),- Eq ((==)),- FilePath,- Foldable (foldl),- Functor (fmap),- Generic,- Hashable (hash),- IO,- Integral (toInteger),- Maybe (..),- Num (abs),- Semigroup ((<>)),- Show,- Text,- Traversable (sequence),- asum,- die,- fromMaybe,- hush,- isJust,- optional,- rightToMaybe,- show,- toStrict,- ($),- (&),- (.),- (<$>),- (<&>),- (=<<),- )-import Protolude qualified as P--import Config (Config (dataDir, dbName))-import Control.Arrow ((>>>))-import Data.Aeson as Aeson (- FromJSON (parseJSON),- ToJSON,- Value (Array, Object, String),- eitherDecode,- encode,- withObject,- (.:),- (.:?),- )-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 (- DateTime,- Time (timeFromElapsedP),- TimeFormat (toFormat),- TimeFormatString,- timePrint,- )-import Data.Text qualified as T-import Data.Text.Lazy.Encoding qualified as TL-import Data.Time.ISO8601.Duration qualified as Iso-import Data.ULID (ulidFromInteger)-import Data.Vector qualified as V-import Data.Yaml as Yaml (ParseException, decodeEither')-import Database.SQLite.Simple as Sql (Connection, query_)-import FullTask (FullTask)-import Lib (- execWithConn,- execWithTask,- insertNotes,- insertRecord,- insertTags,- updateTask,- )-import Note (Note (..))-import Prettyprinter (- Doc,- Pretty (pretty),- dquotes,- hardline,- vsep,- (<+>),- )-import Prettyprinter.Render.Terminal (AnsiStyle)-import System.Directory (createDirectoryIfMissing, removeFile)-import System.FilePath (takeExtension, (</>))-import System.Posix.User (getEffectiveUserName)-import System.Process (readProcess)-import Task (- Task (- Task,- awake_utc,- body,- closed_utc,- due_utc,- group_ulid,- metadata,- modified_utc,- priority_adjustment,- ready_utc,- recurrence_duration,- repetition_duration,- review_utc,- state,- ulid,- user,- waiting_utc- ),- setMetadataField,- taskToEditableYaml,- textToTaskState,- zeroTask,- )-import Text.Editor (runUserEditorDWIM, yamlTemplate)-import Text.Parsec.Rfc2822 (GenericMessage (..), message)-import Text.Parsec.Rfc2822 qualified as Email-import Text.ParserCombinators.Parsec as Parsec (parse)-import Text.PortableLines.ByteString.Lazy (lines8)-import Time.System (timeCurrent)-import Utils (- IdText,- emptyUlid,- parseUlidText,- parseUtc,- setDateTime,- ulidTextToDateTime,- zeroTime,- zonedTimeToDateTime,- (<$$>),- )---data Annotation = Annotation- { entry :: Text- , description :: Text- }- deriving (Generic, Eq)---instance Hashable Annotation---instance ToJSON Annotation---instance FromJSON Annotation where- parseJSON = withObject "annotation" $ \o -> do- entry <- o .: "entry"- description <- o .: "description"- pure Annotation{..}---annotationToNote :: Annotation -> Note-annotationToNote annot@Annotation{entry, description} = do- let- utc = entry & parseUtc & fromMaybe (timeFromElapsedP 0 :: DateTime)- ulidGeneratedRes = annot & (hash >>> toInteger >>> abs >>> ulidFromInteger)- ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` utc-- Note- { ulid = (T.toLower . show) ulidCombined- , body = description- }---textToNote :: DateTime -> Text -> Note-textToNote utc body =- let- ulidGeneratedRes = body & (hash >>> toInteger >>> abs >>> ulidFromInteger)- ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` utc- in- Note- { ulid = (T.toLower . show) ulidCombined- , body = body- }---importUtcFormat :: TimeFormatString-importUtcFormat =- toFormat ("YYYY-MM-DD H:MI:S" :: [Char])---data ImportTask = ImportTask- { task :: Task- , notes :: [Note]- , tags :: [Text]- }- deriving (Show)---emptyImportTask :: ImportTask-emptyImportTask =- ImportTask- { task = zeroTask- , notes = []- , tags = []- }----- | Values a suffixed with a prime (') to avoid name collisions-instance FromJSON ImportTask where- parseJSON = withObject "task" $ \o -> do- utc <- o .:? "utc"- entry <- o .:? "entry"- creation <- o .:? "creation"- creation_utc <- o .:? "creation_utc"- creationUtc <- o .:? "creationUtc"- created <- o .:? "created"- created_at <- o .:? "created_at"- createdAt <- o .:? "createdAt"- created_utc <- o .:? "created_utc"- createdUtc_ <- o .:? "createdUtc"-- let- parsedCreatedUtc =- parseUtc- =<< ( utc- <|> entry- <|> creation- <|> creation_utc- <|> creationUtc- <|> created- <|> created_at- <|> createdAt- <|> created_utc- <|> createdUtc_- )- createdUtc = fromMaybe zeroTime parsedCreatedUtc-- o_body <- o .:? "body"- description <- o .:? "description"- let body = fromMaybe "" (o_body <|> description)-- o_priority_adjustment <- o .:? "priority_adjustment"- urgency <- o .:? "urgency"- priority <- optional (o .: "priority")- let priority_adjustment = o_priority_adjustment <|> urgency <|> priority-- modified <- o .:? "modified"- modified_at <- o .:? "modified_at"- o_modified_utc <- o .:? "modified_utc"- modification_date <- o .:? "modification_date"- updated_at <- o .:? "updated_at"- let- maybeModified =- modified- <|> modified_at- <|> o_modified_utc- <|> modification_date- <|> updated_at- modified_utc =- T.pack $- timePrint importUtcFormat $- fromMaybe createdUtc (parseUtc =<< maybeModified)-- o_state <- o .:? "state"- status <- o .:? "status"- let- state = textToTaskState =<< (o_state <|> status)- implicitCloseUtcMaybe =- if isJust state- then- maybeModified- <|> Just (T.pack $ timePrint importUtcFormat createdUtc)- else Nothing-- o_tags <- o .:? "tags"- o_labels <- o .:? "labels"- project <- o .:? "project"- let- projects = fmap (: []) project- tags = fromMaybe [] (o_tags <> o_labels <> projects)-- due <- o .:? "due"- o_due_utc <- o .:? "due_utc"- due_on <- o .:? "due_on"- let- maybeDue = due <|> o_due_utc <|> due_on- due_utc =- fmap- (T.pack . timePrint importUtcFormat)- (parseUtc =<< maybeDue)-- awake' <- o .:? "awake"- awake_at' <- o .:? "awake_at"- sleep' <- o .:? "sleep"- sleep_utc' <- o .:? "sleep_utc"- sleep_until' <- o .:? "sleep_until"- wait' <- o .:? "wait"- wait_until' <- o .:? "wait_until"- let- maybeAwake =- awake'- <|> awake_at'- <|> sleep'- <|> sleep_utc'- <|> sleep_until'- <|> wait'- <|> wait_until'- awake_utc =- fmap- (T.pack . timePrint importUtcFormat)- (parseUtc =<< maybeAwake)-- ready' <- o .:? "ready"- ready_since' <- o .:? "ready_since"- ready_utc' <- o .:? "ready_utc"- let- maybeReady = ready' <|> ready_since' <|> ready_utc'- ready_utc =- fmap- (T.pack . timePrint importUtcFormat)- (parseUtc =<< maybeReady)-- review' <- o .:? "review"- review_at' <- o .:? "review_at"- review_since' <- o .:? "review_since"- review_utc' <- o .:? "review_utc"- let- maybeReview = review' <|> review_at' <|> review_since' <|> review_utc'- review_utc =- fmap- (T.pack . timePrint importUtcFormat)- (parseUtc =<< maybeReview)-- waiting' <- o .:? "waiting"- waiting_since' <- o .:? "waiting_since"- waiting_utc' <- o .:? "waiting_utc"- let- maybewaiting = waiting' <|> waiting_since' <|> waiting_utc'- waiting_utc =- fmap- (T.pack . timePrint importUtcFormat)- (parseUtc =<< maybewaiting)-- closed <- o .:? "closed"- o_closed_utc <- o .:? "closed_utc"- closed_at <- o .:? "closed_at"- closed_on <- o .:? "closed_on"- end <- o .:? "end"- o_end_utc <- o .:? "end_utc"- end_on <- o .:? "end_on"- let- maybeClosed =- closed- <|> o_closed_utc- <|> closed_at- <|> closed_on- <|> end- <|> o_end_utc- <|> end_on- <|> implicitCloseUtcMaybe- closed_utc =- fmap- (T.pack . timePrint importUtcFormat)- (parseUtc =<< maybeClosed)-- group_ulid <- o .:? "group_ulid"-- let parseIsoDurationMb durTextMb =- hush $- fmap (P.decodeUtf8 . Iso.formatDuration) $- Iso.parseDuration $- P.encodeUtf8 $- fromMaybe "" durTextMb-- repetition_duration' <- o .:? "repetition_duration"- repeat_duration' <- o .:? "repeat_duration"- let- maybeRepetition = repetition_duration' <|> repeat_duration'- repetition_duration = parseIsoDurationMb maybeRepetition-- recurrence_duration' <- o .:? "recurrence_duration"- recur_duration' <- o .:? "recur_duration"- let- maybeRecurrence = recurrence_duration' <|> recur_duration'- recurrence_duration = parseIsoDurationMb maybeRecurrence-- o_notes <-- asum- [ o .:? "notes" :: Parser (Maybe [Note])- , do- notesMb <- o .:? "notes" :: Parser (Maybe [Text])- pure $ case notesMb of- Just textNotes -> Just $ textNotes <&> textToNote createdUtc- Nothing -> Just []- ]- annotations <- o .:? "annotations" :: Parser (Maybe [Annotation])-- let- notes = case (o_notes, annotations) of- (Nothing, Nothing) -> []- (Nothing, Just values) -> values <&> annotationToNote- (Just theNotes, _) -> case parsedCreatedUtc of- Just crUtc ->- theNotes- <&> ( \theNote ->- let- noteUlidTxt = Note.ulid theNote- mbNoteUlid = parseUlidText noteUlidTxt- mbNewUlid = do- noteUlid <- mbNoteUlid-- pure $ show $ setDateTime noteUlid crUtc- in- theNote- { Note.ulid =- T.toLower $ fromMaybe noteUlidTxt mbNewUlid- }- )- Nothing -> theNotes-- o_user <- o .:? "user"- o_author <- o .:? "author"- let- userMaybe = o_user <|> o_author- user = fromMaybe "" userMaybe-- o_metadata <- o .:? "metadata"- let- metadata = o_metadata <|> Just (Object o)- tempTask = Task{ulid = "", ..}-- o_ulid <- o .:? "ulid"- let- ulidGeneratedRes = tempTask & (hash >>> toInteger >>> abs >>> ulidFromInteger)- ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` createdUtc- ulid =- T.toLower $- fromMaybe- ""- (o_ulid <|> Just (show ulidCombined))-- -- let showInt = show :: Int -> Text- -- uuid <- o .:? "uuid"- -- -- Map `show` over `Parser` & `Maybe` to convert possible `Int` to `Text`- -- id <- (o .:? "id" <|> ((showInt <$>) <$> (o .:? "id")))- -- let id = (uuid <|> id)-- let finalTask = tempTask{Task.ulid = ulid}-- pure $ ImportTask finalTask notes tags---insertImportTask :: Connection -> ImportTask -> IO (Doc AnsiStyle)-insertImportTask connection importTaskRecord = do- effectiveUserName <- getEffectiveUserName- let- taskParsed = task importTaskRecord- theTask =- if Task.user taskParsed == ""- then taskParsed{Task.user = T.pack effectiveUserName}- else taskParsed- insertRecord "tasks" connection theTask- warnings <-- insertTags- connection- (ulidTextToDateTime $ Task.ulid taskParsed)- theTask- importTaskRecord.tags- insertNotes- connection- (ulidTextToDateTime $ Task.ulid taskParsed)- theTask- importTaskRecord.notes- pure $- warnings- <$$> "📥 Imported task"- <+> dquotes (pretty $ Task.body theTask)- <+> "with ulid"- <+> dquotes (pretty $ Task.ulid theTask)- <+> hardline---importJson :: Config -> Connection -> IO (Doc AnsiStyle)-importJson _ connection = do- content <- BSL.getContents-- case Aeson.eitherDecode content of- Left error -> die $ T.pack error <> " in task \n" <> show content- Right importTaskRecord -> insertImportTask connection importTaskRecord---importEml :: Config -> Connection -> IO (Doc AnsiStyle)-importEml _ connection = do- content <- BSL.getContents-- case Parsec.parse message "<stdin>" content of- Left error -> die $ show error- Right email -> insertImportTask connection $ emailToImportTask email---emailToImportTask :: GenericMessage BSL.ByteString -> ImportTask-emailToImportTask email@(Message headerFields msgBody) =- let- addBody (ImportTask task notes tags) =- ImportTask- task- { Task.body =- Task.body task- <> ( 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 task <> 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---importFile :: Config -> Connection -> FilePath -> IO (Doc AnsiStyle)-importFile _ connection filePath = do- content <- BSL.readFile filePath-- let- fileExt = takeExtension filePath-- case fileExt of- ".json" ->- let decodeResult = Aeson.eitherDecode content :: Either [Char] ImportTask- in case decodeResult of- Left error ->- die $ T.pack error <> " in task \n" <> show content- Right importTaskRecord ->- insertImportTask connection importTaskRecord- ".eml" ->- case Parsec.parse message filePath content of- Left error -> die $ show error- Right email -> insertImportTask connection $ emailToImportTask email- _ -> die $ T.pack $ "File type " <> fileExt <> " is not supported"---ingestFile :: Config -> Connection -> FilePath -> IO (Doc AnsiStyle)-ingestFile _config connection filePath = do- content <- BSL.readFile filePath-- let- fileExt = takeExtension filePath-- resultDocs <- case fileExt of- ".json" ->- let decodeResult = Aeson.eitherDecode content :: Either [Char] ImportTask- in case decodeResult of- Left error ->- die $ T.pack error <> " in task \n" <> show content- Right importTaskRecord@ImportTask{task} ->- sequence- [ insertImportTask connection importTaskRecord- , editTaskByTask NoPreEdit connection task- ]- ".eml" ->- case Parsec.parse message filePath content of- Left error -> die $ show error- Right email ->- let taskRecord@ImportTask{task} =- emailToImportTask email- in sequence- [ insertImportTask connection taskRecord- , editTaskByTask NoPreEdit connection task- ]- _ -> die $ T.pack $ "File type " <> fileExt <> " is not supported"-- removeFile filePath-- pure $- P.fold resultDocs- <+> "❌ Deleted file \""- <> pretty filePath- <> "\""----- 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---dumpNdjson :: Config -> IO (Doc AnsiStyle)-dumpNdjson 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 $- vsep $- fmap (pretty . TL.decodeUtf8 . Aeson.encode) tasks---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"- [ dataDir conf </> dbName conf- , ".dump"- ]- []- pure $ pretty result---backupDatabase :: Config -> IO (Doc AnsiStyle)-backupDatabase conf = do- now <- timeCurrent-- let- fileUtcFormat = toFormat ("YYYY-MM-DDtHMI" :: [Char])- backupDirName = "backups"- backupDirPath = dataDir conf </> backupDirName- backupFilePath = backupDirPath </> timePrint fileUtcFormat now <> ".db"-- -- Create directory (and parents because of True)- createDirectoryIfMissing True backupDirPath-- result <-- pretty- <$> readProcess- "sqlite3"- [ dataDir conf </> dbName conf- , ".backup '" <> backupFilePath <> "'"- ]- []-- pure $- result- <> hardline- <> pretty- ( "✅ Backed up database \""- <> dbName conf- <> "\" to \""- <> backupFilePath- <> "\""- )---data PreEdit- = ApplyPreEdit (P.ByteString -> P.ByteString)- | NoPreEdit---editTaskByTask :: PreEdit -> Connection -> Task -> IO (Doc AnsiStyle)-editTaskByTask preEdit conn taskToEdit = do- taskYaml <- taskToEditableYaml conn taskToEdit- newContent <- case preEdit of- ApplyPreEdit editFunc -> pure $ editFunc taskYaml- NoPreEdit -> runUserEditorDWIM yamlTemplate taskYaml-- if newContent == taskYaml- then- pure $- "⚠️ Nothing changed" <+> hardline- else do- 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 :: Maybe Value)-- decodeResult :: Either ParseException ImportTask- decodeResult = Yaml.decodeEither' newContent-- case decodeResult of- Left error -> die $ show error <> " in task \n" <> show newContent- Right importTaskRecord -> do- effectiveUserName <- getEffectiveUserName- let- taskParsed = task importTaskRecord- taskFixed =- taskParsed- { Task.user =- if Task.user taskParsed == ""- then T.pack effectiveUserName- else Task.user taskParsed- , Task.metadata =- if hasMetadata == Just True- then Task.metadata taskParsed- else Nothing- }-- updateTask conn taskFixed- warnings <-- insertTags- conn- Nothing- taskFixed- (tags importTaskRecord)- insertNotes- conn- Nothing- taskFixed- (notes importTaskRecord)- pure $- warnings- <$$> "✏️ Edited task"- <+> dquotes (pretty $ Task.body taskFixed)- <+> "with ulid"- <+> dquotes (pretty $ Task.ulid taskFixed)- <+> hardline---editTask :: Config -> Connection -> IdText -> IO (Doc AnsiStyle)-editTask conf conn idSubstr = do- execWithTask conf conn idSubstr $ \taskToEdit -> do- editTaskByTask NoPreEdit conn taskToEdit+{-# 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 "<stdin>" 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
+ source/ImportTask.hs view
@@ -0,0 +1,502 @@+{-|+Datatype `ImportTask` plus instances and functions+-}+module ImportTask where++import Protolude (+ Alternative ((<|>)),+ Applicative (pure),+ Char,+ Eq ((==)),+ Functor (fmap),+ Generic,+ Hashable (hash),+ Integral (toInteger),+ Maybe (..),+ Num (abs),+ Semigroup ((<>)),+ Show,+ Text,+ asum,+ fromMaybe,+ hush,+ isJust,+ optional,+ show,+ ($),+ (&),+ (.),+ (/=),+ (<&>),+ (=<<),+ (>>=),+ (||),+ )+import Protolude qualified as P++import Control.Arrow ((>>>))+import Data.Aeson (Value)+import Data.Aeson as Aeson (+ FromJSON (parseJSON),+ ToJSON,+ Value (Object, String),+ withObject,+ (.!=),+ (.:),+ (.:?),+ )+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser, parseMaybe)+import Data.Hourglass (+ DateTime,+ Time (timeFromElapsedP),+ TimeFormatString,+ timePrint,+ toFormat,+ )+import Data.Text qualified as T+import Data.Time.ISO8601.Duration qualified as Iso+import Data.ULID (ULID, ulidFromInteger)+import FullTask qualified+import Note (Note (..))+import System.Hourglass (dateCurrent)+import Task (+ Task (+ Task,+ awake_utc,+ body,+ closed_utc,+ due_utc,+ group_ulid,+ metadata,+ modified_utc,+ priority_adjustment,+ ready_utc,+ recurrence_duration,+ repetition_duration,+ review_utc,+ state,+ ulid,+ user,+ waiting_utc+ ),+ emptyTask,+ textToTaskState,+ )+import Utils (+ emptyUlid,+ parseUlidText,+ parseUtc,+ parseUtcNum,+ setDateTime,+ toUlidTime,+ zeroTime,+ zeroUlidTxt,+ )+++data Annotation = Annotation+ { entry :: Text+ , description :: Text+ }+ deriving (Generic, Eq)+++instance Hashable Annotation+++instance ToJSON Annotation+++instance FromJSON Annotation where+ parseJSON = withObject "annotation" $ \o -> do+ entry <- o .: "entry"+ description <- o .: "description"+ pure Annotation{..}+++annotationToNote :: Annotation -> Note+annotationToNote annot@Annotation{entry, description} = do+ let+ utc = entry & parseUtc & fromMaybe (timeFromElapsedP 0 :: DateTime)+ ulidGeneratedRes = annot & (hash >>> toInteger >>> abs >>> ulidFromInteger)+ ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` utc++ Note+ { ulid = (T.toLower . show) ulidCombined+ , body = description+ }+++textToNote :: DateTime -> Text -> Note+textToNote utc body =+ let+ ulidGeneratedRes = body & (hash >>> toInteger >>> abs >>> ulidFromInteger)+ ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` utc+ in+ Note+ { ulid = (T.toLower . show) ulidCombined+ , body = body+ }+++importUtcFormat :: TimeFormatString+importUtcFormat =+ toFormat ("YYYY-MM-DD H:MI:S.ms" :: [Char])+++data ImportTask = ImportTask+ { task :: Task+ , notes :: [Note]+ , tags :: [Text]+ }+ deriving (Show)+++emptyImportTask :: ImportTask+emptyImportTask =+ ImportTask+ { task = emptyTask+ , notes = []+ , tags = []+ }+++-- | Values a suffixed with a prime (') to avoid name collisions+instance FromJSON ImportTask where+ parseJSON = withObject "task" $ \o -> do+ utc <- o .:? "utc"+ entry <- o .:? "entry"+ creation <- o .:? "creation"+ creation_utc <- o .:? "creation_utc"+ creationUtc <- o .:? "creationUtc"+ created <- o .:? "created"+ created_at <- o .:? "created_at"+ createdAt <- o .:? "createdAt"+ created_utc <- o .:? "created_utc"+ createdUtc_ <- o .:? "createdUtc"++ let+ parsedCreatedUtc =+ parseUtc+ =<< ( utc+ <|> entry+ <|> creation+ <|> creation_utc+ <|> creationUtc+ <|> created+ <|> created_at+ <|> createdAt+ <|> created_utc+ <|> createdUtc_+ )+ createdUtc = fromMaybe zeroTime parsedCreatedUtc++ o_title <- o .:? "title"+ o_body <- o .:? "body"+ description <- o .:? "description"+ let body = fromMaybe "" (o_title <|> o_body <|> description)++ o_priority_adjustment <- o .:? "priority_adjustment"+ urgency <- o .:? "urgency"+ priority <- optional (o .: "priority")+ let priority_adjustment = o_priority_adjustment <|> urgency <|> priority++ modified <- o .:? "modified"+ modified_at <- o .:? "modified_at"+ o_modified_utc <- o .:? "modified_utc"+ modification_date <- o .:? "modification_date"+ updated_at <- o .:? "updated_at"+ let+ -- TODO: Parse the fields first and then combine them with `<|>`+ maybeModified =+ modified+ <|> modified_at+ <|> o_modified_utc+ <|> modification_date+ <|> updated_at+ modified_utc =+ maybeModified+ >>= parseUtc+ & fromMaybe createdUtc+ & timePrint importUtcFormat+ & T.pack++ o_state <- o .:? "state"+ status <- o .:? "status"+ let+ state = textToTaskState =<< (o_state <|> status)+ implicitCloseUtcMaybe =+ if isJust state+ then+ maybeModified+ <|> Just (T.pack $ timePrint importUtcFormat createdUtc)+ else Nothing++ o_tags <- o .:? "tags"+ (o_labelsMb :: Maybe [Value]) <- o .:? "labels"+ let labels =+ o_labelsMb+ <&> ( ( \o_labels ->+ o_labels <&> \case+ String txt -> Just txt+ Object obj ->+ P.flip parseMaybe obj (\o_ -> o_ .:? "name" .!= "")+ _ -> Nothing+ )+ >>> P.catMaybes+ )++ project <- o .:? "project"+ let+ projects = project <&> (: [])+ tags = fromMaybe [] (o_tags <> labels <> projects)++ due <- o .:? "due"+ o_due_utc <- o .:? "due_utc"+ due_on <- o .:? "due_on"+ let+ maybeDue = due <|> o_due_utc <|> due_on+ due_utc =+ fmap+ (T.pack . timePrint importUtcFormat)+ (parseUtc =<< maybeDue)++ awake' <- o .:? "awake"+ awake_at' <- o .:? "awake_at"+ sleep' <- o .:? "sleep"+ sleep_utc' <- o .:? "sleep_utc"+ sleep_until' <- o .:? "sleep_until"+ wait' <- o .:? "wait"+ wait_until' <- o .:? "wait_until"+ let+ maybeAwake =+ awake'+ <|> awake_at'+ <|> sleep'+ <|> sleep_utc'+ <|> sleep_until'+ <|> wait'+ <|> wait_until'+ awake_utc =+ fmap+ (T.pack . timePrint importUtcFormat)+ (parseUtc =<< maybeAwake)++ ready' <- o .:? "ready"+ ready_since' <- o .:? "ready_since"+ ready_utc' <- o .:? "ready_utc"+ let+ maybeReady = ready' <|> ready_since' <|> ready_utc'+ ready_utc =+ fmap+ (T.pack . timePrint importUtcFormat)+ (parseUtc =<< maybeReady)++ review' <- o .:? "review"+ review_at' <- o .:? "review_at"+ review_since' <- o .:? "review_since"+ review_utc' <- o .:? "review_utc"+ let+ maybeReview = review' <|> review_at' <|> review_since' <|> review_utc'+ review_utc =+ fmap+ (T.pack . timePrint importUtcFormat)+ (parseUtc =<< maybeReview)++ waiting' <- o .:? "waiting"+ waiting_since' <- o .:? "waiting_since"+ waiting_utc' <- o .:? "waiting_utc"+ let+ maybewaiting = waiting' <|> waiting_since' <|> waiting_utc'+ waiting_utc =+ fmap+ (T.pack . timePrint importUtcFormat)+ (parseUtc =<< maybewaiting)++ closed <- o .:? "closed"+ o_closed_utc <- o .:? "closed_utc"+ closed_at <- o .:? "closed_at"+ closed_on <- o .:? "closed_on"+ end <- o .:? "end"+ o_end_utc <- o .:? "end_utc"+ end_on <- o .:? "end_on"+ let+ maybeClosed =+ closed+ <|> o_closed_utc+ <|> closed_at+ <|> closed_on+ <|> end+ <|> o_end_utc+ <|> end_on+ <|> implicitCloseUtcMaybe+ closed_utc =+ fmap+ (T.pack . timePrint importUtcFormat)+ (parseUtc =<< maybeClosed)++ group_ulid <- o .:? "group_ulid"++ let parseIsoDurationMb durTextMb =+ hush $+ fmap (P.decodeUtf8 . Iso.formatDuration) $+ Iso.parseDuration $+ P.encodeUtf8 $+ fromMaybe "" durTextMb++ repetition_duration' <- o .:? "repetition_duration"+ repeat_duration' <- o .:? "repeat_duration"+ let+ maybeRepetition = repetition_duration' <|> repeat_duration'+ repetition_duration = parseIsoDurationMb maybeRepetition++ recurrence_duration' <- o .:? "recurrence_duration"+ recur_duration' <- o .:? "recur_duration"+ let+ maybeRecurrence = recurrence_duration' <|> recur_duration'+ recurrence_duration = parseIsoDurationMb maybeRecurrence++ o_notes <-+ asum+ [ o .:? "notes" :: Parser (Maybe [Note])+ , do+ notesMb <- o .:? "notes" :: Parser (Maybe [Text])+ pure $ case notesMb of+ Just textNotes -> Just $ textNotes <&> textToNote createdUtc+ Nothing -> Just []+ ]+ annotations <- o .:? "annotations" :: Parser (Maybe [Annotation])++ let+ notes = case (o_notes, annotations) of+ (Nothing, Nothing) -> []+ (Nothing, Just values) -> values <&> annotationToNote+ (Just theNotes, _) -> case parsedCreatedUtc of+ Just crUtc ->+ theNotes+ <&> ( \theNote ->+ theNote+ { Note.ulid =+ theNote.ulid+ & parseUlidText+ <&> P.flip setDateTime crUtc+ <&> show @ULID+ & fromMaybe theNote.ulid+ & T.toLower+ }+ )+ Nothing -> theNotes++ (o_userMb :: Maybe Value) <- o .:? "user"+ o_author <- o .:? "author"+ let+ o_userNormMb =+ o_userMb >>= \case+ String txt -> Just txt+ Object obj ->+ P.flip parseMaybe obj (\o_ -> o_ .:? "login" .!= "")+ _ -> Nothing+ userMaybe = o_userNormMb <|> o_author+ user = fromMaybe "" userMaybe++ o_metadata <- o .:? "metadata"+ let+ -- Only delete fields with highest priority,+ -- as they would definitely have been used if available+ -- TODO: Check which fields were actually used and delete only them+ -- (Crudly done for title and body)+ metadata =+ o_metadata+ <|> ( ( o+ & ( case (o_title, o_body) of+ (Nothing, Just _) -> KeyMap.delete "body"+ _ -> KeyMap.delete "title"+ )+ & KeyMap.delete "utc"+ & KeyMap.delete "priority_adjustment"+ & KeyMap.delete "tags"+ & (if notes /= [] then KeyMap.delete "notes" else P.identity)+ )+ & ( \val ->+ if val == KeyMap.empty+ then+ Nothing+ else Just (Object val)+ )+ )+ tempTask = Task{ulid = "", ..}++ o_ulid <- o .:? "ulid"+ let+ ulidGeneratedRes =+ tempTask & (hash >>> toInteger >>> abs >>> ulidFromInteger)+ ulidCombined =+ (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` createdUtc+ ulid =+ T.toLower $+ fromMaybe+ ""+ (o_ulid <|> Just (show ulidCombined))++ -- let showInt = show :: Int -> Text+ -- uuid <- o .:? "uuid"+ -- -- Map `show` over `Parser` & `Maybe` to convert possible `Int` to `Text`+ -- id <- (o .:? "id" <|> ((showInt <$>) <$> (o .:? "id")))+ -- let id = (uuid <|> id)++ let finalTask = tempTask{Task.ulid = ulid}++ pure $ ImportTask finalTask notes tags+++setMissingFields :: ImportTask -> P.IO ImportTask+setMissingFields importTaskRec = do+ now <- dateCurrent+ let nowUlidTxt = now & toUlidTime & show & T.toLower+ pure $+ importTaskRec+ { task =+ importTaskRec.task+ { Task.ulid =+ if zeroUlidTxt `T.isPrefixOf` importTaskRec.task.ulid+ then+ importTaskRec.task.ulid+ & T.replace zeroUlidTxt nowUlidTxt+ else importTaskRec.task.ulid+ , Task.modified_utc =+ if importTaskRec.task.modified_utc == ""+ || importTaskRec.task.modified_utc == "1970-01-01 00:00:00"+ || importTaskRec.task.modified_utc == "1970-01-01 00:00:00.000"+ || parseUtc importTaskRec.task.modified_utc == parseUtcNum 0+ then+ now+ & timePrint (toFormat importUtcFormat)+ & T.pack+ else show importTaskRec.task.modified_utc+ }+ }+++importTaskToFullTask :: ImportTask -> FullTask.FullTask+importTaskToFullTask ImportTask{task, notes, tags} =+ FullTask.FullTask+ { FullTask.ulid = task.ulid+ , FullTask.body = task.body+ , FullTask.modified_utc = task.modified_utc+ , FullTask.awake_utc = task.awake_utc+ , FullTask.ready_utc = task.ready_utc+ , FullTask.waiting_utc = task.waiting_utc+ , FullTask.review_utc = task.review_utc+ , FullTask.due_utc = task.due_utc+ , FullTask.closed_utc = task.closed_utc+ , FullTask.state = task.state+ , FullTask.group_ulid = task.group_ulid+ , FullTask.repetition_duration = task.repetition_duration+ , FullTask.recurrence_duration = task.recurrence_duration+ , FullTask.tags = Just tags+ , FullTask.notes = Just notes+ , FullTask.priority = task.priority_adjustment+ , FullTask.user = task.user+ , FullTask.metadata = task.metadata+ }
source/Lib.hs view
@@ -8,2947 +8,3547 @@ -} module Lib where -import Protolude as P (- Applicative (liftA2, pure),- Bool (..),- Char,- Double,- Down (Down),- Either,- Eq (..),- FilePath,- Float,- Floating (logBase),- Foldable (foldMap, length, maximum, null),- Fractional ((/)),- Functor (fmap),- IO,- Int,- Int64,- Integer,- Integral (toInteger),- Maybe (..),- Monad (return, (>>=)),- MonadIO (liftIO),- Monoid (mempty),- Num (abs, fromInteger, (*), (+), (-)),- Ord (compare, max, (<), (>)),- Read,- RealFrac (ceiling, floor),- Semigroup ((<>)),- Show,- Text,- any,- catMaybes,- const,- decodeUtf8,- dropWhile,- either,- encodeUtf8,- exitFailure,- filter,- forM,- forM_,- fromIntegral,- fromMaybe,- fst,- getArgs,- head,- identity,- intersperse,- isJust,- isNothing,- isSpace,- lastMay,- listToMaybe,- maybe,- maybeToEither,- not,- on,- otherwise,- print,- realToFrac,- repeat,- reverse,- show,- snd,- sortBy,- sortOn,- stderr,- take,- takeWhile,- unlines,- unwords,- ($),- ($>),- (&),- (&&),- (.),- (<$>),- (<&>),- (||),- )-import Protolude qualified as P--import Control.Arrow ((>>>))-import Data.Aeson as Aeson (KeyValue ((.=)), encode, object)-import Data.Coerce (coerce)-import Data.Generics (Data, constrFields, toConstr)-import Data.Hourglass (- DateTime (dtTime),- Duration (durationHours, durationMinutes),- ElapsedP,- ISO8601_Date (ISO8601_Date),- Minutes (Minutes),- Time (timeFromElapsedP),- TimeOfDay (todNSec),- timeAdd,- timePrint,- )-import Data.List (nub)-import Data.Text as T (- breakOn,- dropEnd,- intercalate,- isPrefixOf,- justifyRight,- length,- pack,- replace,- replicate,- take,- takeEnd,- toLower,- unpack,- unwords,- words,- )-import Data.Text.Lazy qualified as TL-import Data.Text.Lazy.Encoding qualified as TL-import Data.Time.Clock (UTCTime)-import Data.Time.ISO8601.Duration qualified as Iso-import Data.ULID (ULID, getULID)-import Data.Yaml as Yaml (encode)-import Database.SQLite.Simple (- Error (ErrorConstraint),- Only (Only),- SQLError (sqlError),- )-import Database.SQLite.Simple as Sql (- Connection,- FromRow (..),- NamedParam ((:=)),- Query (Query),- SQLData (SQLText),- ToRow,- changes,- execute,- executeNamed,- field,- open,- query,- queryNamed,- query_,- toRow,- withConnection,- )-import Database.SQLite.Simple.QQ (sql)-import Numeric (showFFloat)-import Prettyprinter as Pp (- Doc,- Pretty (pretty),- align,- annotate,- concatWith,- dquotes,- fill,- hang,- hardline,- hsep,- indent,- line,- punctuate,- vcat,- vsep,- (<+>),- )-import Prettyprinter.Render.Terminal (- AnsiStyle,- Color (Black, Green, Red, Yellow),- bgColorDull,- bold,- color,- colorDull,- hPutDoc,- putDoc,- underlined,- )-import Prettyprinter.Util (reflow)-import System.Directory (createDirectoryIfMissing)-import System.FilePath ((</>))-import System.Posix.User (getEffectiveUserName)-import System.Process (readProcess)-import Text.Fuzzily qualified as Fuzzily-import Text.ParserCombinators.ReadP as ReadP (- ReadP,- char,- eof,- munch,- munch1,- readP_to_S,- sepBy1,- skipSpaces,- string,- (<++),- )-import Time.System (dateCurrent, timeCurrentP)--import Config (- Config (- bodyClosedStyle,- bodyStyle,- bodyWidth,- closedStyle,- dataDir,- dateStyle,- dateWidth,- dbName,- dueStyle,- headCount,- hooks,- idStyle,- prioWidth,- priorityStyle,- progressBarWidth,- tableName,- tagStyle,- utcFormat,- utcFormatShort- ),- HookSet (pre),- HooksConfig (add),- defaultConfig,- )-import Control.Monad.Catch (catchIf)-import FullTask (- FullTask (- awake_utc,- body,- closed_utc,- due_utc,- group_ulid,- metadata,- modified_utc,- notes,- priority,- ready_utc,- recurrence_duration,- repetition_duration,- review_utc,- tags,- ulid,- user,- waiting_utc- ),- cpTimesAndState,- selectQuery,- )-import Note (Note (body, ulid))-import SqlUtils (quoteKeyword, quoteText)-import Task (- DerivedState (IsOpen),- Task,- TaskState (..),- derivedStateToQuery,- getStateHierarchy,- textToDerivedState,- zeroTask,- )-import Task qualified-import TaskToNote (TaskToNote (..))-import TaskToTag (TaskToTag (..))-import Utils (- IdText,- ListModifiedFlag (..),- applyColorMode,- dateTimeToUtcTime,- executeHooks,- numDigits,- parseUlidText,- parseUtc,- setDateTime,- ulidTextToDateTime,- utcFormatReadable,- utcTimeToDateTime,- vsepCollapse,- (<$$>),- (<++>),- )---noTasksWarning :: Text-noTasksWarning =- "No tasks available. "- <> "Run `tasklite help` to learn how to create tasks."---newtype NumRows = NumRows Integer- deriving (Eq, Ord, Read, Show)---instance FromRow NumRows where- fromRow = NumRows <$> field---getDbPath :: Config -> IO FilePath-getDbPath conf = do- pure $ conf.dataDir </> conf.dbName---setupConnection :: Config -> IO Connection-setupConnection conf = do- createDirectoryIfMissing True $ dataDir conf- open $ conf.dataDir </> conf.dbName---execWithConn :: Config -> (Connection -> IO a) -> IO a-execWithConn conf func = do- createDirectoryIfMissing True $ dataDir conf- withConnection- (conf.dataDir </> conf.dbName)- func----- | Get fields names of record (empty list if not record constructor)-getRecordFields :: (Data object) => object -> [Text]-getRecordFields =- toConstr >>> constrFields >>> fmap T.pack---insertRecord :: (ToRow r, Data r) => Text -> Connection -> r -> IO ()-insertRecord tableName connection record = do- let recordFields = record & getRecordFields- execute- connection- ( Query $- "INSERT INTO "- <> tableName- <> "("- <> (recordFields & T.intercalate ",\n")- <> ") VALUES ("- <> ((recordFields $> "?") & T.intercalate ",\n")- <> ")"- )- (toRow record)---getUpdateAssignments :: Task -> Text-getUpdateAssignments task =- task- & getRecordFields- <&> (<> " = ?")- & T.intercalate ", "---updateTask :: Connection -> Task -> IO ()-updateTask connection task = do- execute- connection- ( Query $- " UPDATE tasks SET "- <> getUpdateAssignments task- <> " WHERE ulid == ?"- )- (toRow task <> [SQLText task.ulid])---handleTagDupError :: Text -> (Applicative f) => e -> f (Doc AnsiStyle)-handleTagDupError tag _exception =- pure $- annotate (color Yellow) $- "⚠️ Tag " <> dquotes (pretty tag) <> " is already assigned"---insertTags- :: Connection -> Maybe DateTime -> Task -> [Text] -> IO (Doc AnsiStyle)-insertTags connection mbCreatedUtc task tags = do- let uniqueTags = nub tags- taskToTags <- forM uniqueTags $ \tag -> do- tagUlid <- getULID- pure $- TaskToTag- { ulid =- mbCreatedUtc- <&> setDateTime tagUlid- & fromMaybe tagUlid- & show- & T.toLower- , task_ulid = task.ulid- , tag = tag- }-- -- TODO: Insert all tags at once- insertWarnings <- P.forM taskToTags $ \taskToTag ->- catchIf- -- TODO: Find out why it's not `ErrorConstraintUnique`- (\(err :: SQLError) -> err.sqlError == ErrorConstraint)- (insertRecord "task_to_tag" connection taskToTag P.>> pure "")- (handleTagDupError taskToTag.tag)-- pure $ vsepCollapse insertWarnings---insertNotes :: Connection -> Maybe DateTime -> Task -> [Note] -> IO ()-insertNotes connection mbCreatedUtc task notes = do- taskToNotes <- forM notes $ \theNote -> do- let- noteUlidTxt = theNote.ulid- mbNoteUlid = parseUlidText noteUlidTxt- mbNewUlid = do- createdUtc <- mbCreatedUtc- noteUlid <- mbNoteUlid-- pure $ show $ setDateTime noteUlid createdUtc-- pure $- TaskToNote- { ulid =- mbNewUlid- & fromMaybe noteUlidTxt- & T.toLower- , task_ulid = task.ulid- , note = theNote.body- }-- P.forM_ taskToNotes $ \taskToNote ->- insertRecord "task_to_note" connection taskToNote----- | Tuple is (Maybe createdUtc, noteBody)-insertNoteTuples :: Connection -> Task -> [(Maybe DateTime, Text)] -> IO ()-insertNoteTuples connection task notes = do- taskToNotes <- forM notes $ \(mbCreatedUtc, noteBody) -> do- noteUlid <- getULID- pure $- TaskToNote- { ulid =- mbCreatedUtc- <&> setDateTime noteUlid- & fromMaybe noteUlid- & show- & T.toLower- , task_ulid = task.ulid- , note = noteBody- }-- forM_ taskToNotes $ \taskToNote ->- insertRecord "task_to_note" connection taskToNote---formatElapsedP :: Config -> IO ElapsedP -> IO Text-formatElapsedP conf =- fmap (pack . timePrint conf.utcFormat)---formatUlid :: IO ULID -> IO Text-formatUlid =- fmap (T.toLower . show)---{-| Parses the body of the tasks and extracts all meta data- | Returns a tuple (body, tags, dueUtcMb, createdUtcMb)- TODO: Replace with parsec implementation--}-parseTaskBody :: [Text] -> (Text, [Text], Maybe Text, Maybe DateTime)-parseTaskBody bodyWords =- let- isTag = ("+" `T.isPrefixOf`)- isDueUtc = ("due:" `T.isPrefixOf`)- isCreatedUtc = ("created:" `T.isPrefixOf`)- isMeta word = isTag word || isDueUtc word || isCreatedUtc word- -- Handle case when word is actually a text- bodyWordsReversed = bodyWords & T.unwords & T.words & P.reverse- body =- bodyWordsReversed- & P.dropWhile isMeta- & P.reverse- & unwords- metadata =- bodyWordsReversed- & P.takeWhile isMeta- & P.reverse- tags = fmap (T.replace "+" "") (P.filter isTag metadata)- dueUtcMb =- metadata- & P.filter isDueUtc- <&> T.replace "due:" ""- & P.lastMay- >>= parseUtc- <&> (timePrint utcFormatReadable >>> pack)- createdUtcMb =- metadata- & P.filter isCreatedUtc- <&> T.replace "created:" ""- & P.lastMay- >>= parseUtc- in- (body, tags, dueUtcMb, createdUtcMb)---getTriple :: Config -> IO (ULID, Text, [Char])-getTriple conf = do- ulid <- getULID- -- TODO: Set via a SQL trigger- modified_utc <- formatElapsedP conf timeCurrentP- effectiveUserName <- getEffectiveUserName-- pure (ulid, modified_utc, effectiveUserName)---addTask :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)-addTask conf connection bodyWords = do- (ulid, modified_utc, effectiveUserName) <- getTriple conf- let- (body, tags, dueUtcMb, createdUtcMb) = parseTaskBody bodyWords- task =- zeroTask- { Task.ulid = T.toLower $ show $ case createdUtcMb of- Nothing -> ulid- Just createdUtc -> setDateTime ulid createdUtc- , Task.body = body- , Task.due_utc = dueUtcMb- , Task.modified_utc = modified_utc- , Task.user = T.pack effectiveUserName- }-- args <- getArgs- preAddResult <-- executeHooks- ( TL.toStrict $- TL.decodeUtf8 $- Aeson.encode $- object- [ "arguments" .= args- , "taskToAdd" .= task- -- TODO: Add tags and notes to task- ]- )- (conf.hooks & add & pre)- putDoc preAddResult-- insertRecord "tasks" connection task- warnings <- insertTags connection Nothing task tags-- pure $- warnings- <$$> ( "🆕 Added task"- <+> dquotes (pretty task.body)- <+> "with id"- <+> dquotes (pretty task.ulid)- )---logTask :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)-logTask conf connection bodyWords = do- (ulid, modified_utc, effectiveUserName) <- getTriple conf- let- (body, extractedTags, dueUtcMb, createdUtcMb) = parseTaskBody bodyWords- tags = extractedTags <> ["log"]- task =- zeroTask- { Task.ulid = T.toLower $ show $ case createdUtcMb of- Nothing -> ulid- Just createdUtc -> setDateTime ulid createdUtc- , Task.body = body- , Task.state = Just Done- , Task.due_utc = dueUtcMb- , Task.closed_utc = Just modified_utc- , Task.user = T.pack effectiveUserName- , Task.modified_utc = modified_utc- }-- insertRecord "tasks" connection task- warnings <- insertTags connection Nothing task tags- pure $- warnings- <$$> "📝 Logged task"- <+> dquotes (pretty task.body)- <+> "with id"- <+> dquotes (pretty task.ulid)---execWithTask- :: Config- -> Connection- -> Text- -> (Task -> IO (Doc AnsiStyle))- -> IO (Doc AnsiStyle)-execWithTask conf connection idSubstr callback = do- tasks <-- query- connection- ( Query $- "SELECT *\n"- <> ("FROM \"" <> conf.tableName <> "\"\n")- <> "WHERE ulid LIKE ?\n"- )- ["%" <> idSubstr :: Text]- :: IO [Task]-- let- numOfTasks = P.length tasks- ulidLength = 26- prefix = if T.length idSubstr == ulidLength then "" else "…"- quote = dquotes . pretty-- if- | numOfTasks == 0 ->- pure $- "⚠️ Task" <+> quote (prefix <> idSubstr) <+> "does not exist"- | numOfTasks == 1 ->- callback $ fromMaybe zeroTask $ P.head tasks- | numOfTasks > 1 ->- pure $- "⚠️ Id slice"- <+> quote idSubstr- <+> "is not unique."- <+> "It could refer to one of the following tasks:"- <++> P.foldMap- ( \task ->- annotate conf.idStyle (pretty task.ulid)- <++> pretty task.body- <> hardline- )- tasks- | otherwise -> pure "This case should not be possible"----- | Set state and automatically sets `closed_utc` via an SQL trigger-setClosedWithState :: Connection -> Task -> Maybe TaskState -> IO ()-setClosedWithState connection task theTaskState = do- executeNamed- connection- [sql|- UPDATE tasks- SET- state = :state,- review_utc = NULL- WHERE- ulid == :ulid AND- (state IS NULL OR state != :state)- |]- [ ":ulid" := task.ulid- , ":state" := theTaskState- ]---setReadyUtc- :: Config -> Connection -> DateTime -> [IdText] -> IO (Doc AnsiStyle)-setReadyUtc conf connection datetime ids = do- let utcText = pack $ timePrint conf.utcFormat datetime-- docs <- forM ids $ \idSubstr ->- execWithTask conf connection idSubstr $ \task -> do- updateTask connection $ task{Task.ready_utc = Just utcText}-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- pure $- "📅 Set ready UTC of task"- <+> prettyBody- <+> "with id"- <+> prettyId- <+> "to"- <+> dquotes (pretty utcText)-- pure $ vsep docs---waitFor- :: Config -> Connection -> Iso.Duration -> [Text] -> IO (Doc AnsiStyle)-waitFor conf connection duration ids = do- docs <- forM ids $ \idSubstr ->- execWithTask conf connection idSubstr $ \task -> do- now <- timeCurrentP- let- nowAsText = (pack . timePrint conf.utcFormat) now- threeDays =- (pack . timePrint conf.utcFormat)- ( utcTimeToDateTime $- Iso.addDuration duration $- dateTimeToUtcTime $- timeFromElapsedP now- )-- executeNamed- connection- [sql|- UPDATE tasks- SET- waiting_utc = :waiting_utc,- review_utc = :review_utc- WHERE- ulid == :ulid- |]- [ ":ulid" := task.ulid- , ":waiting_utc" := nowAsText- , ":review_utc" := threeDays- ]-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- numOfChanges <- changes connection-- pure $- if numOfChanges == 0- then- "⚠️ An error occurred while moving task"- <+> prettyBody- <> "with id"- <+> prettyId- <+> "into waiting mode"- else- "⏳ Set waiting UTC and review UTC for task"- <+> prettyBody- <+> "with id"- <+> prettyId-- pure $ vsep docs---waitTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)-waitTasks conf connection =- waitFor conf connection $- Iso.DurationDate (Iso.DurDateDay (Iso.DurDay 3) Nothing)---reviewTasksIn- :: Config- -> Connection- -> Iso.Duration- -> [Text]- -> IO (Doc AnsiStyle)-reviewTasksIn conf connection duration ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- now <- timeCurrentP- let- xDays =- (pack . timePrint conf.utcFormat)- ( utcTimeToDateTime $- Iso.addDuration duration $- dateTimeToUtcTime $- timeFromElapsedP now- )- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid- warningStart = "⚠️ Task" <+> prettyBody <+> "with id" <+> prettyId-- if isJust task.closed_utc- then pure $ warningStart <+> "is already closed"- else do- executeNamed- connection- [sql|- UPDATE tasks- SET review_utc = :review_utc- WHERE ulid == :ulid- |]- [ ":ulid" := task.ulid- , ":review_utc" := xDays- ]-- numOfChanges <- changes connection-- pure $- if numOfChanges == 0- then warningStart <+> "could not be reviewed"- else getResultMsg "🔎 Finished review" task-- pure $ vsep docs---showDateTime :: Config -> DateTime -> Text-showDateTime conf =- pack . timePrint conf.utcFormat---showEither :: Config -> Either a UTCTime -> Maybe Text-showEither conf theEither =- theEither- & either (const Nothing) Just- <&> (utcTimeToDateTime >>> showDateTime conf)----- TODO: Eliminate code duplication with createNextRecurrence-createNextRepetition- :: Config -> Connection -> Task -> IO (Maybe (Doc AnsiStyle))-createNextRepetition conf connection task = do- newUlidText <- formatUlid getULID- let- nowMb =- ulidTextToDateTime newUlidText-- durTextEither =- maybeToEither- "Task has no repetition duration"- task.repetition_duration-- isoDurEither =- durTextEither- <&> encodeUtf8- >>= Iso.parseDuration-- nextDueMb =- liftA2- Iso.addDuration- isoDurEither- ( maybeToEither- "ULID can't be converted to UTC time"- (nowMb <&> dateTimeToUtcTime)- )-- newTask =- task- { Task.ulid = newUlidText- , Task.due_utc = nextDueMb & showEither conf- , Task.closed_utc = Nothing- , Task.state = Nothing- , Task.awake_utc =- liftA2- Iso.addDuration- isoDurEither- ( maybeToEither- "Task has no awake UTC"- (task.awake_utc >>= parseUtc <&> dateTimeToUtcTime)- )- & showEither conf- , Task.ready_utc =- liftA2- Iso.addDuration- isoDurEither- ( maybeToEither- "Task has no ready UTC"- (task.ready_utc >>= parseUtc <&> dateTimeToUtcTime)- )- & showEither conf- , Task.modified_utc =- nowMb- <&> (timePrint conf.utcFormat >>> pack)- & fromMaybe ""- }-- insertRecord "tasks" connection newTask-- tags <-- query- connection- [sql|- SELECT tag- FROM task_to_tag- WHERE task_ulid == ?- |]- (Only task.ulid)-- warnings <- liftIO $ insertTags connection Nothing newTask (tags & P.concat)-- liftIO $- pure $- Just $- warnings- <$$> "➡️ Created next task"- <+> dquotes (pretty newTask.body)- <+> "in repetition series"- <+> dquotes (pretty newTask.group_ulid)- <+> "with id"- <+> dquotes (pretty newUlidText)----- TODO: Eliminate code duplication with createNextRepetition-createNextRecurrence- :: Config -> Connection -> Task -> IO (Maybe (Doc AnsiStyle))-createNextRecurrence conf connection task = do- newUlidText <- formatUlid getULID- let- dueUtcMb =- task.due_utc >>= parseUtc-- durTextEither =- maybeToEither- "Task has no recurrence duration"- task.recurrence_duration-- isoDurEither =- durTextEither- <&> encodeUtf8- >>= Iso.parseDuration-- nextDueMb =- liftA2- Iso.addDuration- isoDurEither- (maybeToEither "Task has no due UTC" (dueUtcMb <&> dateTimeToUtcTime))-- newTask =- task- { Task.ulid = newUlidText- , Task.due_utc = nextDueMb & showEither conf- , Task.closed_utc = Nothing- , Task.state = Nothing- , Task.awake_utc =- liftA2- Iso.addDuration- isoDurEither- ( maybeToEither- "Task has no awake UTC"- (task.awake_utc >>= parseUtc <&> dateTimeToUtcTime)- )- & showEither conf- , Task.ready_utc =- liftA2- Iso.addDuration- isoDurEither- ( maybeToEither- "Task has no ready UTC"- (task.ready_utc >>= parseUtc <&> dateTimeToUtcTime)- )- & showEither conf- , Task.modified_utc =- newUlidText- & ulidTextToDateTime- <&> (timePrint conf.utcFormat >>> pack)- & fromMaybe ""- }-- tags <-- query- connection- [sql|- SELECT tag- FROM task_to_tag- WHERE task_ulid == ?- |]- (Only task.ulid)-- warnings <- liftIO $ insertTags connection Nothing newTask (tags & P.concat)-- liftIO $- pure $- Just $- warnings- <$$> "➡️ Created next task"- <+> dquotes (pretty task.body)- <+> "in recurrence series"- <+> dquotes (pretty task.group_ulid)- <+> "with id"- <+> dquotes (pretty newUlidText)---doTasks :: Config -> Connection -> Maybe [Text] -> [Text] -> IO (Doc AnsiStyle)-doTasks conf connection noteWordsMaybe ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- if isJust task.closed_utc- then- pure $- "⚠️ Task"- <+> dquotes (pretty task.ulid)- <+> "is already done"- else do- logMessageMaybe <-- if isJust task.repetition_duration- then createNextRepetition conf connection task- else- if isJust task.recurrence_duration- then createNextRecurrence conf connection task- else pure Nothing-- noteMessageMaybe <- case noteWordsMaybe of- Nothing -> pure Nothing- Just noteWords ->- liftIO $- addNote conf connection (unwords noteWords) ids <&> Just-- setClosedWithState connection task $ Just Done-- pure $- fromMaybe "" (noteMessageMaybe <&> (<> hardline))- <> ( "✅ Finished task"- <+> dquotes (pretty task.body)- <+> "with id"- <+> dquotes (pretty task.ulid)- )- <> fromMaybe "" (logMessageMaybe <&> (hardline <>))-- pure $ vsep docs---endTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)-endTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- setClosedWithState connection task $ Just Obsolete- numOfChanges <- changes connection-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- pure $- if numOfChanges == 0- then- "⚠️ Task"- <+> prettyBody- <+> "with id"- <+> prettyId- <+> "is already marked as obsolete"- else- "⏹ Marked task"- <+> prettyBody- <+> "with id"- <+> prettyId- <+> "as obsolete"-- pure $ vsep docs---trashTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)-trashTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- setClosedWithState connection task $ Just Deletable- numOfChanges <- changes connection-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- pure $- if numOfChanges == 0- then- "⚠️ Task"- <+> prettyBody- <+> "with id"- <+> prettyId- <+> "is already marked as deletable"- else- "🗑 Marked task"- <+> prettyBody- <+> "with id"- <+> prettyId- <+> "as deletable"-- pure $ vsep docs---deleteTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)-deleteTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- execute- connection- [sql|- DELETE FROM tasks- WHERE ulid == ?- |]- (Only task.ulid)-- execute- connection- [sql|- DELETE FROM task_to_tag- WHERE task_ulid == ?- |]- (Only task.ulid)-- execute- connection- [sql|- DELETE FROM task_to_note- WHERE task_ulid == ?- |]- (Only task.ulid)-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- pure $ "❌ Deleted task" <+> prettyBody <+> "with id" <+> prettyId-- pure $ vsep docs---durationToIso :: Duration -> Text-durationToIso dur =- "PT" <> show (coerce (durationMinutes dur) :: Int64) <> "M"---repeatTasks- :: Config -> Connection -> Iso.Duration -> [IdText] -> IO (Doc AnsiStyle)-repeatTasks conf connection duration ids = do- let durationIsoText = decodeUtf8 $ Iso.formatDuration duration-- docs <- forM ids $ \idSubstr ->- execWithTask conf connection idSubstr $ \task -> do- groupUlid <- formatUlid getULID-- executeNamed- connection- [sql|- UPDATE tasks- SET- repetition_duration = :repetition_duration,- group_ulid = :group_ulid- WHERE ulid == :ulid- |]- [ ":repetition_duration" := durationIsoText- , ":group_ulid" := groupUlid- , ":ulid" := task.ulid- ]-- -- If repetition is set for already closed task,- -- next task in series must be created immediately- creationMb <-- if isNothing task.closed_utc- then pure $ Just mempty- else- liftIO $- createNextRepetition conf connection $- task- { Task.repetition_duration = Just durationIsoText- , Task.group_ulid = Just groupUlid- }-- pure $- "📅 Set repeat duration of task"- <+> dquotes (pretty task.body)- <+> "with id"- <+> dquotes (pretty task.ulid)- <+> "to"- <+> dquotes (pretty durationIsoText)- <++> ( creationMb- & fromMaybe- "⚠️ Next task in repetition series could not be created!"- )-- pure $ vsep docs---recurTasks- :: Config -> Connection -> Iso.Duration -> [IdText] -> IO (Doc AnsiStyle)-recurTasks conf connection duration ids = do- let durationIsoText = decodeUtf8 $ Iso.formatDuration duration-- docs <- forM ids $ \idSubstr ->- execWithTask conf connection idSubstr $ \task -> do- groupUlid <- formatUlid getULID-- executeNamed- connection- [sql|- UPDATE tasks- SET- recurrence_duration = :recurrence_duration,- group_ulid = :group_ulid- WHERE ulid == :ulid- |]- [ ":recurrence_duration" := durationIsoText- , ":group_ulid" := groupUlid- , ":ulid" := task.ulid- ]-- -- If recurrence is set for already closed task,- -- next task in series must be created immediately- creationMb <-- if isNothing task.closed_utc- then pure $ Just mempty- else- liftIO $- createNextRecurrence conf connection $- task- { Task.recurrence_duration = Just durationIsoText- , Task.group_ulid = Just groupUlid- }-- pure $- "📅 Set recurrence duration of task"- <+> dquotes (pretty task.body)- <+> "with id"- <+> dquotes (pretty task.ulid)- <+> "to"- <+> dquotes (pretty durationIsoText)- <++> ( creationMb- & fromMaybe- "⚠️ Next task in recurrence series could not be created!"- )-- pure $ vsep docs---adjustPriority :: Config -> Float -> [IdText] -> IO (Doc AnsiStyle)-adjustPriority conf adjustment ids = do- dbPath <- getDbPath conf- withConnection dbPath $ \connection -> do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET priority_adjustment =- ifnull(priority_adjustment, 0) + :adjustment- WHERE ulid == :ulid- |]- [ ":adjustment" := adjustment- , ":ulid" := task.ulid- ]-- numOfChanges <- changes connection-- let prettyBody = dquotes $ pretty task.body-- pure $- if numOfChanges == 0- then- "⚠️ An error occurred while adjusting the priority of task"- <+> prettyBody- else- (if adjustment > 0 then "⬆️ Increased" else "⬇️ Decreased")- <+> "priority of task"- <+> prettyBody- <+> "with id"- <+> dquotes (pretty task.ulid)- <+> "by"- <+> pretty (abs adjustment)-- pure $ vsep docs---startTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)-startTasks conf connection ids = do- logMessage <- addNote conf connection "start" ids-- pure $- pretty $- T.replace- "📝 Added a note to"- "⏳ Started"- (show logMessage)---stopTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)-stopTasks conf connection ids = do- logMessages <- addNote conf connection "stop" ids-- pure $- pretty $- T.replace- "📝 Added a note to"- "⌛️ Stopped"- (show logMessages)---formatTaskForInfo- :: Config- -> DateTime- -> (FullTask, [TaskToTag], [TaskToNote])- -> Doc AnsiStyle-formatTaskForInfo conf now (taskV, tags, notes) =- let- mkGreen = annotate (color Green)- grayOut = annotate (colorDull Black)- stateHierarchy = getStateHierarchy now $ cpTimesAndState taskV- mbCreatedUtc =- fmap- (pack . timePrint (utcFormat defaultConfig))- (ulidTextToDateTime taskV.ulid)- tagsPretty =- tags- <&> ( \t ->- annotate (tagStyle conf) (pretty t.tag)- <++> maybe- mempty- (grayOut . pretty . pack . timePrint conf.utcFormat)- (ulidTextToDateTime t.ulid)- <++> grayOut (pretty t.ulid)- )- notesPretty =- notes- <&> ( \n ->- maybe- mempty- (grayOut . pretty . pack . timePrint conf.utcFormat)- (ulidTextToDateTime n.ulid)- <++> grayOut (pretty n.ulid)- <> hardline- <> indent 2 (reflow n.note)- <> hardline- )-- mbAwakeUtc = FullTask.awake_utc taskV- mbReadyUtc = FullTask.ready_utc taskV- mbWaitingUtc = FullTask.waiting_utc taskV- mbReviewUtc = FullTask.review_utc taskV- mbDueUtc = FullTask.due_utc taskV- mbClosedUtc = FullTask.closed_utc taskV- mbModifiedUtc = Just $ FullTask.modified_utc taskV-- printIf :: Doc AnsiStyle -> Maybe Text -> Maybe (Doc AnsiStyle)- printIf name =- fmap- ( \v ->- name- <+> annotate (dueStyle conf) (pretty v)- <> hardline- )- in- hardline- <> annotate bold (reflow $ FullTask.body taskV)- <> hardline- <> hardline- <> ( if P.null tags- then mempty- else- (tags <&> (TaskToTag.tag >>> formatTag conf) & hsep)- <> hardline- <> hardline- )- <> ( if P.null notes- then mempty- else- ( notes- <&> ( \n ->- maybe- mempty- ( grayOut- . pretty- . pack- . timePrint- (utcFormatShort conf)- )- (ulidTextToDateTime n.ulid)- <++> align (reflow n.note)- )- & vsep- )- <> hardline- <> hardline- )- <> ( " State:"- <+> mkGreen (pretty stateHierarchy)- <> hardline- )- <> ( "Priority:"- <+> annotate- (priorityStyle conf)- (pretty $ FullTask.priority taskV)- <> hardline- )- <> ( " ULID:"- <+> grayOut (pretty $ FullTask.ulid taskV)- <> hardline- )- <> hardline- <> ( [ (printIf "🆕 Created ", mbCreatedUtc)- , (printIf "☀️ Awake ", mbAwakeUtc)- , (printIf "📅 Ready ", mbReadyUtc)- , (printIf "⏳ Waiting ", mbWaitingUtc)- , (printIf "🔎 Review ", mbReviewUtc)- , (printIf "📅 Due ", mbDueUtc)- , (printIf "✅ Done ", mbClosedUtc)- , (printIf "✏️ Modified ", mbModifiedUtc)- ]- & sortBy (compare `on` snd)- & P.mapMaybe (\tup -> fst tup (snd tup))- & punctuate (pretty (" ⬇" :: Text))- & vsep- )- <> hardline- <> maybe- mempty- ( \value ->- "Repetition Duration:"- <+> mkGreen (pretty value)- <> hardline- )- (FullTask.repetition_duration taskV)- <> maybe- mempty- ( \value ->- "Recurrence Duration:"- <+> mkGreen (pretty value)- <> hardline- )- (FullTask.recurrence_duration taskV)- <> maybe- mempty- ( \value ->- "Group Ulid:"- <+> grayOut (pretty value)- <> hardline- )- (FullTask.group_ulid taskV)- <> ( "User:"- <+> mkGreen (pretty $ FullTask.user taskV)- <> hardline- )- <> hardline- <> maybe- mempty- ( \value ->- "Metadata:"- <> hardline- <> indent 2 (pretty $ decodeUtf8 $ Yaml.encode value)- <> hardline- )- (FullTask.metadata taskV)- <> ( if P.null tags- then mempty- else- annotate underlined "Tags Detailed:"- <> hardline- <> hardline- <> vsep tagsPretty- <> hardline- <> hardline- )- <> ( if P.null notes- then mempty- else- annotate underlined "Notes Detailed:"- <> hardline- <> hardline- <> vsep notesPretty- <> hardline- )---infoTask :: Config -> Connection -> Text -> IO (Doc AnsiStyle)-infoTask conf connection idSubstr = do- execWithTask conf connection idSubstr $ \task -> do- now <- dateCurrent-- fullTasks :: [FullTask] <-- query- connection- [sql|- SELECT *- FROM tasks_view- WHERE ulid == ?- |]- (Only task.ulid)-- tags <-- query- connection- [sql|- SELECT *- FROM task_to_tag- WHERE task_ulid == ?- |]- (Only task.ulid)-- notes <-- query- connection- [sql|- SELECT *- FROM task_to_note- WHERE task_ulid == ?- |]- (Only task.ulid)-- pure $ case fullTasks of- [fullTask] -> formatTaskForInfo conf now (fullTask, tags, notes)- _ -> pretty noTasksWarning---nextTask :: Config -> Connection -> IO (Doc AnsiStyle)-nextTask conf connection = do- now <- dateCurrent-- tasks :: [FullTask] <-- query_- connection- [sql|- SELECT *- FROM tasks_view- WHERE closed_utc IS NULL- ORDER BY priority DESC- LIMIT 1- |]-- case tasks of- [fullTask] -> do- tags <-- query- connection- [sql|- SELECT *- FROM task_to_tag- WHERE task_ulid == ?- |]- (Only fullTask.ulid)-- notes <-- query- connection- [sql|- SELECT *- FROM task_to_note- WHERE task_ulid == ?- |]- (Only fullTask.ulid)-- pure $ formatTaskForInfo conf now (fullTask, tags, notes)- _ ->- pure $ pretty noTasksWarning---randomTask :: Config -> Connection -> IO (Doc AnsiStyle)-randomTask conf connection = do- (tasks :: [FullTask]) <-- query_- connection- [sql|- SELECT *- FROM tasks_view- WHERE closed_utc IS NULL- ORDER BY random()- LIMIT 1- |]-- case tasks of- [fullTask] -> infoTask conf connection fullTask.ulid- _ -> pure $ pretty noTasksWarning---findTask :: Connection -> Text -> IO (Doc AnsiStyle)-findTask connection aPattern = do- tasks :: [(Text, Text, Maybe [Text], Maybe [Text], Maybe Text)] <-- query_ connection $- [sql|- SELECT ulid, body, tags, notes, metadata- FROM tasks_view- |]-- let- ulidWidth = 5- numOfResults = 8- minimumScore = 4- ulidColor = Green- preTag = "\x1b[4m\x1b[34m" -- Set color to blue and underline text- postTag = "\x1b[0m" -- Reset styling- metaNorm metadata =- metadata- & fromMaybe ""- & T.replace ",\"" ", \""- & T.replace "\":" "\": "- & T.replace "\"" ""- matchFunc =- Fuzzily.match- Fuzzily.IgnoreCase- (preTag, postTag)- identity- aPattern-- -- Calculate fuzzy score for each part individually- -- and pick the highest one- scoreFunc (ulid, theBody, _, mbNotes, mbMetadata) =- let- scoreParts =- [ matchFunc theBody- , matchFunc (maybe "" unwords mbNotes)- , -- TODO: Find good way to include tags- -- , matchFunc (maybe "" unwords mbTags)- matchFunc (metaNorm mbMetadata)- , matchFunc ulid- ]- highestScore = P.maximum $ 0 : (catMaybes scoreParts <&> Fuzzily.score)- combinedText =- scoreParts- & catMaybes- <&> (Fuzzily.rendered >>> reflow)- & P.intersperse mempty- & vcat- in- (highestScore, ulid, combinedText)-- fstOf3 (x, _, _) = x- tasksScored =- tasks- <&> scoreFunc- & P.filter ((> minimumScore) . fstOf3)- & sortOn (Down . fstOf3)- moreResults = P.length tasksScored - numOfResults- header =- annotate (underlined <> color ulidColor) (fill ulidWidth "ULID")- <++> annotate underlined (fill 20 "Task")- <> hardline- body =- tasksScored- & P.take numOfResults- <&> ( \(_, ulid, combinedText) ->- annotate- (color ulidColor)- (fill ulidWidth $ pretty $ T.takeEnd ulidWidth ulid)- <> indent 2 combinedText- )- & P.intersperse mempty- & vsep- footer =- if moreResults > 0- then- hardline- <> hardline- <> annotate- (color Red)- ("There are " <> pretty moreResults <> " more results available")- <> hardline- else hardline-- pure $ header <> body <> footer----- TODO: Use Continuation monad to avoid callback hell--- withConnectCont :: Text -> ContT a IO Connection--- withConnectCont dbPath =--- ContT $ withConnection dbPath--addTag :: Config -> Connection -> Text -> [IdText] -> IO (Doc AnsiStyle)-addTag conf conn tag ids = do- docs <- forM ids $ \idSubstr ->- execWithTask conf conn idSubstr $ \task -> do- now <- fmap (pack . timePrint conf.utcFormat) timeCurrentP- ulid <- formatUlid getULID-- catchIf- -- TODO: Find out why it's not `ErrorConstraintUnique`- (\(err :: SQLError) -> err.sqlError == ErrorConstraint)- ( do- insertRecord "task_to_tag" conn TaskToTag{ulid, task_ulid = task.ulid, tag}-- -- TODO: Check if modified_utc could be set via SQL trigger- executeNamed- conn- [sql|- UPDATE tasks- SET modified_utc = :now- WHERE ulid == :ulid- |]- [ ":now" := now- , ":ulid" := task.ulid- ]-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- pure $- "🏷 Added tag"- <+> dquotes (pretty tag)- <+> "to task"- <+> prettyBody- <+> "with id"- <+> prettyId- )- (handleTagDupError tag)-- pure $ vsep docs---deleteTag :: Config -> Connection -> Text -> [IdText] -> IO (Doc AnsiStyle)-deleteTag conf connection tag ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- DELETE FROM task_to_tag- WHERE- task_ulid == :task_ulid- AND tag == :tag- |]- [ ":task_ulid" := task.ulid- , ":tag" := tag- ]-- pure $ getResultMsg ("💥 Removed tag \"" <> pretty tag <> "\"") task-- pure $ vsep docs---addNote :: Config -> Connection -> Text -> [IdText] -> IO (Doc AnsiStyle)-addNote conf connection noteBody ids = do- docs <- forM ids $ \idSubstr ->- execWithTask conf connection idSubstr $ \task -> do- now <- timeCurrentP <&> (timePrint conf.utcFormat >>> pack)- ulid <- formatUlid getULID-- insertRecord- "task_to_note"- connection- TaskToNote- { ulid- , task_ulid = task.ulid- , TaskToNote.note = noteBody- }-- -- TODO: Check if modified_utc could be set via SQL trigger- executeNamed- connection- [sql|- UPDATE tasks- SET modified_utc = :now- WHERE ulid == :ulid- |]- [ ":now" := now- , ":ulid" := task.ulid- ]-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- pure $- "🗒 Added a note to task"- <+> prettyBody- <+> "with id"- <+> prettyId-- pure $ vsep docs---deleteNote :: Config -> Connection -> IdText -> IO (Doc AnsiStyle)-deleteNote _conf connection noteId = do- taskIds :: [Only Text] <-- queryNamed- connection- [sql|- DELETE FROM task_to_note- WHERE ulid == :noteId- RETURNING task_ulid- |]- [":noteId" := noteId]-- case taskIds of- [Only taskId] ->- pure $- "💥 Deleted note"- <+> dquotes (pretty noteId)- <+> "of task"- <+> dquotes (pretty taskId)- [] ->- pure $- annotate (color Yellow) $- "⚠️ Note" <+> dquotes (pretty noteId) <+> "does not exist"- _ ->- pure $- annotate (color Yellow) $- ("⚠️ Note" <+> dquotes (pretty noteId) <+> "exists multiple times.")- <++> "This indicates a serious database inconsistency \- \and you should clean up the database manually \- \before continuing."---setDueUtc :: Config -> Connection -> DateTime -> [IdText] -> IO (Doc AnsiStyle)-setDueUtc conf connection datetime ids = do- let- utcText :: Text- utcText = pack $ timePrint conf.utcFormat datetime-- docs <- forM ids $ \idSubstr ->- execWithTask conf connection idSubstr $ \task -> do- updateTask connection task{Task.due_utc = Just utcText}-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- pure $- "📅 Set due UTC of task"- <+> prettyBody- <+> "with id"- <+> prettyId- <+> "to"- <+> dquotes (pretty utcText)-- pure $ vsep docs---getResultMsg :: Doc AnsiStyle -> Task -> Doc AnsiStyle-getResultMsg msg task = do- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- msg <+> "of task" <+> prettyBody <+> "with id" <+> prettyId---uncloseTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-uncloseTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET closed_utc = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed close timestamp and state field" task-- pure $ vsep docs---undueTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-undueTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET due_utc = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed due timestamp" task-- pure $ vsep docs---unwaitTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unwaitTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET waiting_utc = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed waiting and review timestamps" task-- pure $ vsep docs---unwakeTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unwakeTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET awake_utc = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed awake timestamp" task-- pure $ vsep docs---unreadyTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unreadyTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET ready_utc = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed ready timestamp" task-- pure $ vsep docs---unreviewTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unreviewTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET review_utc = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed review timestamp" task-- pure $ vsep docs---unrepeatTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unrepeatTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET repetition_duration = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed repetition duration" task-- pure $ vsep docs---unrecurTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unrecurTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET recurrence_duration = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed recurrence duration" task-- pure $ vsep docs---untagTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-untagTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- DELETE FROM task_to_tag- WHERE task_ulid == :task_ulid- |]- [":task_ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed all tags" task-- pure $ vsep docs---unnoteTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unnoteTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- DELETE FROM task_to_note- WHERE task_ulid == :task_ulid- |]- [":task_ulid" := task.ulid]-- pure $ getResultMsg "💥 Deleted all notes" task-- pure $ vsep docs---unprioTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unprioTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET priority_adjustment = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed priority adjustment" task-- pure $ vsep docs---unmetaTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-unmetaTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- executeNamed- connection- [sql|- UPDATE tasks- SET metadata = NULL- WHERE ulid == :ulid- |]- [":ulid" := task.ulid]-- pure $ getResultMsg "💥 Removed metadata" task-- pure $ vsep docs---duplicateTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)-duplicateTasks conf connection ids = do- docs <- forM ids $ \idSubstr -> do- execWithTask conf connection idSubstr $ \task -> do- dupeUlid <- formatUlid getULID- -- TODO: Check if modified_utc can be set via an SQL trigger- modified_utc <- formatElapsedP conf timeCurrentP-- let dupeTask =- task- { Task.ulid = dupeUlid- , Task.due_utc = Nothing- , Task.awake_utc = Nothing- , Task.closed_utc = Nothing- , Task.modified_utc = modified_utc- , Task.state = Nothing- }-- insertRecord "tasks" connection dupeTask-- tags <-- query- connection- [sql|- SELECT tag- FROM task_to_tag- WHERE task_ulid == ?- |]- (Only task.ulid)-- warnings <- liftIO $ insertTags connection Nothing dupeTask (tags & P.concat)-- notes <-- query- connection- [sql|- SELECT *- FROM task_to_note- WHERE task_ulid == ?- |]- (Only task.ulid)-- let- noteTuples =- notes <&> \theNote ->- ( ulidTextToDateTime (TaskToNote.ulid theNote)- , TaskToNote.note theNote- )-- liftIO $- insertNoteTuples- connection- dupeTask- noteTuples-- numOfChanges <- changes connection-- let- prettyBody = dquotes $ pretty task.body- prettyId = dquotes $ pretty task.ulid-- pure $- warnings- <$$> if numOfChanges == 0- then- "⚠️ Task"- <+> prettyBody- <+> "with id"- <+> prettyId- <+> "could not be duplicated"- else- "👯 Created a duplicate of task"- <+> prettyBody- <+> "(id:"- <+> pretty task.ulid- <+> ")"- <+> "with id"- <+> pretty dupeUlid-- pure $ vsep docs---showAtPrecision :: Int -> Double -> Text-showAtPrecision numOfDigits number =- let- tuple = breakOn "." (show number)- clipDecimalPart =- if snd tuple == ".0"- then T.replace ".0" (T.replicate (1 + numOfDigits) " ")- else T.take (1 + numOfDigits)- in- fst tuple- <> if numOfDigits /= 0- then (clipDecimalPart . snd) tuple- else ""---formatTag :: (Pretty a) => Config -> a -> Doc AnsiStyle-formatTag conf =- annotate (tagStyle conf)- . (annotate (color Black) "+" <>)- . pretty---formatTaskLine :: Config -> DateTime -> Int -> FullTask -> Doc AnsiStyle-formatTaskLine conf now taskWidth task =- let- id = pretty $ T.takeEnd taskWidth task.ulid- createdUtc =- fmap- (pack . timePrint ISO8601_Date)- (ulidTextToDateTime task.ulid)- tags = fromMaybe [] task.tags- closedUtcMaybe =- task.closed_utc- >>= parseUtc- <&> timePrint conf.utcFormat- dueUtcMaybe =- task.due_utc- >>= parseUtc- <&> T.replace " 00:00:00" ""- . T.pack- . timePrint conf.utcFormat- dueIn offset =- let dateMaybe = task.due_utc >>= parseUtc- in isJust dateMaybe && dateMaybe < Just (now `timeAdd` offset)- multilineIndent = 2- hangWidth =- taskWidth- + 2- + dateWidth conf- + 2- + prioWidth conf- + 2- + multilineIndent- hhsep = concatWith (<++>)- isEmptyDoc doc = show doc /= ("" :: Text)- isOpen = isNothing task.closed_utc- grayOutIfDone doc =- if isOpen- then annotate (bodyStyle conf) doc- else annotate (bodyClosedStyle conf) doc- -- redOut onTime doc = if onTime- -- then annotate (bodyStyle conf) doc- -- else annotate (color Red) doc- taskLine =- createdUtc <&> \taskDate ->- hang hangWidth $- hhsep $- P.filter- isEmptyDoc- [ annotate conf.idStyle id- , annotate- (priorityStyle conf)- ( pretty $- justifyRight 4 ' ' $- showAtPrecision 1 $- realToFrac $- fromMaybe 0 task.priority- )- , annotate (dateStyle conf) (pretty taskDate)- , pretty- ( case task.review_utc >>= parseUtc of- Nothing -> "" :: Text- Just date_ -> if date_ < now then "🔎 " else ""- )- <> ( if dueIn mempty{durationHours = 24} && isOpen- then "⚠️️ "- else ""- )- <> ( if dueIn mempty && isOpen- then annotate (color Red) (reflow task.body)- else grayOutIfDone (reflow task.body)- )- , annotate (dueStyle conf) (pretty dueUtcMaybe)- , annotate (closedStyle conf) (pretty closedUtcMaybe)- , hsep (tags <&> formatTag conf)- , if not $ P.null task.notes- then "📝"- else ""- ]- in- fromMaybe- ( "Id"- <+> dquotes (pretty task.ulid)- <+> "is an invalid ulid and could not be converted to a datetime"- )- taskLine---getIdLength :: Float -> Int-getIdLength numOfItems =- -- TODO: Calculate idLength by total number of tasks, not just of the viewed- let- targetCollisionChance = 0.01 -- Targeted likelihood of id collisions- sizeOfAlphabet = 32 -- Crockford's base 32 alphabet- in- ceiling (logBase sizeOfAlphabet (numOfItems / targetCollisionChance)) + 1---countTasks :: Config -> Connection -> Maybe [Text] -> IO (Doc AnsiStyle)-countTasks conf connection filterExpression = do- let- parserResults =- readP_to_S filterExpsParser $- T.unpack (unwords $ fromMaybe [""] filterExpression)- filterMay = listToMaybe parserResults-- case filterMay of- Nothing -> do- [NumRows taskCount] <-- query_ connection $- Query $- "SELECT count(1) FROM " <> quoteKeyword conf.tableName-- pure $ pretty taskCount- Just (filterExps, _) -> do- let- ppInvalidFilter = \case- (InvalidFilter error) ->- dquotes (pretty error) <+> "is an invalid filter"- (HasStatus Nothing) -> "Filter contains an invalid state value"- _ -> "The functions should not be called with a valid function"- errors = P.filter (not . isValidFilter) filterExps- errorsDoc =- if P.length errors > 0- then- Just $- vsep (fmap (annotate (color Red) . ppInvalidFilter) errors)- <> hardline- <> hardline- else Nothing-- tasks <- query_ connection (getFilterQuery filterExps Nothing)- pure $ errorsDoc & fromMaybe (pretty $ P.length (tasks :: [FullTask]))----- TODO: Print number of remaining tasks and how to display them at the bottom-headTasks :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-headTasks conf now connection = do- tasks <-- query- connection- -- TODO: Add `wait_utc` < datetime('now')"- [sql|- SELECT *- FROM tasks_view- WHERE closed_utc IS NULL- ORDER BY- priority DESC,- due_utc ASC,- ulid DESC- LIMIT ?- |]- (Only $ headCount conf)-- formatTasksColor conf now tasks---newTasks- :: Config- -> DateTime- -> Connection- -> Maybe [Text]- -> IO (Doc AnsiStyle)-newTasks conf now connection filterExp = do- let- parserResults =- readP_to_S filterExpsParser $- T.unpack (unwords $ fromMaybe [""] filterExp)- filterMay = listToMaybe parserResults-- case filterMay of- Nothing -> do- tasks <-- query- connection- [sql|- SELECT *- FROM tasks_view- ORDER BY ulid DESC- LIMIT ?- |]- (Only $ headCount conf)-- formatTasksColor conf now tasks- --- Just (filterExps, _) -> do- let- ppInvalidFilter = \case- (InvalidFilter error) ->- dquotes (pretty error) <+> "is an invalid filter"- (HasStatus Nothing) -> "Filter contains an invalid state value"- _ -> "The functions should not be called with a valid function"- errors = P.filter (not . isValidFilter) filterExps-- if P.length errors > 0- then- pure $- vsep (fmap (annotate (color Red) . ppInvalidFilter) errors)- <> hardline- <> hardline- else do- tasks <-- query_- connection- (getFilterQuery filterExps (Just "ulid DESC"))- formatTasksColor conf now tasks---listOldTasks :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-listOldTasks conf now connection = do- tasks <-- query- connection- [sql|- SELECT *- FROM tasks_view- WHERE closed_utc IS NULL- ORDER BY ulid ASC- LIMIT ?- |]- (Only $ headCount conf)-- formatTasksColor conf now tasks---openTasks :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-openTasks conf now connection = do- tasks <-- query_- connection- [sql|- SELECT *- FROM tasks_view- WHERE closed_utc IS NULL- ORDER BY priority DESC, due_utc ASC, ulid DESC- |]- formatTasksColor conf now tasks---modifiedTasks- :: Config- -> DateTime- -> Connection- -> ListModifiedFlag- -> IO (Doc AnsiStyle)-modifiedTasks conf now connection listModifiedFlag = do- tasks <-- query_- connection- [sql|- SELECT *- FROM tasks_view- ORDER BY modified_utc DESC- |]-- let- filterModified =- P.filter- ( \task ->- removeNSec (ulidTextToDateTime task.ulid)- /= parseUtc task.modified_utc- )-- removeNSec :: Maybe DateTime -> Maybe DateTime- removeNSec mDateTime =- case mDateTime of- Just dateTime ->- Just $- dateTime{dtTime = (dtTime dateTime){todNSec = 0}}- Nothing -> Nothing-- filteredTasks =- case listModifiedFlag of- AllItems -> tasks- ModifiedItemsOnly -> filterModified tasks-- formatTasksColor conf now filteredTasks---overdueTasks :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-overdueTasks conf now connection = do- tasks <-- query_- connection- [sql|- SELECT *- FROM tasks_view- WHERE- closed_utc IS NULL AND- due_utc < datetime('now')- ORDER BY- priority DESC,- due_utc ASC,- ulid DESC- |]-- formatTasksColor conf now tasks---doneTasks :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-doneTasks conf now connection = do- tasks <-- query- connection- [sql|- SELECT *- FROM tasks_view- WHERE- closed_utc IS NOT NULL AND- state == 'Done'- ORDER BY closed_utc DESC- LIMIT ?- |]- (Only $ headCount conf)-- formatTasksColor conf now tasks---obsoleteTasks :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-obsoleteTasks conf now connection = do- tasks <-- query- connection- [sql|- SELECT *- FROM tasks_view- WHERE- closed_utc IS NOT NULL AND- state == 'Obsolete'- ORDER BY ulid DESC- LIMIT ?- |]- (Only $ headCount conf)-- formatTasksColor conf now tasks---deletableTasks :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-deletableTasks conf now connection = do- tasks <-- query- connection- [sql|- SELECT *- FROM tasks_view- WHERE- closed_utc IS NOT NULL- AND state == 'Deletable'- ORDER BY ulid DESC- LIMIT ?- |]- (Only $ headCount conf)- formatTasksColor conf now tasks---listRepeating :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-listRepeating conf now connection = do- tasks <-- query_- connection- [sql|- SELECT *- FROM tasks_view- WHERE repetition_duration IS NOT NULL- ORDER BY repetition_duration DESC- |]-- formatTasksColor conf now tasks---listRecurring :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-listRecurring conf now connection = do- tasks <-- query_- connection- [sql|- SELECT *- FROM tasks_view- WHERE recurrence_duration IS NOT NULL- ORDER BY recurrence_duration DESC- |]-- formatTasksColor conf now tasks---listReady :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-listReady conf now connection = do- tasks <-- query- connection- [sql|- SELECT *- FROM tasks_view- WHERE- (ready_utc IS NULL OR- (ready_utc IS NOT NULL AND ready_utc < datetime('now'))- ) AND- closed_utc IS NULL- ORDER BY- priority DESC,- due_utc ASC,- ulid DESC- LIMIT ?- |]- (Only $ headCount conf)-- formatTasksColor conf now tasks---listWaiting :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-listWaiting conf now connection = do- tasks <-- query_- connection- [sql|- SELECT *- FROM tasks_view- WHERE closed_utc IS NULL- AND waiting_utc IS NOT NULL- AND (review_utc > datetime('now') OR review_utc IS NULL)- ORDER BY waiting_utc DESC- |]-- formatTasksColor conf now tasks---listAll :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-listAll conf now connection = do- tasks <-- query_- connection- [sql|- SELECT *- FROM tasks_view- ORDER BY ulid ASC- |]-- formatTasksColor conf now tasks---listNoTag :: Config -> DateTime -> Connection -> IO (Doc AnsiStyle)-listNoTag conf now connection = do- tasks <-- query_- connection- [sql|- SELECT *- FROM tasks_view- WHERE- closed_utc IS NULL AND- tags IS NULL- ORDER BY- priority DESC,- due_utc ASC,- ulid DESC- |]-- formatTasksColor conf now tasks---getWithTag :: Connection -> Maybe DerivedState -> [Text] -> IO [FullTask]-getWithTag connection stateMaybe tags = do- let- tagQuery = case tags of- [] -> ""- _ ->- tags- <&> (\t -> "tag LIKE '" <> t <> "'")- & T.intercalate " OR "- & ("AND " <>)-- stateQuery = case stateMaybe of- Nothing -> ""- Just derivedState -> "AND " <> derivedStateToQuery derivedState-- -- `WHERE TRUE` simplifies adding additional filters with "AND"- ulidsQuery =- "\- \SELECT tasks.ulid \n\- \FROM tasks \n\- \LEFT JOIN task_to_tag ON tasks.ulid IS task_to_tag.task_ulid \n\- \WHERE TRUE \n\- \"- <> tagQuery- <> " \- \"- <> stateQuery- <> " \- \GROUP BY tasks.ulid \- \HAVING count(tag) = "- <> show (P.length tags)-- mainQuery =- FullTask.selectQuery- <> "\- \FROM ("- <> Query ulidsQuery- <> ") tasks1\n\- \LEFT JOIN tasks_view ON tasks1.ulid IS tasks_view.ulid\n\- \ORDER BY \n\- \ priority DESC,\n\- \ due_utc ASC,\n\- \ ulid DESC\n"-- query_ connection mainQuery---listWithTag :: Config -> DateTime -> Connection -> [Text] -> IO (Doc AnsiStyle)-listWithTag conf now connection tags = do- tasks <- getWithTag connection Nothing tags- formatTasksColor conf now tasks---queryTasks :: Config -> DateTime -> Connection -> Text -> IO (Doc AnsiStyle)-queryTasks conf now connection sqlQuery = do- tasks <-- query_ connection $- Query $- "SELECT * FROM tasks_view WHERE " <> sqlQuery- formatTasksColor conf now tasks---runSql :: Config -> Text -> IO (Doc AnsiStyle)-runSql conf sqlQuery = do- result <-- readProcess- "sqlite3"- [ conf.dataDir </> conf.dbName- , ".headers on"- , ".mode csv"- , ".separator , '\n'"- , T.unpack sqlQuery- ]- []- -- Remove trailing newline- pure $ pretty (T.dropEnd 1 $ T.pack result)---data FilterExp- = HasTag Text- | NotTag Text- | HasDue Text- | HasStatus (Maybe DerivedState) -- Should be `Either`- | InvalidFilter Text- deriving (Show)---tagParser :: ReadP FilterExp-tagParser = do- _ <- char '+'- aTag <- munch (not . isSpace)- pure $ HasTag $ pack aTag---notTagParser :: ReadP FilterExp-notTagParser = do- _ <- char '-'- aTag <- munch (not . isSpace)- pure $ NotTag $ pack aTag---dueParser :: ReadP FilterExp-dueParser = do- _ <- string "due:"- utcStr <- munch (not . isSpace)- pure $ HasDue $ pack utcStr---stateParser :: ReadP FilterExp-stateParser = do- _ <- string "state:"- stateStr <- munch (not . isSpace)- pure $ HasStatus $ textToDerivedState $ pack stateStr---filterExpParser :: ReadP FilterExp-filterExpParser =- do- tagParser- <++ notTagParser- <++ dueParser- <++ stateParser- <++ (InvalidFilter . pack <$> munch1 (not . isSpace))---filterExpsParser :: ReadP [FilterExp]-filterExpsParser = do- val <- sepBy1 filterExpParser skipSpaces- eof- return val---parseFilterExps :: Text -> IO ()-parseFilterExps input =- P.print $ readP_to_S filterExpsParser $ T.unpack input---{-| Returns (operator, where-query) tuple- TODO: Should be `FilterExp -> Maybe (Text, Text)`--}-filterToSql :: FilterExp -> (Text, Text)-filterToSql = \case- HasTag tag -> ("INTERSECT", "tag LIKE " <> quoteText tag)- NotTag tag -> ("EXCEPT", "tag LIKE " <> quoteText tag)- HasDue utc -> ("INTERSECT", "due_utc < datetime(" <> quoteText utc <> ")")- HasStatus (Just taskState) -> ("INTERSECT", derivedStateToQuery taskState)- -- Following cases should never be called, as they are filtered out- HasStatus Nothing -> ("", "")- InvalidFilter _ -> ("", "")---isValidFilter :: FilterExp -> Bool-isValidFilter = \case- InvalidFilter _ -> False- HasStatus Nothing -> False- _ -> True---runFilter :: Config -> DateTime -> Connection -> [Text] -> IO (Doc AnsiStyle)-runFilter conf now connection exps = do- let- parserResults = readP_to_S filterExpsParser $ T.unpack $ unwords exps- filterHelp =- "Filter expressions must be a list of key[:value] entries."- <> hardline- dieWithError err = do- hPutDoc stderr $ annotate (color Red) err- exitFailure-- case parserResults of- [(filterExps, _)] -> do- let- ppInvalidFilter = \case- (InvalidFilter error) ->- dquotes (pretty error)- <+> "is an invalid filter."- <> hardline- <> filterHelp- (HasStatus Nothing) ->- "Filter contains an invalid state value"- _ ->- "The functions should not be called with a valid function"- errors = P.filter (not . isValidFilter) filterExps- isStateExp = \case (HasStatus _) -> True; _ -> False- updatedFilterExps =- if P.any isStateExp filterExps- then filterExps- else HasStatus (Just IsOpen) : filterExps- sqlQuery = getFilterQuery updatedFilterExps Nothing-- tasks <- query_ connection sqlQuery-- if P.length errors > 0- then dieWithError $ vsep (fmap ppInvalidFilter errors)- else formatTasksColor conf now tasks- _ -> dieWithError filterHelp----- TODO: Increase performance of this query-getFilterQuery :: [FilterExp] -> Maybe Text -> Query-getFilterQuery filterExps orderByMb = do- let- filterTuple =- filterToSql <$> P.filter isValidFilter filterExps-- queries =- filterTuple <&> \(operator, whereQuery) ->- operator- <> "\n\- \SELECT tasks.ulid\n\- \FROM tasks\n\- \LEFT JOIN task_to_tag ON tasks.ulid IS task_to_tag.task_ulid\n\- \WHERE "- <> whereQuery- <> "\n\- \GROUP BY tasks.ulid"-- ulidsQuery =- "SELECT tasks.ulid FROM tasks\n"- <> unlines queries-- orderBy = Query $ case orderByMb of- Nothing ->- "ORDER BY \n\- \ priority DESC,\n\- \ due_utc ASC,\n\- \ ulid DESC\n"- Just orderByTxt ->- "ORDER BY \n" <> orderByTxt-- FullTask.selectQuery- <> "FROM ("- <> Query ulidsQuery- <> ") tasks1\n\- \LEFT JOIN tasks_view ON tasks1.ulid IS tasks_view.ulid\n"- <> orderBy---formatTasks :: Config -> DateTime -> [FullTask] -> Doc AnsiStyle-formatTasks conf now tasks =- if P.length tasks == 0- then pretty noTasksWarning- else- let- strong = bold <> underlined- taskWidth = getIdLength $ fromIntegral $ P.length tasks- docHeader =- annotate- (idStyle conf <> strong)- (fill taskWidth "Id")- <++> annotate- (priorityStyle conf <> strong)- (fill (prioWidth conf) "Prio")- <++> annotate- (dateStyle conf <> strong)- (fill (dateWidth conf) "Opened UTC")- <++> annotate- (bodyStyle conf <> strong)- (fill (bodyWidth conf) "Body")- <++> line- in- docHeader- <> vsep (fmap (formatTaskLine conf now taskWidth) tasks)- <> line---formatTasksColor :: Config -> DateTime -> [FullTask] -> IO (Doc AnsiStyle)-formatTasksColor conf now tasks = do- confNorm <- applyColorMode conf- pure $ formatTasks confNorm now tasks---getProgressBar :: Integer -> Double -> Doc AnsiStyle-getProgressBar maxWidthInChars progress =- let- barWidth = floor (progress * fromInteger maxWidthInChars)- remainingWidth = fromIntegral $ maxWidthInChars - barWidth- in- annotate- (bgColorDull Green <> colorDull Green)- (pretty $ P.take (fromIntegral barWidth) $ P.repeat '#')- <>- -- (annotate (bgColorDull Green) $ fill (fromIntegral barWidth) "" <>- annotate (bgColorDull Black) (fill remainingWidth "")---formatTagLine- :: Config -> Int -> (Text, Integer, Integer, Double) -> Doc AnsiStyle-formatTagLine conf maxTagLength (tag, open_count, closed_count, progress) =- let- barWidth = toInteger $ progressBarWidth conf- progressPercentage =- if progress == 0- then " "- else- pretty- ( justifyRight 3 ' ' $- T.pack $- showFFloat (Just 0) (progress * 100) ""- )- <+> "%"- in- fill maxTagLength (pretty tag)- <++> pretty (justifyRight (T.length "open") ' ' $ show open_count)- <++> pretty (justifyRight (T.length "closed") ' ' $ show closed_count)- <++> progressPercentage- <+> getProgressBar barWidth progress---formatTags :: Config -> [(Text, Integer, Integer, Double)] -> Doc AnsiStyle-formatTags conf tagTuples =- let- percWidth = 6 -- Width of e.g. 100 %- progressWith = conf.progressBarWidth + percWidth- firstOf4 (a, _, _, _) = a- maxTagLength =- tagTuples- <&> (T.length . firstOf4)- & P.maximum- in- annotate (bold <> underlined) (fill maxTagLength "Tag")- <++> annotate (bold <> underlined) "Open"- <++> annotate (bold <> underlined) "Closed"- <++> annotate (bold <> underlined) (fill progressWith "Progress")- <> line- <> vsep (fmap (formatTagLine conf maxTagLength) tagTuples)---listTags :: Config -> Connection -> IO (Doc AnsiStyle)-listTags conf connection = do- tags <- query_ connection $ Query "SELECT * FROM tags"-- pure $ formatTags conf tags---listProjects :: Config -> Connection -> IO (Doc AnsiStyle)-listProjects conf connection = do- tags <-- query_ connection $- [sql|- SELECT *- FROM tags- WHERE- "open" > 0 AND- closed > 0- |]-- pure $ formatTags conf tags---getStats :: Config -> Connection -> IO (Doc AnsiStyle)-getStats _ connection = do- [NumRows numOfTasksTotal] <-- query_ connection $- Query "SELECT count(1) FROM tasks"- [NumRows numOfTasksOpen] <-- query_ connection $- Query "SELECT count(1) FROM tasks WHERE closed_utc IS NULL"- [NumRows numOfTasksClosed] <-- query_ connection $- Query "SELECT count(1) FROM tasks WHERE closed_utc IS NOT NULL"- [NumRows numOfTasksDone] <-- query_ connection $- Query "SELECT count(1) FROM tasks WHERE state IS 'Done'"- [NumRows numOfTasksObsolete] <-- query_ connection $- Query "SELECT count(1) FROM tasks WHERE state IS 'Obsolete'"- [NumRows numOfTasksDeletable] <-- query_ connection $- Query "SELECT count(1) FROM tasks WHERE state IS 'Deletable'"-- let- widthKey = 12- widthValue = max 5 $ fromIntegral $ numDigits 10 numOfTasksTotal- formatLine (name :: Text) (numTasks :: Integer) =- let- numTotalInt :: Double = fromIntegral numOfTasksTotal- numTasksInt :: Double = fromIntegral numTasks- share = T.pack $ showFFloat (Just 3) (numTasksInt / numTotalInt) ""- in- fill widthKey (pretty name)- <++> fill- widthValue- (pretty $ justifyRight widthValue ' ' $ show numTasks)+import Protolude (+ Applicative (liftA2, pure),+ Bool (..),+ Char,+ Double,+ Down (Down),+ Either (Left, Right),+ Eq (..),+ FilePath,+ Float,+ Floating (logBase),+ Fractional ((/)),+ Functor (fmap),+ IO,+ Int,+ Int64,+ Integer,+ Integral (toInteger),+ Maybe (..),+ Monad (return, (>>=)),+ MonadIO (liftIO),+ Monoid (mempty),+ Num (abs, fromInteger, (*), (+), (-)),+ Ord (compare, max, (<), (>)),+ Read,+ RealFrac (ceiling, floor),+ Semigroup ((<>)),+ Show,+ Text,+ catMaybes,+ const,+ decodeUtf8,+ either,+ encodeUtf8,+ exitFailure,+ forM,+ forM_,+ fromIntegral,+ fromMaybe,+ fst,+ getArgs,+ identity,+ isJust,+ isNothing,+ isSpace,+ listToMaybe,+ maybe,+ maybeToEither,+ not,+ on,+ otherwise,+ realToFrac,+ show,+ snd,+ sortBy,+ sortOn,+ stderr,+ unlines,+ unwords,+ ($),+ ($>),+ (&),+ (&&),+ (.),+ (<$>),+ (<&>),+ (<=),+ (||),+ )+import Protolude qualified as P++import Control.Applicative ((<|>))+import Control.Arrow ((>>>))+import Data.Aeson as Aeson (KeyValue ((.=)), encode, object)+import Data.Coerce (coerce)+import Data.Generics (Data, constrFields, toConstr)+import Data.Hourglass (+ DateTime (dtTime),+ Duration (durationHours, durationMinutes),+ ISO8601_Date (ISO8601_Date),+ Minutes (Minutes),+ Seconds (Seconds),+ Time (timeFromElapsedP),+ TimeOfDay (todNSec),+ timeAdd,+ timeDiff,+ timePrint,+ )+import Data.List (nub)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Encoding qualified as TL+import Data.Time.Clock (UTCTime)+import Data.Time.ISO8601.Duration qualified as Iso+import Data.ULID (ULID, getULID)+import Data.Yaml qualified as Yaml+import Database.SQLite.Simple (+ Connection,+ Error (ErrorConstraint),+ FromRow (..),+ NamedParam ((:=)),+ Only (Only),+ Query (Query),+ SQLData (SQLNull, SQLText),+ SQLError (sqlError),+ ToRow,+ changes,+ execute,+ executeNamed,+ field,+ open,+ query,+ queryNamed,+ query_,+ toRow,+ withConnection,+ )+import Database.SQLite.Simple.QQ (sql)+import Numeric (showFFloat)+import Prettyprinter as Pp (+ Doc,+ Pretty (pretty),+ align,+ annotate,+ concatWith,+ dquotes,+ fill,+ hang,+ hardline,+ hsep,+ indent,+ line,+ punctuate,+ vcat,+ vsep,+ (<+>),+ )+import Prettyprinter.Render.Terminal (+ AnsiStyle,+ Color (Black, Green, Red, Yellow),+ bold,+ color,+ hPutDoc,+ underlined,+ )+import Prettyprinter.Util (reflow)+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import System.Posix.User (getEffectiveUserName)+import System.Process (readProcess)+import Text.Fuzzily qualified as Fuzzily+import Text.ParserCombinators.ReadP (+ ReadP,+ char,+ eof,+ munch,+ munch1,+ readP_to_S,+ sepBy1,+ skipSpaces,+ string,+ (<++),+ )+import Text.Printf (printf)+import Time.System (dateCurrent, timeCurrentP)++import Config (+ Column (..),+ Config (+ bodyClosedStyle,+ bodyStyle,+ bodyWidth,+ closedStyle,+ columns,+ dataDir,+ dateStyle,+ dateWidth,+ dbName,+ dueStyle,+ headCount,+ hooks,+ idStyle,+ prioWidth,+ priorityStyle,+ progressBarWidth,+ tableName,+ tagStyle,+ utcFormat,+ utcFormatShort+ ),+ HookSet (post, pre),+ HooksConfig (add),+ defaultConfig,+ )+import Control.Monad.Catch (catchAll, catchIf)+import FullTask (+ FullTask (+ awake_utc,+ body,+ closed_utc,+ due_utc,+ group_ulid,+ metadata,+ modified_utc,+ notes,+ priority,+ ready_utc,+ recurrence_duration,+ repetition_duration,+ review_utc,+ tags,+ ulid,+ user,+ waiting_utc+ ),+ cpTimesAndState,+ selectQuery,+ )+import Hooks (HookResult (message, task), executeHooks, formatHookResult)+import ImportTask (+ ImportTask (ImportTask, notes, tags, task),+ importTaskToFullTask,+ setMissingFields,+ )+import Note (Note (body, ulid))+import Prettyprinter.Internal.Type (Doc (Empty))+import SqlUtils (quoteKeyword, quoteText)+import Task (+ DerivedState (IsOpen),+ Task,+ TaskState (..),+ derivedStateToQuery,+ emptyTask,+ getStateHierarchy,+ textToDerivedState,+ )+import Task qualified+import TaskToNote (TaskToNote (..))+import TaskToTag (TaskToTag (..))+import Utils (+ IdText,+ ListModifiedFlag (..),+ applyColorMode,+ bgColrDull,+ colr,+ colrDull,+ countChar,+ dateTimeToUtcTime,+ formatElapsedP,+ numDigits,+ parseUlidText,+ parseUtc,+ setDateTime,+ ulidTextToDateTime,+ utcFormatReadable,+ utcTimeToDateTime,+ vsepCollapse,+ (<$$>),+ (<++>),+ )+++noTasksWarning :: Text+noTasksWarning =+ "No tasks available. "+ <> "Run `tasklite help` to learn how to create tasks."+++newtype NumRows = NumRows Integer+ deriving (Eq, Ord, Read, Show)+++instance FromRow NumRows where+ fromRow = NumRows <$> field+++getDbPath :: Config -> IO FilePath+getDbPath conf = do+ pure $ conf.dataDir </> conf.dbName+++setupConnection :: Config -> IO Connection+setupConnection conf = do+ createDirectoryIfMissing True $ dataDir conf+ open $ conf.dataDir </> conf.dbName+++execWithConn :: Config -> (Connection -> IO a) -> IO a+execWithConn conf func = do+ createDirectoryIfMissing True $ dataDir conf+ withConnection+ (conf.dataDir </> conf.dbName)+ func+++-- | Get fields names of record (empty list if not record constructor)+getRecordFields :: (Data object) => object -> [Text]+getRecordFields =+ toConstr >>> constrFields >>> fmap T.pack+++insertRecord :: (ToRow r, Data r) => Text -> Connection -> r -> IO ()+insertRecord tableName connection record = do+ let recordFields = record & getRecordFields+ execute+ connection+ ( Query $+ "INSERT INTO "+ <> tableName+ <> "("+ <> (recordFields & T.intercalate ",\n")+ <> ") VALUES ("+ <> ((recordFields $> "?") & T.intercalate ",\n")+ <> ")"+ )+ (toRow record)+++getUpdateAssignments :: Task -> Text+getUpdateAssignments task =+ task+ & getRecordFields+ <&> (<> " = ?")+ & T.intercalate ", "+++updateTask :: Connection -> Task -> IO ()+updateTask connection task = do+ execute+ connection+ ( Query $+ " UPDATE tasks SET "+ <> getUpdateAssignments task+ <> " WHERE ulid == ?"+ )+ (toRow task <> [SQLText task.ulid])+++handleTagDupError :: Config -> Text -> (Applicative f) => e -> f (Doc AnsiStyle)+handleTagDupError conf tag _exception =+ pure $+ annotate (colr conf Yellow) $+ "⚠️ Tag " <> dquotes (pretty tag) <> " is already assigned"+++insertTags ::+ Config -> Connection -> Maybe DateTime -> Task -> [Text] -> IO (Doc AnsiStyle)+insertTags conf connection mbCreatedUtc task tags = do+ let uniqueTags = nub tags+ taskToTags <- forM uniqueTags $ \tag -> do+ newUlid <- getULID+ pure $+ TaskToTag+ { ulid =+ mbCreatedUtc+ <&> setDateTime newUlid+ & fromMaybe newUlid+ & show+ & T.toLower+ , task_ulid = task.ulid+ , tag = tag+ }++ -- TODO: Insert all tags at once+ insertWarnings <- P.forM taskToTags $ \taskToTag ->+ catchIf+ -- TODO: Find out why it's not `ErrorConstraintUnique`+ (\(err :: SQLError) -> err.sqlError == ErrorConstraint)+ (insertRecord "task_to_tag" connection taskToTag P.>> pure "")+ (handleTagDupError conf taskToTag.tag)++ pure $ vsepCollapse insertWarnings+++insertNotes ::+ Config ->+ Connection ->+ Maybe DateTime ->+ Task ->+ [Note] ->+ IO (Doc AnsiStyle)+insertNotes conf connection mbCreatedUtc task notes = do+ let uniqueNotes = nub notes+ taskToNotes <- forM uniqueNotes $ \theNote -> do+ newUlid <- getULID+ pure $+ TaskToNote+ { ulid =+ theNote.ulid+ & parseUlidText+ & fromMaybe newUlid+ & case mbCreatedUtc of+ Nothing -> P.identity+ Just createdUtc -> P.flip setDateTime createdUtc+ & show @ULID+ & T.toLower+ , task_ulid = task.ulid+ , note = theNote.body+ }++ insertWarnings <- P.forM taskToNotes $ \taskToNote ->+ catchAll+ (insertRecord "task_to_note" connection taskToNote P.>> pure "")+ ( \exception ->+ pure $+ annotate (colr conf Yellow) $+ "⚠️ Note "+ <> dquotes (pretty taskToNote.note)+ <> " could not be inserted"+ <+> "ERROR:"+ <+> pretty (show exception :: Text)+ )++ pure $ vsepCollapse insertWarnings+++-- | Tuple is (Maybe createdUtc, noteBody)+insertNoteTuples :: Connection -> Task -> [(Maybe DateTime, Text)] -> IO ()+insertNoteTuples connection task notes = do+ taskToNotes <- forM notes $ \(mbCreatedUtc, noteBody) -> do+ noteUlid <- getULID+ pure $+ TaskToNote+ { ulid =+ mbCreatedUtc+ <&> setDateTime noteUlid+ & fromMaybe noteUlid+ & show+ & T.toLower+ , task_ulid = task.ulid+ , note = noteBody+ }++ forM_ taskToNotes $ \taskToNote ->+ insertRecord "task_to_note" connection taskToNote+++formatUlid :: IO ULID -> IO Text+formatUlid =+ fmap (T.toLower . show)+++{-| Parses the body of the tasks and extracts all meta data+ | Returns a tuple (body, tags, dueUtcMb, createdUtcMb)+ TODO: Replace with parsec implementation+-}+parseTaskBody :: [Text] -> (Text, [Text], Maybe Text, Maybe DateTime)+parseTaskBody bodyWords =+ let+ isTag = ("+" `T.isPrefixOf`)+ isDueUtc = ("due:" `T.isPrefixOf`)+ isCreatedUtc = ("created:" `T.isPrefixOf`)+ isMeta word = isTag word || isDueUtc word || isCreatedUtc word+ -- Handle case when word is actually a text+ bodyWordsReversed = bodyWords & T.unwords & T.words & P.reverse+ body =+ bodyWordsReversed+ & P.dropWhile isMeta+ & P.reverse+ & unwords+ metadata =+ bodyWordsReversed+ & P.takeWhile isMeta+ & P.reverse+ tags = fmap (T.replace "+" "") (P.filter isTag metadata)+ dueUtcMb =+ metadata+ & P.filter isDueUtc+ <&> T.replace "due:" ""+ & P.lastMay+ >>= parseUtc+ <&> (timePrint utcFormatReadable >>> T.pack)+ createdUtcMb =+ metadata+ & P.filter isCreatedUtc+ <&> T.replace "created:" ""+ & P.lastMay+ >>= parseUtc+ in+ (body, tags, dueUtcMb, createdUtcMb)+++-- | Get (ulid, modified_utc, effectiveUserName) from the environment+getTriple :: Config -> IO (ULID, Text, [Char])+getTriple conf = do+ ulid <- getULID+ -- TODO: Set via a SQL trigger+ modified_utc <- formatElapsedP conf timeCurrentP+ effectiveUserName <- getEffectiveUserName++ pure (ulid, modified_utc, effectiveUserName)+++addEmptyTask :: Config -> Connection -> IO Task+addEmptyTask conf conn = do+ (ulid, modified_utc, effectiveUserName) <- getTriple conf+ let task =+ emptyTask+ { Task.ulid = T.toLower $ show ulid+ , Task.body = ""+ , Task.state = Just Done+ , Task.due_utc = Nothing+ , Task.closed_utc = Just modified_utc+ , Task.user = T.pack effectiveUserName+ , Task.modified_utc = modified_utc+ }++ insertRecord "tasks" conn task+ pure task+++-- TODO: Eliminate code duplications with `editTask`+addTask :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)+addTask conf connection bodyWords = do+ (ulid, modified_utc, effectiveUserName) <- getTriple conf+ let+ (body, tags, dueUtcMb, createdUtcMb) = parseTaskBody bodyWords+ importTaskDraft =+ ImportTask+ { task =+ emptyTask+ { Task.ulid = T.toLower $ show $ case createdUtcMb of+ Nothing -> ulid+ Just createdUtc -> setDateTime ulid createdUtc+ , Task.body = body+ , Task.due_utc = dueUtcMb+ , Task.modified_utc = modified_utc+ , Task.user = T.pack effectiveUserName+ }+ , tags = tags+ , notes = [] -- TODO: Add notes to task+ }++ args <- getArgs+ preAddResults <-+ executeHooks+ ( TL.toStrict $+ TL.decodeUtf8 $+ Aeson.encode $+ object+ [ "arguments" .= args+ , "taskToAdd" .= importTaskToFullTask importTaskDraft+ ]+ )+ conf.hooks.add.pre++ -- Maybe the task was changed by the hook+ (importTask, preAddHookMsg) <- case preAddResults of+ [] -> pure (importTaskDraft, Empty)+ [Left error] -> do+ _ <- exitFailure+ pure (importTaskDraft, pretty error)+ [Right hookResult] -> do+ case hookResult.task of+ Nothing -> pure (importTaskDraft, Empty)+ Just task -> do+ fullImportTask <- setMissingFields task+ 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."+ )++ insertRecord "tasks" connection importTask.task+ warnings <- insertTags conf connection Nothing importTask.task importTask.tags++ -- TODO: Use RETURNING clause in `insertRecord` instead+ (insertedTasks :: [FullTask]) <-+ queryNamed+ connection+ "SELECT * FROM tasks_view WHERE ulid == :ulid"+ [":ulid" := importTask.task.ulid]++ case insertedTasks of+ [insertedTask] -> do+ postAddResults <-+ executeHooks+ ( TL.toStrict $+ TL.decodeUtf8 $+ Aeson.encode $+ object+ [ "arguments" .= args+ , "taskAdded" .= insertedTask+ -- TODO: Add tags and notes to task+ ]+ )+ conf.hooks.add.post++ let+ postAddHookMsg :: Doc AnsiStyle+ postAddHookMsg =+ ( postAddResults+ <&> \case+ Left error -> "ERROR:" <+> pretty error+ Right hookResult -> pretty hookResult.message+ & P.fold+ )+ <> hardline++ pure $+ [ preAddHookMsg+ , warnings+ , "🆕 Added task"+ <+> dquotes (pretty importTask.task.body)+ <+> "with id"+ <+> dquotes (pretty importTask.task.ulid)+ , postAddHookMsg+ ]+ & P.filter (\d -> show d /= T.empty)+ & vsep+ ---+ _ -> pure "Task could not be added"+++logTask :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)+logTask conf connection bodyWords = do+ (ulid, modified_utc, effectiveUserName) <- getTriple conf+ let+ (body, extractedTags, dueUtcMb, createdUtcMb) = parseTaskBody bodyWords+ tags = extractedTags <> ["log"]+ task =+ emptyTask+ { Task.ulid = T.toLower $ show $ case createdUtcMb of+ Nothing -> ulid+ Just createdUtc -> setDateTime ulid createdUtc+ , Task.body = body+ , Task.state = Just Done+ , Task.due_utc = dueUtcMb+ , Task.closed_utc = Just modified_utc+ , Task.user = T.pack effectiveUserName+ , Task.modified_utc = modified_utc+ }++ insertRecord "tasks" connection task+ warnings <- insertTags conf connection Nothing task tags+ pure $+ warnings+ <$$> "📝 Logged task"+ <+> dquotes (pretty task.body)+ <+> "with id"+ <+> dquotes (pretty task.ulid)+++execWithTask ::+ Config ->+ Connection ->+ Text ->+ (Task -> IO (Doc AnsiStyle)) ->+ IO (Doc AnsiStyle)+execWithTask conf connection idSubstr callback = do+ tasks <-+ query+ connection+ ( Query $+ "SELECT *\n"+ <> ("FROM \"" <> conf.tableName <> "\"\n")+ <> "WHERE ulid LIKE ?\n"+ )+ ["%" <> idSubstr :: Text] ::+ IO [Task]++ let+ numOfTasks = P.length tasks+ ulidLength = 26+ prefix = if T.length idSubstr == ulidLength then "" else "…"+ quote = dquotes . pretty++ if+ | numOfTasks == 0 ->+ pure $+ "⚠️ Task" <+> quote (prefix <> idSubstr) <+> "does not exist"+ | numOfTasks == 1 ->+ callback $ fromMaybe emptyTask $ P.head tasks+ | numOfTasks > 1 ->+ pure $+ "⚠️ Id slice"+ <+> quote idSubstr+ <+> "is not unique."+ <+> "It could refer to one of the following tasks:"+ <++> P.foldMap+ ( \task ->+ annotate conf.idStyle (pretty task.ulid)+ <++> pretty task.body+ <> hardline+ )+ tasks+ | otherwise -> pure "This case should not be possible"+++-- | Set state and automatically sets `closed_utc` via an SQL trigger+setClosedWithState :: Connection -> Task -> Maybe TaskState -> IO ()+setClosedWithState connection task theTaskState = do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET+ state = :state,+ review_utc = NULL+ WHERE+ ulid == :ulid AND+ (state IS NULL OR state != :state)+ |]+ [ ":ulid" := task.ulid+ , ":state" := theTaskState+ ]+++setReadyUtc ::+ Config -> Connection -> DateTime -> [IdText] -> IO (Doc AnsiStyle)+setReadyUtc conf connection datetime ids = do+ let utcText = T.pack $ timePrint conf.utcFormat datetime++ docs <- forM ids $ \idSubstr ->+ execWithTask conf connection idSubstr $ \task -> do+ updateTask connection $ task{Task.ready_utc = Just utcText}++ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ pure $+ "📅 Set ready UTC of task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ <+> "to"+ <+> dquotes (pretty utcText)++ pure $ vsep docs+++waitFor ::+ Config -> Connection -> Iso.Duration -> [Text] -> IO (Doc AnsiStyle)+waitFor conf connection duration ids = do+ docs <- forM ids $ \idSubstr ->+ execWithTask conf connection idSubstr $ \task -> do+ now <- timeCurrentP+ let+ nowAsText = (T.pack . timePrint conf.utcFormat) now+ threeDays =+ (T.pack . timePrint conf.utcFormat)+ ( utcTimeToDateTime $+ Iso.addDuration duration $+ dateTimeToUtcTime $+ timeFromElapsedP now+ )++ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET+ waiting_utc = :waiting_utc,+ review_utc = :review_utc+ WHERE+ ulid == :ulid+ |]+ [ ":ulid" := task.ulid+ , ":waiting_utc" := nowAsText+ , ":review_utc" := threeDays+ ]++ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ numOfChanges <- changes connection++ pure $+ if numOfChanges == 0+ then+ "⚠️ An error occurred while moving task"+ <+> prettyBody+ <> "with id"+ <+> prettyId+ <+> "into waiting mode"+ else+ "⏳ Set waiting UTC and review UTC for task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId++ pure $ vsep docs+++waitTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)+waitTasks conf connection =+ waitFor conf connection $+ Iso.DurationDate (Iso.DurDateDay (Iso.DurDay 3) Nothing)+++reviewTasksIn ::+ Config ->+ Connection ->+ Iso.Duration ->+ [Text] ->+ IO (Doc AnsiStyle)+reviewTasksIn conf connection duration ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ now <- timeCurrentP+ let+ xDays =+ (T.pack . timePrint conf.utcFormat)+ ( utcTimeToDateTime $+ Iso.addDuration duration $+ dateTimeToUtcTime $+ timeFromElapsedP now+ )+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid+ warningStart = "⚠️ Task" <+> prettyBody <+> "with id" <+> prettyId++ if isJust task.closed_utc+ then pure $ warningStart <+> "is already closed"+ else do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET review_utc = :review_utc+ WHERE ulid == :ulid+ |]+ [ ":ulid" := task.ulid+ , ":review_utc" := xDays+ ]++ numOfChanges <- changes connection++ pure $+ if numOfChanges == 0+ then warningStart <+> "could not be reviewed"+ else getResultMsg task "🔎 Finished review"++ pure $ vsep docs+++showDateTime :: Config -> DateTime -> Text+showDateTime conf =+ T.pack . timePrint conf.utcFormat+++showEither :: Config -> Either a UTCTime -> Maybe Text+showEither conf theEither =+ theEither+ & either (const Nothing) Just+ <&> (utcTimeToDateTime >>> showDateTime conf)+++-- TODO: Eliminate code duplication with createNextRecurrence+createNextRepetition ::+ Config -> Connection -> Task -> IO (Maybe (Doc AnsiStyle))+createNextRepetition conf connection task = do+ newUlidText <- formatUlid getULID+ let+ nowMb =+ ulidTextToDateTime newUlidText++ durTextEither =+ maybeToEither+ "Task has no repetition duration"+ task.repetition_duration++ isoDurEither =+ durTextEither+ <&> encodeUtf8+ >>= Iso.parseDuration++ nextDueMb =+ liftA2+ Iso.addDuration+ isoDurEither+ ( maybeToEither+ "ULID can't be converted to UTC time"+ (nowMb <&> dateTimeToUtcTime)+ )++ newTask =+ task+ { Task.ulid = newUlidText+ , Task.due_utc = nextDueMb & showEither conf+ , Task.closed_utc = Nothing+ , Task.state = Nothing+ , Task.awake_utc =+ liftA2+ Iso.addDuration+ isoDurEither+ ( maybeToEither+ "Task has no awake UTC"+ (task.awake_utc >>= parseUtc <&> dateTimeToUtcTime)+ )+ & showEither conf+ , Task.ready_utc =+ liftA2+ Iso.addDuration+ isoDurEither+ ( maybeToEither+ "Task has no ready UTC"+ (task.ready_utc >>= parseUtc <&> dateTimeToUtcTime)+ )+ & showEither conf+ , Task.modified_utc =+ nowMb+ <&> (timePrint conf.utcFormat >>> T.pack)+ & fromMaybe ""+ , Task.review_utc = Nothing+ }++ insertRecord "tasks" connection newTask++ tags <-+ query+ connection+ [sql|+ SELECT tag+ FROM task_to_tag+ WHERE task_ulid == ?+ |]+ (Only task.ulid)++ warnings <-+ liftIO $ insertTags conf connection Nothing newTask (tags & P.concat)++ liftIO $+ pure $+ Just $+ warnings+ <$$> "➡️ Created next task"+ <+> dquotes (pretty newTask.body)+ <+> "in repetition series"+ <+> dquotes (pretty newTask.group_ulid)+ <+> "with id"+ <+> dquotes (pretty newUlidText)+++-- TODO: Eliminate code duplication with createNextRepetition+createNextRecurrence ::+ Config -> Connection -> Task -> IO (Maybe (Doc AnsiStyle))+createNextRecurrence conf connection task = do+ newUlidText <- formatUlid getULID+ let+ dueUtcMb =+ task.due_utc >>= parseUtc++ durTextEither =+ maybeToEither+ "Task has no recurrence duration"+ task.recurrence_duration++ isoDurEither =+ durTextEither+ <&> encodeUtf8+ >>= Iso.parseDuration++ -- If task has no due UTC, use current UTC as the base for recurrence+ nowMb = ulidTextToDateTime newUlidText+ baseDateMb = dueUtcMb <|> nowMb++ nextDueMb =+ liftA2+ Iso.addDuration+ isoDurEither+ ( maybeToEither+ "Task has no due UTC current time couldn't be determined"+ (baseDateMb <&> dateTimeToUtcTime)+ )++ newTask =+ task+ { Task.ulid = newUlidText+ , Task.due_utc = nextDueMb & showEither conf+ , Task.closed_utc = Nothing+ , Task.state = Nothing+ , Task.awake_utc =+ liftA2+ Iso.addDuration+ isoDurEither+ ( maybeToEither+ "Task has no awake UTC"+ (task.awake_utc >>= parseUtc <&> dateTimeToUtcTime)+ )+ & showEither conf+ , Task.ready_utc =+ liftA2+ Iso.addDuration+ isoDurEither+ ( maybeToEither+ "Task has no ready UTC"+ (task.ready_utc >>= parseUtc <&> dateTimeToUtcTime)+ )+ & showEither conf+ , Task.modified_utc =+ newUlidText+ & ulidTextToDateTime+ <&> (timePrint conf.utcFormat >>> T.pack)+ & fromMaybe ""+ , Task.review_utc = Nothing+ }++ insertRecord "tasks" connection newTask++ tags <-+ query+ connection+ [sql|+ SELECT tag+ FROM task_to_tag+ WHERE task_ulid == ?+ |]+ (Only task.ulid)++ warnings <-+ liftIO $ insertTags conf connection Nothing newTask (tags & P.concat)++ liftIO $+ pure $+ Just $+ warnings+ <$$> "➡️ Created next task"+ <+> dquotes (pretty task.body)+ <+> "in recurrence series"+ <+> dquotes (pretty task.group_ulid)+ <+> "with id"+ <+> dquotes (pretty newUlidText)+++doTasks :: Config -> Connection -> Maybe [Text] -> [Text] -> IO (Doc AnsiStyle)+doTasks conf connection noteWordsMaybe ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ if isJust task.closed_utc+ then+ pure $+ "⚠️ Task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ <+> "is already done"+ else do+ logMessageMaybe <-+ if isJust task.repetition_duration+ then createNextRepetition conf connection task+ else+ if isJust task.recurrence_duration+ then createNextRecurrence conf connection task+ else pure Nothing++ noteMessageMaybe <- case noteWordsMaybe of+ Nothing -> pure Nothing+ Just noteWords ->+ liftIO $+ addNote conf connection (unwords noteWords) ids <&> Just++ setClosedWithState connection task $ Just Done++ pure $+ fromMaybe "" (noteMessageMaybe <&> (<> hardline))+ <> ( "✅ Finished task"+ <+> dquotes (pretty task.body)+ <+> "with id"+ <+> dquotes (pretty task.ulid)+ )+ <> fromMaybe "" (logMessageMaybe <&> (hardline <>))++ pure $ vsep docs+++endTasks :: Config -> Connection -> Maybe [Text] -> [Text] -> IO (Doc AnsiStyle)+endTasks conf connection noteWordsMaybe ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ if isJust task.closed_utc+ then+ pure $+ "⚠️ Task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ <+> "is already marked as obsolete"+ else do+ logMessageMaybe <-+ if isJust task.repetition_duration+ then createNextRepetition conf connection task+ else+ if isJust task.recurrence_duration+ then createNextRecurrence conf connection task+ else pure Nothing++ noteMessageMaybe <- case noteWordsMaybe of+ Nothing -> pure Nothing+ Just noteWords ->+ liftIO $+ addNote conf connection (unwords noteWords) ids <&> Just++ setClosedWithState connection task $ Just Obsolete++ pure $+ fromMaybe "" (noteMessageMaybe <&> (<> hardline))+ <> ( "⏹ Marked task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ <+> "as obsolete"+ )+ <> fromMaybe "" (logMessageMaybe <&> (hardline <>))++ pure $ vsep docs+++trashTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)+trashTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ setClosedWithState connection task $ Just Deletable+ numOfChanges <- changes connection++ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ pure $+ if numOfChanges == 0+ then+ "⚠️ Task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ <+> "is already marked as deletable"+ else+ "🗑 Marked task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ <+> "as deletable"++ pure $ vsep docs+++deleteTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)+deleteTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ execute+ connection+ [sql|+ DELETE FROM tasks+ WHERE ulid == ?+ |]+ (Only task.ulid)++ execute+ connection+ [sql|+ DELETE FROM task_to_tag+ WHERE task_ulid == ?+ |]+ (Only task.ulid)++ execute+ connection+ [sql|+ DELETE FROM task_to_note+ WHERE task_ulid == ?+ |]+ (Only task.ulid)++ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ pure $ "❌ Deleted task" <+> prettyBody <+> "with id" <+> prettyId++ pure $ vsep docs+++durationToIso :: Duration -> Text+durationToIso dur =+ "PT" <> show (coerce (durationMinutes dur) :: Int64) <> "M"+++repeatTasks ::+ Config -> Connection -> Iso.Duration -> [IdText] -> IO (Doc AnsiStyle)+repeatTasks conf connection duration ids = do+ let durationIsoText = decodeUtf8 $ Iso.formatDuration duration++ docs <- forM ids $ \idSubstr ->+ execWithTask conf connection idSubstr $ \task -> do+ groupUlid <- formatUlid getULID++ recDur :: [Only SQLData] <-+ queryNamed+ connection+ [sql|+ UPDATE tasks+ SET+ repetition_duration = :repetition_duration,+ group_ulid = :group_ulid+ WHERE+ ulid == :ulid AND+ recurrence_duration IS NULL+ RETURNING recurrence_duration+ |]+ [ ":repetition_duration" := durationIsoText+ , ":group_ulid" := groupUlid+ , ":ulid" := task.ulid+ ]++ if recDur /= [Only SQLNull]+ then+ pure $+ "⚠️ Task"+ <+> dquotes (pretty task.body)+ <+> "with id"+ <+> dquotes (pretty task.ulid)+ <+> "is already in a recurrence series"+ else do+ -- If repetition is set for already closed task,+ -- next task in series must be created immediately+ creationMb <-+ if isNothing task.closed_utc+ then pure $ Just mempty+ else+ liftIO $+ createNextRepetition conf connection $+ task+ { Task.repetition_duration = Just durationIsoText+ , Task.group_ulid = Just groupUlid+ }++ pure $+ "📅 Set repeat duration of task"+ <+> dquotes (pretty task.body)+ <+> "with id"+ <+> dquotes (pretty task.ulid)+ <+> "to"+ <+> dquotes (pretty durationIsoText)+ <++> ( creationMb+ & fromMaybe+ "⚠️ Next task in repetition series could not be created!"+ )++ pure $ vsep docs+++recurTasks ::+ Config -> Connection -> Iso.Duration -> [IdText] -> IO (Doc AnsiStyle)+recurTasks conf connection duration ids = do+ let durationIsoText = decodeUtf8 $ Iso.formatDuration duration++ docs <- forM ids $ \idSubstr ->+ execWithTask conf connection idSubstr $ \task -> do+ groupUlid <- formatUlid getULID++ repDur :: [Only SQLData] <-+ queryNamed+ connection+ [sql|+ UPDATE tasks+ SET+ recurrence_duration = :recurrence_duration,+ group_ulid = :group_ulid+ WHERE+ ulid == :ulid AND+ repetition_duration IS NULL+ RETURNING repetition_duration+ |]+ [ ":recurrence_duration" := durationIsoText+ , ":group_ulid" := groupUlid+ , ":ulid" := task.ulid+ ]++ if repDur /= [Only SQLNull]+ then+ pure $+ "⚠️ Task"+ <+> dquotes (pretty task.body)+ <+> "with id"+ <+> dquotes (pretty task.ulid)+ <+> "is already in a repetition series"+ else do+ -- If recurrence is set for already closed task,+ -- next task in series must be created immediately+ creationMb <-+ if isNothing task.closed_utc+ then pure $ Just mempty+ else+ liftIO $+ createNextRecurrence conf connection $+ task+ { Task.recurrence_duration = Just durationIsoText+ , Task.group_ulid = Just groupUlid+ }++ pure $+ "📅 Set recurrence duration of task"+ <+> dquotes (pretty task.body)+ <+> "with id"+ <+> dquotes (pretty task.ulid)+ <+> "to"+ <+> dquotes (pretty durationIsoText)+ <++> ( creationMb+ & fromMaybe+ "⚠️ Next task in recurrence series could not be created!"+ )++ pure $ vsep docs+++adjustPriority :: Config -> Float -> [IdText] -> IO (Doc AnsiStyle)+adjustPriority conf adjustment ids = do+ dbPath <- getDbPath conf+ withConnection dbPath $ \connection -> do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET priority_adjustment =+ ifnull(priority_adjustment, 0) + :adjustment+ WHERE ulid == :ulid+ |]+ [ ":adjustment" := adjustment+ , ":ulid" := task.ulid+ ]++ numOfChanges <- changes connection++ let prettyBody = dquotes $ pretty task.body++ pure $+ if numOfChanges == 0+ then+ "⚠️ An error occurred while adjusting the priority of task"+ <+> prettyBody+ else+ (if adjustment > 0 then "⬆️ Increased" else "⬇️ Decreased")+ <+> "priority of task"+ <+> prettyBody+ <+> "with id"+ <+> dquotes (pretty task.ulid)+ <+> "by"+ <+> pretty (abs adjustment)++ pure $ vsep docs+++startTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)+startTasks conf connection ids = do+ logMessage <- addNote conf connection "start" ids++ pure $+ pretty $+ T.replace+ "📝 Added a note to"+ "⏳ Started"+ (show logMessage)+++stopTasks :: Config -> Connection -> [Text] -> IO (Doc AnsiStyle)+stopTasks conf connection ids = do+ logMessages <- addNote conf connection "stop" ids++ pure $+ pretty $+ T.replace+ "📝 Added a note to"+ "⌛️ Stopped"+ (show logMessages)+++formatTaskForInfo ::+ Config ->+ DateTime ->+ (FullTask, [TaskToTag], [TaskToNote]) ->+ Doc AnsiStyle+formatTaskForInfo conf now (taskV, tags, notes) =+ let+ mkGreen = annotate (colr conf Green)+ grayOut = annotate (colrDull conf Black)+ stateHierarchy = getStateHierarchy now $ cpTimesAndState taskV+ mbCreatedUtc =+ fmap+ (T.pack . timePrint (utcFormat defaultConfig))+ (ulidTextToDateTime taskV.ulid)+ tagsPretty =+ tags+ <&> ( \t ->+ annotate conf.tagStyle (pretty t.tag)+ <++> maybe+ mempty+ (grayOut . pretty . T.pack . timePrint conf.utcFormat)+ (ulidTextToDateTime t.ulid)+ <++> grayOut (pretty t.ulid)+ )+ notesPretty =+ notes+ <&> ( \n ->+ maybe+ mempty+ (grayOut . pretty . T.pack . timePrint conf.utcFormat)+ (ulidTextToDateTime n.ulid)+ <++> grayOut (pretty n.ulid)+ <> hardline+ <> indent 2 (pretty n.note)+ <> hardline+ )++ mbAwakeUtc = FullTask.awake_utc taskV+ mbReadyUtc = FullTask.ready_utc taskV+ mbWaitingUtc = FullTask.waiting_utc taskV+ mbReviewUtc = FullTask.review_utc taskV+ mbDueUtc = FullTask.due_utc taskV+ mbClosedUtc = FullTask.closed_utc taskV+ mbModifiedUtc = Just $ FullTask.modified_utc taskV++ printIf :: Doc AnsiStyle -> Maybe Text -> Maybe (Doc AnsiStyle)+ printIf name =+ fmap+ ( \v ->+ name+ <+> annotate conf.dueStyle (pretty v)+ <> hardline+ )+ in+ hardline+ <> annotate bold (pretty taskV.body)+ <> hardline+ <> hardline+ <> ( if P.null tags+ then mempty+ else+ (tags <&> (TaskToTag.tag >>> formatTag conf) & hsep)+ <> hardline+ <> hardline+ )+ <> ( if P.null notes+ then mempty+ else+ ( notes+ <&> ( \n ->+ maybe+ mempty+ ( grayOut+ . pretty+ . T.pack+ . timePrint+ conf.utcFormatShort+ )+ (ulidTextToDateTime n.ulid)+ <++> align (pretty n.note)+ )+ & vsep+ )+ <> hardline+ <> hardline+ )+ <> ( " State:"+ <+> mkGreen (pretty stateHierarchy)+ <> hardline+ )+ <> ( "Priority:"+ <+> annotate+ conf.priorityStyle+ (pretty $ FullTask.priority taskV)+ <> hardline+ )+ <> ( " ULID:"+ <+> grayOut (pretty $ FullTask.ulid taskV)+ <> hardline+ )+ <> hardline+ <> ( [ (printIf "🆕 Created ", mbCreatedUtc)+ , (printIf "☀️ Awake ", mbAwakeUtc)+ , (printIf "📅 Ready ", mbReadyUtc)+ , (printIf "⏳ Waiting ", mbWaitingUtc)+ , (printIf "🔎 Review ", mbReviewUtc)+ , (printIf "📅 Due ", mbDueUtc)+ , (printIf "✅ Done ", mbClosedUtc)+ , (printIf "✏️ Modified ", mbModifiedUtc)+ ]+ & sortBy (compare `on` snd)+ & P.mapMaybe (\tup -> fst tup (snd tup))+ & punctuate (pretty (" ⬇" :: Text))+ & vsep+ )+ <> hardline+ <> maybe+ mempty+ ( \value ->+ "Repetition Duration:"+ <+> mkGreen (pretty value)+ <> hardline+ )+ (FullTask.repetition_duration taskV)+ <> maybe+ mempty+ ( \value ->+ "Recurrence Duration:"+ <+> mkGreen (pretty value)+ <> hardline+ )+ (FullTask.recurrence_duration taskV)+ <> maybe+ mempty+ ( \value ->+ "Group Ulid:"+ <+> grayOut (pretty value)+ <> hardline+ )+ (FullTask.group_ulid taskV)+ <> ( "User:"+ <+> mkGreen (pretty $ FullTask.user taskV)+ <> hardline+ )+ <> hardline+ <> maybe+ mempty+ ( \value ->+ "Metadata:"+ <> hardline+ <> indent 2 (pretty $ decodeUtf8 $ Yaml.encode value)+ <> hardline+ )+ (FullTask.metadata taskV)+ <> ( if P.null tags+ then mempty+ else+ annotate underlined "Tags Detailed:"+ <> hardline+ <> hardline+ <> vsep tagsPretty+ <> hardline+ <> hardline+ )+ <> ( if P.null notes+ then mempty+ else+ annotate underlined "Notes Detailed:"+ <> hardline+ <> hardline+ <> vsep notesPretty+ <> hardline+ )+++infoTask :: Config -> Connection -> Text -> IO (Doc AnsiStyle)+infoTask conf connection idSubstr = do+ execWithTask conf connection idSubstr $ \task -> do+ now <- dateCurrent++ fullTasks :: [FullTask] <-+ query+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE ulid == ?+ |]+ (Only task.ulid)++ tags <-+ query+ connection+ [sql|+ SELECT *+ FROM task_to_tag+ WHERE task_ulid == ?+ |]+ (Only task.ulid)++ notes <-+ query+ connection+ [sql|+ SELECT *+ FROM task_to_note+ WHERE task_ulid == ?+ |]+ (Only task.ulid)++ pure $ case fullTasks of+ [fullTask] -> formatTaskForInfo conf now (fullTask, tags, notes)+ _ -> pretty noTasksWarning+++nextTask :: Config -> Connection -> IO (Doc AnsiStyle)+nextTask conf connection = do+ now <- dateCurrent++ tasks :: [FullTask] <-+ query_+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE closed_utc IS NULL+ ORDER BY priority DESC+ LIMIT 1+ |]++ case tasks of+ [fullTask] -> do+ tags <-+ query+ connection+ [sql|+ SELECT *+ FROM task_to_tag+ WHERE task_ulid == ?+ |]+ (Only fullTask.ulid)++ notes <-+ query+ connection+ [sql|+ SELECT *+ FROM task_to_note+ WHERE task_ulid == ?+ |]+ (Only fullTask.ulid)++ pure $ formatTaskForInfo conf now (fullTask, tags, notes)+ _ ->+ pure $ pretty noTasksWarning+++randomTask ::+ Config -> Connection -> Maybe [Text] -> IO (Doc AnsiStyle)+randomTask conf connection filterExpression = do+ let+ parserResults =+ readP_to_S filterExpsParser $+ T.unpack (unwords $ fromMaybe [""] filterExpression)+ filterMay = listToMaybe parserResults++ case filterMay of+ Nothing -> do+ (tasks :: [FullTask]) <-+ query_+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE closed_utc IS NULL+ ORDER BY random()+ LIMIT 1+ |]++ case tasks of+ [fullTask] -> infoTask conf connection fullTask.ulid+ _ -> pure $ pretty noTasksWarning+ --+ Just (filterExps, _) -> do+ let+ ppInvalidFilter = \case+ (InvalidFilter error) ->+ dquotes (pretty error) <+> "is an invalid filter"+ (HasStatus Nothing) -> "Filter contains an invalid state value"+ _ -> "The functions should not be called with a valid function"+ errors = P.filter (not . isValidFilter) filterExps+ errorsDoc =+ if P.length errors > 0+ then+ Just $+ vsep (fmap (annotate (colr conf Red) . ppInvalidFilter) errors)+ <> hardline+ <> hardline+ else Nothing++ tasks <-+ query_ connection $+ getFilterQuery+ (HasStatus (Just IsOpen) : filterExps)+ (Just "random()")+ Nothing++ case P.headMay (tasks :: [FullTask]) of+ Nothing -> pure $ pretty noTasksWarning+ Just fullTask -> do+ taskFormatted <- infoTask conf connection fullTask.ulid+ pure $ errorsDoc & fromMaybe taskFormatted+++findTask :: Config -> Connection -> Text -> IO (Doc AnsiStyle)+findTask conf connection aPattern = do+ tasks :: [(Text, Text, Maybe [Text], Maybe [Text], Maybe Text)] <-+ query_+ connection+ [sql|+ SELECT ulid, body, tags, notes, metadata+ FROM tasks_view+ |]++ let+ ulidWidth = 5+ numOfResults = 8+ minimumScore = 5+ ulidColor = Green+ -- TODO: Escape sequences are counted as several chars and mess up wrapping.+ -- Implement first: https://github.com/ad-si/Fuzzily/issues/1+ preTag = "\x1b[4m\x1b[34m" -- Set color to blue and underline text+ postTag = "\x1b[0m" -- Reset styling+ metaNorm metadata =+ metadata+ & fromMaybe ""+ & T.replace ",\"" ", \""+ & T.replace "\":" "\": "+ & T.replace "\"" ""+ matchFunc =+ Fuzzily.match+ Fuzzily.IgnoreCase+ (preTag, postTag)+ identity+ aPattern++ -- Calculate fuzzy score for each part individually+ -- and pick the highest one+ scoreFunc (ulid, theBody, _, mbNotes, mbMetadata) =+ let+ scoreParts =+ [ ( matchFunc theBody+ -- Weight the body score higher+ <&> \case+ Fuzzily.Fuzzy{score, ..} ->+ Fuzzily.Fuzzy{score = score + 1, ..}+ )+ -- Always include the body+ <|> ( Just $+ Fuzzily.Fuzzy+ { original = theBody+ , rendered = theBody+ , score = 0+ }+ )+ , matchFunc (maybe "" unwords mbNotes)+ , -- TODO: Find good way to include tags+ -- , matchFunc (maybe "" unwords mbTags)+ matchFunc (metaNorm mbMetadata)+ , matchFunc ulid+ ]+ highestScore = P.maximum $ 0 : (catMaybes scoreParts <&> Fuzzily.score)+ combinedText =+ scoreParts+ & catMaybes+ <&> (Fuzzily.rendered >>> reflow)+ & P.intersperse mempty+ & vcat+ in+ (highestScore, ulid, combinedText)++ fstOf3 (x, _, _) = x+ tasksScored =+ tasks+ <&> scoreFunc+ & P.filter ((> minimumScore) . fstOf3)+ & sortOn (Down . fstOf3)+ moreResults = P.length tasksScored - numOfResults+ header =+ annotate (underlined <> color ulidColor) (fill ulidWidth "ULID")+ <++> annotate underlined (fill 20 "Task")+ <> hardline+ body =+ tasksScored+ & P.take numOfResults+ <&> ( \(_, ulid, combinedText) ->+ annotate+ (colr conf ulidColor)+ (fill ulidWidth $ pretty $ T.takeEnd ulidWidth ulid)+ <> indent 2 combinedText+ )+ & P.intersperse mempty+ & vsep+ footer =+ if moreResults > 0+ then+ hardline+ <> hardline+ <> annotate+ (colr conf Red)+ ("There are " <> pretty moreResults <> " more results available")+ <> hardline+ else hardline++ pure $ header <> body <> footer+++-- TODO: Use Continuation monad to avoid callback hell+-- withConnectCont :: Text -> ContT a IO Connection+-- withConnectCont dbPath =+-- ContT $ withConnection dbPath++addTag :: Config -> Connection -> Text -> [IdText] -> IO (Doc AnsiStyle)+addTag conf conn tag ids = do+ let tagNorm = T.dropWhile (== '+') tag+ docs <- forM ids $ \idSubstr ->+ execWithTask conf conn idSubstr $ \task -> do+ now <- fmap (T.pack . timePrint conf.utcFormat) timeCurrentP+ ulid <- formatUlid getULID++ catchIf+ -- TODO: Find out why it's not `ErrorConstraintUnique`+ (\(err :: SQLError) -> err.sqlError == ErrorConstraint)+ ( do+ insertRecord+ "task_to_tag"+ conn+ TaskToTag{ulid, task_ulid = task.ulid, tag = tagNorm}++ -- TODO: Check if modified_utc could be set via SQL trigger+ executeNamed+ conn+ [sql|+ UPDATE tasks+ SET modified_utc = :now+ WHERE ulid == :ulid+ |]+ [ ":now" := now+ , ":ulid" := task.ulid+ ]++ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ pure $+ "🏷 Added tag"+ <+> dquotes (pretty tagNorm)+ <+> "to task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ )+ (handleTagDupError conf tagNorm)++ pure $ vsep docs+++deleteTag :: Config -> Connection -> Text -> [IdText] -> IO (Doc AnsiStyle)+deleteTag conf connection tag ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ DELETE FROM task_to_tag+ WHERE+ task_ulid == :task_ulid+ AND tag == :tag+ |]+ [ ":task_ulid" := task.ulid+ , ":tag" := tag+ ]++ numOfChanges <- changes connection++ pure $+ if numOfChanges == 0+ then+ annotate (colr conf Yellow) $+ "⚠️ Tag"+ <+> dquotes (pretty tag)+ <+> "is not set for task"+ <+> dquotes (pretty task.ulid)+ else getResultMsg task ("💥 Removed tag \"" <> pretty tag <> "\"")++ pure $ vsep docs+++addNote :: Config -> Connection -> Text -> [IdText] -> IO (Doc AnsiStyle)+addNote conf connection noteBody ids = do+ docs <- forM ids $ \idSubstr ->+ execWithTask conf connection idSubstr $ \task -> do+ now <- timeCurrentP <&> (timePrint conf.utcFormat >>> T.pack)+ ulid <- formatUlid getULID++ insertRecord+ "task_to_note"+ connection+ TaskToNote+ { ulid+ , task_ulid = task.ulid+ , TaskToNote.note = noteBody+ }++ -- TODO: Check if modified_utc could be set via SQL trigger+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET modified_utc = :now+ WHERE ulid == :ulid+ |]+ [ ":now" := now+ , ":ulid" := task.ulid+ ]++ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ pure $+ "🗒 Added a note to task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId++ pure $ vsep docs+++deleteNote :: Config -> Connection -> IdText -> IO (Doc AnsiStyle)+deleteNote conf connection noteId = do+ taskIds :: [Only Text] <-+ queryNamed+ connection+ [sql|+ DELETE FROM task_to_note+ WHERE ulid == :noteId+ RETURNING task_ulid+ |]+ [":noteId" := noteId]++ case taskIds of+ [Only taskId] ->+ pure $+ "💥 Deleted note"+ <+> dquotes (pretty noteId)+ <+> "of task"+ <+> dquotes (pretty taskId)+ [] ->+ pure $+ annotate (colr conf Yellow) $+ "⚠️ Note" <+> dquotes (pretty noteId) <+> "does not exist"+ _ ->+ pure $+ annotate (colr conf Yellow) $+ ("⚠️ Note" <+> dquotes (pretty noteId) <+> "exists multiple times.")+ <++> "This indicates a serious database inconsistency \+ \and you should clean up the database manually \+ \before continuing."+++setDueUtc :: Config -> Connection -> DateTime -> [IdText] -> IO (Doc AnsiStyle)+setDueUtc conf connection datetime ids = do+ let+ utcText :: Text+ utcText = T.pack $ timePrint conf.utcFormat datetime++ docs <- forM ids $ \idSubstr ->+ execWithTask conf connection idSubstr $ \task -> do+ updateTask connection task{Task.due_utc = Just utcText}++ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ pure $+ "📅 Set due UTC of task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ <+> "to"+ <+> dquotes (pretty utcText)++ pure $ vsep docs+++getResultMsg :: Task -> Doc AnsiStyle -> Doc AnsiStyle+getResultMsg task msg = do+ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ msg <+> "of task" <+> prettyBody <+> "with id" <+> prettyId+++getWarnMsg :: Config -> Task -> Doc AnsiStyle -> Doc AnsiStyle+getWarnMsg conf task msg = do+ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ annotate (colr conf Yellow) $+ "⚠️ Task" <+> prettyBody <+> "with id" <+> prettyId <+> msg+++uncloseTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+uncloseTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET+ closed_utc = NULL,+ state = NULL+ WHERE+ ulid == :ulid AND+ closed_utc IS NOT NULL AND+ state IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "is still open"+ else getResultMsg task "💥 Removed close timestamp and state field"++ pure $ vsep docs+++undueTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+undueTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET due_utc = NULL+ WHERE+ ulid == :ulid AND+ due_utc IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have a due timestamp"+ else getResultMsg task "💥 Removed due timestamp"++ pure $ vsep docs+++unwaitTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unwaitTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET waiting_utc = NULL+ WHERE+ ulid == :ulid AND+ waiting_utc IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have a waiting timestamp"+ else getResultMsg task "💥 Removed waiting and review timestamps"++ pure $ vsep docs+++unwakeTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unwakeTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET awake_utc = NULL+ WHERE+ ulid == :ulid AND+ awake_utc IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have an awake timestamp"+ else getResultMsg task "💥 Removed awake timestamp"++ pure $ vsep docs+++unreadyTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unreadyTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET ready_utc = NULL+ WHERE+ ulid == :ulid AND+ ready_utc IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have a ready timestamp"+ else getResultMsg task "💥 Removed ready timestamp"++ pure $ vsep docs+++unreviewTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unreviewTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET review_utc = NULL+ WHERE+ ulid == :ulid AND+ review_utc IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have a review timestamp"+ else getResultMsg task "💥 Removed review timestamp"++ pure $ vsep docs+++unrepeatTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unrepeatTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET repetition_duration = NULL+ WHERE+ ulid == :ulid AND+ repetition_duration IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have a repetition duration"+ else getResultMsg task "💥 Removed repetition duration"++ pure $ vsep docs+++unrecurTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unrecurTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET recurrence_duration = NULL+ WHERE+ ulid == :ulid AND+ recurrence_duration IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have a recurrence duration"+ else getResultMsg task "💥 Removed recurrence duration"++ pure $ vsep docs+++untagTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+untagTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ DELETE FROM task_to_tag+ WHERE task_ulid == :task_ulid+ |]+ [":task_ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have any tags"+ else getResultMsg task "💥 Removed all tags"++ pure $ vsep docs+++unnoteTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unnoteTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ DELETE FROM task_to_note+ WHERE task_ulid == :task_ulid+ |]+ [":task_ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have any notes"+ else getResultMsg task "💥 Deleted all notes"++ pure $ vsep docs+++unprioTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unprioTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET priority_adjustment = NULL+ WHERE+ ulid == :ulid AND+ priority_adjustment IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have a priority adjustment"+ else getResultMsg task "💥 Removed priority adjustment"++ pure $ vsep docs+++unmetaTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+unmetaTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ executeNamed+ connection+ [sql|+ UPDATE tasks+ SET metadata = NULL+ WHERE+ ulid == :ulid AND+ metadata IS NOT NULL+ |]+ [":ulid" := task.ulid]++ numOfChanges <- changes connection+ pure $+ if numOfChanges == 0+ then getWarnMsg conf task "does not have any metadata"+ else getResultMsg task "💥 Removed metadata"++ pure $ vsep docs+++duplicateTasks :: Config -> Connection -> [IdText] -> IO (Doc AnsiStyle)+duplicateTasks conf connection ids = do+ docs <- forM ids $ \idSubstr -> do+ execWithTask conf connection idSubstr $ \task -> do+ dupeUlid <- formatUlid getULID+ -- TODO: Check if modified_utc can be set via an SQL trigger+ modified_utc <- formatElapsedP conf timeCurrentP+ user <- getEffectiveUserName++ let dupeTask =+ emptyTask+ { Task.ulid = dupeUlid+ , Task.body = task.body+ , Task.modified_utc = modified_utc+ , Task.priority_adjustment = task.priority_adjustment+ , Task.user = T.pack user+ , Task.metadata = task.metadata+ }++ insertRecord "tasks" connection dupeTask++ tags <-+ query+ connection+ [sql|+ SELECT tag+ FROM task_to_tag+ WHERE task_ulid == ?+ |]+ (Only task.ulid)++ warnings <-+ liftIO $ insertTags conf connection Nothing dupeTask (tags & P.concat)++ notes <-+ query+ connection+ [sql|+ SELECT *+ FROM task_to_note+ WHERE task_ulid == ?+ |]+ (Only task.ulid)++ let+ noteTuples =+ notes <&> \theNote ->+ ( ulidTextToDateTime (TaskToNote.ulid theNote)+ , TaskToNote.note theNote+ )++ liftIO $+ insertNoteTuples+ connection+ dupeTask+ noteTuples++ numOfChanges <- changes connection++ let+ prettyBody = dquotes $ pretty task.body+ prettyId = dquotes $ pretty task.ulid++ pure $+ warnings+ <$$> if numOfChanges == 0+ then+ "⚠️ Task"+ <+> prettyBody+ <+> "with id"+ <+> prettyId+ <+> "could not be duplicated"+ else+ "👯 Created a duplicate of task"+ <+> prettyBody+ <+> "(id:"+ <+> pretty task.ulid+ <+> ")"+ <+> "with id"+ <+> pretty dupeUlid++ pure $ vsep docs+++showAtPrecision :: Int -> Double -> Text+showAtPrecision numOfDigits number =+ let+ tuple = T.breakOn "." (show number)+ clipDecimalPart =+ if snd tuple == ".0"+ then T.replace ".0" (T.replicate (1 + numOfDigits) " ")+ else T.take (1 + numOfDigits)+ in+ fst tuple+ <> if numOfDigits /= 0+ then (clipDecimalPart . snd) tuple+ else ""+++formatTag :: (Pretty a) => Config -> a -> Doc AnsiStyle+formatTag conf =+ annotate conf.tagStyle+ . (annotate (colr conf Black) "+" <>)+ . pretty+++invalidUlidMsg :: FullTask -> Doc AnsiStyle+invalidUlidMsg task =+ "Id"+ <+> dquotes (pretty task.ulid)+ <+> "is an invalid ulid and could not be converted to a datetime"+++-- | Convert seconds into a short, fractional notation like 1.5y, 2.3mo, …+formatDuration :: Seconds -> T.Text+formatDuration (Seconds seconds) = do+ let+ secInHour = 3600.0+ secInDay = 24 * secInHour+ secInMonth = 30 * secInDay+ secInYear = 12 * secInMonth++ years = fromIntegral seconds / secInYear+ months = fromIntegral seconds / secInMonth+ days = fromIntegral seconds / secInDay+ hours = fromIntegral seconds / secInHour++ format :: Double -> [Char] -> T.Text+ format val suffix =+ T.pack $ printf "%.1f%-2s" val suffix++ case () of+ _+ | years > 1 -> format years "y"+ | months > 1 -> format months "mo"+ | days > 1 -> format days "d"+ | otherwise -> format hours "h"+++formatTaskPriority :: Config -> FullTask -> Doc AnsiStyle+formatTaskPriority conf task = do+ let+ prio = fromMaybe 0 task.priority+ txt = T.justifyRight 4 ' ' $ showAtPrecision 1 $ realToFrac prio+ annotate conf.priorityStyle (pretty txt)+++formatTaskDue :: Config -> FullTask -> Doc AnsiStyle+formatTaskDue conf task = do+ let+ dueUtcMaybe = task.due_utc >>= parseUtc <&> format+ format = T.replace " 00:00:00" "" . T.pack . timePrint conf.utcFormat+ annotate conf.dueStyle (pretty dueUtcMaybe)+++formatTaskClose :: Config -> FullTask -> Doc AnsiStyle+formatTaskClose conf task = do+ let closedUtcMaybe = task.closed_utc >>= parseUtc <&> timePrint conf.utcFormat+ annotate conf.closedStyle (pretty closedUtcMaybe)+++formatTaskTags :: Config -> FullTask -> Doc AnsiStyle+formatTaskTags conf task = do+ let tags = fromMaybe [] task.tags+ hsep (tags <&> formatTag conf)+++formatTaskNotes :: FullTask -> Doc AnsiStyle+formatTaskNotes task =+ if not $ P.null task.notes then "📝" else ""+++formatTaskId :: Config -> Int -> FullTask -> Doc AnsiStyle+formatTaskId conf taskWidth task = do+ let id = pretty $ T.takeEnd taskWidth task.ulid+ annotate conf.idStyle id+++formatTaskBody :: Config -> DateTime -> FullTask -> Doc AnsiStyle+formatTaskBody conf now task = pretty reviewIcon <> dueSoon <> body+ where+ dueIn offset =+ let dateMaybe = task.due_utc >>= parseUtc+ in isJust dateMaybe && dateMaybe < Just (now `timeAdd` offset)+ grayOutIfDone doc =+ if isOpen+ then annotate conf.bodyStyle doc+ else annotate conf.bodyClosedStyle doc++ isOpen = isNothing task.closed_utc+ reviewIcon = case task.review_utc >>= parseUtc of+ Nothing -> "" :: Text+ Just date_ -> if date_ < now then "🔎 " else ""+ dueSoon = if dueIn mempty{durationHours = 24} && isOpen then "⚠️️ " else ""+ taskBody =+ reflow $+ if countChar '\n' task.body > 0+ then (task.body & T.takeWhile (/= '\n')) <> " ▼"+ else task.body+ body =+ if dueIn mempty && isOpen+ then annotate (colr conf Red) taskBody+ else grayOutIfDone taskBody+++formatTaskOpenedUTC :: Config -> DateTime -> FullTask -> Doc AnsiStyle+formatTaskOpenedUTC conf _now task = do+ let+ dateMaybe = ulidTextToDateTime task.ulid+ formatTaskDate = T.pack . timePrint ISO8601_Date++ annotate (dateStyle conf) (pretty $ maybe "bad Ulid" formatTaskDate dateMaybe)+++formatTaskAge :: Config -> DateTime -> FullTask -> Doc AnsiStyle+formatTaskAge conf now task = do+ let+ dateMaybe = ulidTextToDateTime task.ulid+ formatTaskDuration =+ timeDiff now+ >>> formatDuration+ >>> T.center (colToWidth conf 0 AgeCol) ' '+ >>> T.replace ".0" " "++ annotate+ (dateStyle conf)+ (pretty $ maybe "bad Ulid" formatTaskDuration dateMaybe)+++colToWidth :: Config -> Int -> Column -> Int+colToWidth conf idColWidth = \case+ IdCol -> idColWidth+ PrioCol -> conf.prioWidth+ OpenedUTCCol -> conf.dateWidth+ AgeCol -> 6+ BodyCol -> conf.bodyWidth+ EmptyCol -> 0+++formatTaskLine :: Config -> DateTime -> Int -> FullTask -> Doc AnsiStyle+formatTaskLine conf now idColWidth task = do+ let+ columns = conf.columns & P.filter (/= EmptyCol)+ multilineIndent = 2+ hangWidth =+ ( (columns & P.filter (/= BodyCol) <&> colToWidth conf idColWidth)+ <> [multilineIndent]+ )+ & P.intersperse 2+ & P.sum+ hhsep = concatWith (<++>)+ isEmptyDoc doc = show doc /= ("" :: Text)+ fields =+ columns+ & P.concatMap+ ( \case+ IdCol -> [formatTaskId conf idColWidth task]+ PrioCol -> [formatTaskPriority conf task]+ OpenedUTCCol -> [formatTaskOpenedUTC conf now task]+ AgeCol -> [formatTaskAge conf now task]+ BodyCol ->+ [ formatTaskBody conf now task+ , formatTaskDue conf task+ , formatTaskClose conf task+ , formatTaskTags conf task+ , formatTaskNotes task+ ]+ EmptyCol -> []+ )+ hang hangWidth $ hhsep $ P.filter isEmptyDoc fields+++getIdLength :: Float -> Int+getIdLength numOfItems =+ -- TODO: Calculate idLength by total number of tasks, not just of the viewed+ let+ targetCollisionChance = 0.01 -- Targeted likelihood of id collisions+ sizeOfAlphabet = 32 -- Crockford's base 32 alphabet+ in+ ceiling (logBase sizeOfAlphabet (numOfItems / targetCollisionChance)) + 1+++countTasks :: Config -> Connection -> Maybe [Text] -> IO (Doc AnsiStyle)+countTasks conf connection filterExpression = do+ let+ parserResults =+ readP_to_S filterExpsParser $+ T.unpack (unwords $ fromMaybe [""] filterExpression)+ filterMay = listToMaybe parserResults++ case filterMay of+ Nothing -> do+ [NumRows taskCount] <-+ query_ connection $+ Query $+ "SELECT count(1) FROM " <> quoteKeyword conf.tableName++ pure $ pretty taskCount+ Just (filterExps, _) -> do+ let+ ppInvalidFilter = \case+ (InvalidFilter error) ->+ dquotes (pretty error) <+> "is an invalid filter"+ (HasStatus Nothing) -> "Filter contains an invalid state value"+ _ -> "The functions should not be called with a valid function"+ errors = P.filter (not . isValidFilter) filterExps+ errorsDoc =+ if P.length errors > 0+ then+ Just $+ vsep (fmap (annotate (colr conf Red) . ppInvalidFilter) errors)+ <> hardline+ <> hardline+ else Nothing++ tasks <- query_ connection (getFilterQuery filterExps Nothing Nothing)+ pure $ errorsDoc & fromMaybe (pretty $ P.length (tasks :: [FullTask]))+++-- TODO: Print number of remaining tasks and how to display them at the bottom+headTasks :: Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+headTasks conf now connection availableLinesMb = do+ let taskCount = do+ let availableLines = availableLinesMb & fromMaybe 0+ if P.isJust availableLinesMb && availableLines < conf.headCount+ then availableLines+ else conf.headCount++ tasks <-+ queryNamed+ connection+ -- TODO: Add `wait_utc` < datetime('now')"+ [sql|+ SELECT *+ FROM tasks_view+ WHERE closed_utc IS NULL+ ORDER BY+ priority DESC,+ due_utc ASC,+ ulid DESC+ LIMIT :taskCount+ |]+ [":taskCount" := taskCount]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++newTasks ::+ Config ->+ DateTime ->+ Connection ->+ Maybe [Text] ->+ Maybe Int ->+ IO (Doc AnsiStyle)+newTasks conf now connection filterExp availableLinesMb = do+ let+ parserResults =+ readP_to_S filterExpsParser $+ T.unpack (unwords $ fromMaybe [""] filterExp)+ filterMay = listToMaybe parserResults++ case filterMay of+ Nothing -> do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ ORDER BY ulid DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+ --+ Just (filterExps, _) -> do+ let+ ppInvalidFilter = \case+ (InvalidFilter error) ->+ dquotes (pretty error) <+> "is an invalid filter"+ (HasStatus Nothing) -> "Filter contains an invalid state value"+ _ -> "The functions should not be called with a valid function"+ errors = P.filter (not . isValidFilter) filterExps++ if P.length errors > 0+ then+ pure $+ vsep (fmap (annotate (colr conf Red) . ppInvalidFilter) errors)+ <> hardline+ <> hardline+ else do+ tasks <-+ query_+ connection+ (getFilterQuery filterExps (Just "ulid DESC") availableLinesMb)+ formatTasksColor conf now (isJust availableLinesMb) tasks+++listOldTasks ::+ Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+listOldTasks conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE closed_utc IS NULL+ ORDER BY ulid ASC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++openTasks ::+ Config ->+ DateTime ->+ Connection ->+ Maybe [Text] ->+ Maybe Int ->+ IO (Doc AnsiStyle)+openTasks conf now connection filterExpression availableLinesMb = do+ let+ parserResults =+ readP_to_S filterExpsParser $+ T.unpack (unwords $ fromMaybe [""] filterExpression)+ filterMay = listToMaybe parserResults++ case filterMay of+ Nothing -> do+ (tasks :: [FullTask]) <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE closed_utc IS NULL+ ORDER BY priority DESC, due_utc ASC, ulid DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+ --+ Just (filterExps, _) -> do+ let+ ppInvalidFilter = \case+ (InvalidFilter error) ->+ dquotes (pretty error) <+> "is an invalid filter"+ (HasStatus Nothing) -> "Filter contains an invalid state value"+ _ -> "The functions should not be called with a valid function"+ errors = P.filter (not . isValidFilter) filterExps++ if P.length errors > 0+ then+ pure $+ vsep (fmap (annotate (colr conf Red) . ppInvalidFilter) errors)+ <> hardline+ <> hardline+ else do+ let+ isStateExp = \case (HasStatus _) -> True; _ -> False+ filterExpWithOpen =+ if P.any isStateExp filterExps+ then filterExps+ else HasStatus (Just IsOpen) : filterExps+ sqlQuery =+ getFilterQuery+ filterExpWithOpen+ (Just "priority DESC, due_utc ASC, ulid DESC")+ availableLinesMb++ tasks <- query_ connection sqlQuery+ formatTasksColor conf now (isJust availableLinesMb) tasks+++modifiedTasks ::+ Config ->+ DateTime ->+ Connection ->+ ListModifiedFlag ->+ Maybe Int ->+ IO (Doc AnsiStyle)+modifiedTasks conf now connection listModifiedFlag availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ ORDER BY modified_utc Desc+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ let+ filterModified =+ P.filter+ ( \task ->+ removeNSec (ulidTextToDateTime task.ulid)+ /= parseUtc task.modified_utc+ )++ removeNSec :: Maybe DateTime -> Maybe DateTime+ removeNSec mDateTime =+ case mDateTime of+ Just dateTime ->+ Just $+ dateTime{dtTime = (dtTime dateTime){todNSec = 0}}+ Nothing -> Nothing++ filteredTasks =+ case listModifiedFlag of+ AllItems -> tasks+ ModifiedItemsOnly -> filterModified tasks++ formatTasksColor conf now (isJust availableLinesMb) filteredTasks+++overdueTasks ::+ Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+overdueTasks conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE+ closed_utc IS NULL AND+ due_utc < datetime('now')+ ORDER BY+ priority DESC,+ due_utc ASC,+ ulid Desc+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++doneTasks :: Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+doneTasks conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE+ closed_utc IS NOT NULL AND+ state == 'Done'+ ORDER BY closed_utc DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++obsoleteTasks ::+ Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+obsoleteTasks conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE+ closed_utc IS NOT NULL AND+ state == 'Obsolete'+ ORDER BY ulid DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++deletableTasks ::+ Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+deletableTasks conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE+ closed_utc IS NOT NULL+ AND state == 'Deletable'+ ORDER BY ulid DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]+ formatTasksColor conf now (isJust availableLinesMb) tasks+++listRepeating ::+ Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+listRepeating conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE repetition_duration IS NOT NULL+ ORDER BY repetition_duration Desc+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++listRecurring ::+ Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+listRecurring conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE recurrence_duration IS NOT NULL+ ORDER BY recurrence_duration DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++listReady ::+ Config -> DateTime -> Connection -> Maybe P.Int -> IO (Doc AnsiStyle)+listReady conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE+ (ready_utc IS NULL OR+ (ready_utc IS NOT NULL AND ready_utc < datetime('now'))+ ) AND+ waiting_utc IS NULL AND+ ready_utc IS NULL AND+ closed_utc IS NULL+ ORDER BY+ priority DESC,+ due_utc ASC,+ ulid DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++listWaiting ::+ Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+listWaiting conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE closed_utc IS NULL+ AND waiting_utc IS NOT NULL+ AND (review_utc > datetime('now') OR review_utc IS NULL)+ ORDER BY waiting_utc DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++listAll :: Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+listAll conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ ORDER BY ulid ASC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++listNoTag :: Config -> DateTime -> Connection -> Maybe Int -> IO (Doc AnsiStyle)+listNoTag conf now connection availableLinesMb = do+ tasks <-+ queryNamed+ connection+ [sql|+ SELECT *+ FROM tasks_view+ WHERE+ closed_utc IS NULL AND+ tags IS NULL+ ORDER BY+ priority DESC,+ due_utc ASC,+ ulid DESC+ LIMIT :taskCount+ |]+ [ ":taskCount" := case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ ]++ formatTasksColor conf now (isJust availableLinesMb) tasks+++getWithTag ::+ Connection ->+ Maybe DerivedState ->+ Maybe Int ->+ [Text] ->+ IO [FullTask]+getWithTag connection stateMaybe availableLinesMb tags = do+ let+ tagQuery = case tags of+ [] -> ""+ _ ->+ tags+ <&> (\t -> "tag LIKE '" <> t <> "'")+ & T.intercalate " OR "+ & ("AND " <>)++ stateQuery = case stateMaybe of+ Nothing -> ""+ Just derivedState -> "AND " <> derivedStateToQuery derivedState++ -- `WHERE TRUE` simplifies adding additional filters with "AND"+ ulidsQuery =+ "\+ \SELECT tasks.ulid \n\+ \FROM tasks \n\+ \LEFT JOIN task_to_tag ON tasks.ulid IS task_to_tag.task_ulid \n\+ \WHERE TRUE \n\+ \"+ <> tagQuery+ <> " \+ \"+ <> stateQuery+ <> " \+ \GROUP BY tasks.ulid \+ \HAVING count(tag) = "+ <> show (P.length tags)++ mainQuery =+ FullTask.selectQuery+ <> "\+ \FROM ("+ <> Query ulidsQuery+ <> ") tasks1\n\+ \LEFT JOIN tasks_view ON tasks1.ulid IS tasks_view.ulid\n\+ \ORDER BY \n\+ \ priority DESC,\n\+ \ due_utc ASC,\n\+ \ ulid DESC\n\+ \LIMIT "+ <> Query+ ( show @Int $ case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ )++ query_ connection mainQuery+++listWithTag ::+ Config -> DateTime -> Connection -> [Text] -> Maybe Int -> IO (Doc AnsiStyle)+listWithTag conf now connection tags availableLinesMb = do+ tasks <- getWithTag connection Nothing availableLinesMb tags+ formatTasksColor conf now (isJust availableLinesMb) tasks+++queryTasks :: Config -> DateTime -> Connection -> Text -> IO (Doc AnsiStyle)+queryTasks conf now connection sqlQuery = do+ tasks <-+ query_ connection $+ Query $+ "SELECT * FROM tasks_view WHERE " <> sqlQuery+ formatTasksColor conf now False tasks+++runSql :: Config -> Text -> IO (Doc AnsiStyle)+runSql conf sqlQuery = do+ result <-+ readProcess+ "sqlite3"+ [ conf.dataDir </> conf.dbName+ , ".headers on"+ , ".mode csv"+ , ".separator , '\n'"+ , T.unpack sqlQuery+ ]+ []+ -- Remove trailing newline+ pure $ pretty (T.dropEnd 1 $ T.pack result)+++data FilterExp+ = HasTag Text+ | NotTag Text+ | HasDue Text+ | HasStatus (Maybe DerivedState) -- Should be `Either`+ | InvalidFilter Text+ deriving (Show)+++tagParser :: ReadP FilterExp+tagParser = do+ _ <- char '+'+ aTag <- munch (not . isSpace)+ pure $ HasTag $ T.pack aTag+++notTagParser :: ReadP FilterExp+notTagParser = do+ _ <- char '-'+ aTag <- munch (not . isSpace)+ pure $ NotTag $ T.pack aTag+++dueParser :: ReadP FilterExp+dueParser = do+ _ <- string "due:"+ utcStr <- munch (not . isSpace)+ pure $ HasDue $ T.pack utcStr+++stateParser :: ReadP FilterExp+stateParser = do+ _ <- string "state:"+ stateStr <- munch (not . isSpace)+ pure $ HasStatus $ textToDerivedState $ T.pack stateStr+++filterExpParser :: ReadP FilterExp+filterExpParser =+ do+ tagParser+ <++ notTagParser+ <++ dueParser+ <++ stateParser+ <++ (InvalidFilter . T.pack <$> munch1 (not . isSpace))+++filterExpsParser :: ReadP [FilterExp]+filterExpsParser = do+ val <- sepBy1 filterExpParser skipSpaces+ eof+ return val+++parseFilterExps :: Text -> IO ()+parseFilterExps input =+ P.print $ readP_to_S filterExpsParser $ T.unpack input+++{-| Returns (operator, where-query) tuple+ TODO: Should be `FilterExp -> Maybe (Text, Text)`+-}+filterToSql :: FilterExp -> (Text, Text)+filterToSql = \case+ HasTag tag -> ("INTERSECT", "tag LIKE " <> quoteText tag)+ NotTag tag -> ("EXCEPT", "tag LIKE " <> quoteText tag)+ HasDue utc -> ("INTERSECT", "due_utc < datetime(" <> quoteText utc <> ")")+ HasStatus (Just taskState) -> ("INTERSECT", derivedStateToQuery taskState)+ -- Following cases should never be called, as they are filtered out+ HasStatus Nothing -> ("", "")+ InvalidFilter _ -> ("", "")+++isValidFilter :: FilterExp -> Bool+isValidFilter = \case+ InvalidFilter _ -> False+ HasStatus Nothing -> False+ _ -> True+++runFilter ::+ Config -> DateTime -> Connection -> [Text] -> Maybe Int -> IO (Doc AnsiStyle)+runFilter conf now connection exps availableLinesMb = do+ let+ parserResults = readP_to_S filterExpsParser $ T.unpack $ unwords exps+ filterHelp =+ "Filter expressions must be a list of key[:value] entries."+ <> hardline+ dieWithError err = do+ hPutDoc stderr $ annotate (colr conf Red) err+ exitFailure++ case parserResults of+ [(filterExps, _)] -> do+ let+ ppInvalidFilter = \case+ (InvalidFilter error) ->+ dquotes (pretty error)+ <+> "is an invalid filter."+ <> hardline+ <> filterHelp+ (HasStatus Nothing) ->+ "Filter contains an invalid state value"+ _ ->+ "The functions should not be called with a valid function"+ errors = P.filter (not . isValidFilter) filterExps+ sqlQuery = getFilterQuery filterExps Nothing availableLinesMb++ tasks <- query_ connection sqlQuery++ if P.length errors > 0+ then dieWithError $ vsep (fmap ppInvalidFilter errors)+ else+ if P.length tasks <= 0+ then pure "No tasks available for the given filter."+ else formatTasksColor conf now False tasks+ _ -> dieWithError filterHelp+++-- TODO: Increase performance of this query+getFilterQuery :: [FilterExp] -> Maybe Text -> Maybe Int -> Query+getFilterQuery filterExps orderByMb availableLinesMb = do+ let+ filterTuple =+ filterToSql <$> P.filter isValidFilter filterExps++ queries =+ filterTuple <&> \(operator, whereQuery) ->+ operator+ <> "\n\+ \SELECT tasks.ulid\n\+ \FROM tasks\n\+ \LEFT JOIN task_to_tag ON tasks.ulid IS task_to_tag.task_ulid\n\+ \WHERE "+ <> whereQuery+ <> "\n\+ \GROUP BY tasks.ulid"++ ulidsQuery =+ "SELECT tasks.ulid FROM tasks\n"+ <> unlines queries++ orderBy = Query $ case orderByMb of+ Nothing ->+ "ORDER BY \n\+ \ priority DESC,\n\+ \ due_utc ASC,\n\+ \ ulid DESC\n"+ Just orderByTxt ->+ "ORDER BY \n" <> orderByTxt <> "\n"++ FullTask.selectQuery+ <> "FROM ("+ <> Query ulidsQuery+ <> ") tasks1\n\+ \LEFT JOIN tasks_view ON tasks1.ulid IS tasks_view.ulid\n"+ <> orderBy+ <> Query+ ( "LIMIT "+ <> ( show @P.Int $ case availableLinesMb of+ Nothing -> -1 -- No limit+ Just availableLines -> availableLines+ )+ <> "\n"+ )+++columnToDoc :: Config -> Int -> Column -> Doc AnsiStyle+columnToDoc conf idColWidth = do+ let strong = bold <> underlined++ \case+ IdCol ->+ annotate+ (conf.idStyle <> strong)+ (fill idColWidth "Id")+ PrioCol ->+ annotate+ (conf.priorityStyle <> strong)+ (fill (colToWidth conf idColWidth PrioCol) "Prio")+ OpenedUTCCol ->+ annotate+ (conf.dateStyle <> strong)+ (fill (colToWidth conf idColWidth OpenedUTCCol) "Opened UTC")+ AgeCol ->+ annotate+ (conf.dateStyle <> strong)+ (fill (colToWidth conf idColWidth AgeCol) "Age")+ BodyCol ->+ annotate+ (conf.bodyStyle <> strong)+ (fill (colToWidth conf idColWidth BodyCol) "Body")+ EmptyCol ->+ mempty+++formatTasks :: Config -> DateTime -> Bool -> [FullTask] -> Doc AnsiStyle+formatTasks conf now isTruncated tasks =+ if P.length tasks == 0+ then pretty noTasksWarning+ else do+ let+ idColWidth = getIdLength $ fromIntegral $ P.length tasks+ docHeader =+ concatWith (<++>) $+ ( conf.columns+ & P.filter (/= EmptyCol)+ <&> columnToDoc conf idColWidth+ )+ <> [line]++ docHeader+ <> vsep (fmap (formatTaskLine conf now idColWidth) tasks)+ <> line+ <> if isTruncated+ then+ annotate+ (colr conf Yellow)+ ( "This list is truncated. "+ <> "List all by piping into `cat` or `less`."+ )+ else mempty+++formatTasksColor ::+ Config -> DateTime -> Bool -> [FullTask] -> IO (Doc AnsiStyle)+formatTasksColor conf now isTruncated tasks = do+ confNorm <- applyColorMode conf+ pure $ formatTasks confNorm now isTruncated tasks+++getProgressBar :: Config -> Integer -> Double -> Doc AnsiStyle+getProgressBar conf maxWidthInChars progress =+ let+ barWidth = floor (progress * fromInteger maxWidthInChars)+ remainingWidth = fromIntegral $ maxWidthInChars - barWidth+ in+ annotate+ (bgColrDull conf Green <> colrDull conf Green)+ (pretty $ P.take (fromIntegral barWidth) $ P.repeat '#')+ <>+ -- (annotate (bgColrDull conf Green) $ fill (fromIntegral barWidth) "" <>+ annotate (bgColrDull conf Black) (fill remainingWidth "")+++formatTagLine ::+ Config -> Int -> (Text, Integer, Integer, Double) -> Doc AnsiStyle+formatTagLine conf maxTagLength (tag, open_count, closed_count, progress) =+ let+ barWidth = toInteger $ progressBarWidth conf+ progressPercentage =+ if progress == 0+ then " "+ else+ pretty+ ( T.justifyRight 3 ' ' $+ T.pack $+ showFFloat (Just 0) (progress * 100) ""+ )+ <+> "%"+ in+ fill maxTagLength (pretty tag)+ <++> pretty (T.justifyRight (T.length "open") ' ' $ show open_count)+ <++> pretty (T.justifyRight (T.length "closed") ' ' $ show closed_count)+ <++> progressPercentage+ <+> getProgressBar conf barWidth progress+++formatTags :: Config -> [(Text, Integer, Integer, Double)] -> Doc AnsiStyle+formatTags conf tagTuples = do+ let+ percWidth = 6 -- Width of e.g. 100 %+ progressWith = conf.progressBarWidth + percWidth+ firstOf4 (a, _, _, _) = a+ maxTagLength =+ tagTuples+ <&> (T.length . firstOf4)+ & P.maximum++ if P.null tagTuples+ then+ annotate+ (colr conf Yellow)+ "⚠️ No tags available"+ else+ annotate (bold <> underlined) (fill maxTagLength "Tag")+ <++> annotate (bold <> underlined) "Open"+ <++> annotate (bold <> underlined) "Closed"+ <++> annotate (bold <> underlined) (fill progressWith "Progress")+ <> line+ <> vsep (fmap (formatTagLine conf maxTagLength) tagTuples)+++listTags :: Config -> Connection -> IO (Doc AnsiStyle)+listTags conf connection = do+ tags <- query_ connection $ Query "SELECT * FROM tags"++ pure $ formatTags conf tags+++listProjects :: Config -> Connection -> IO (Doc AnsiStyle)+listProjects conf connection = do+ tags <-+ query_+ connection+ [sql|+ SELECT *+ FROM tags+ WHERE+ "open" > 0 AND+ closed > 0+ |]++ pure $+ if P.null tags+ then+ annotate (colr conf Yellow) $+ "⚠️ No projects available yet. "+ <> "Tag some tasks to populate this list."+ else formatTags conf tags+++listNotes :: Config -> Connection -> IO (Doc AnsiStyle)+listNotes conf connection = do+ (notes :: [TaskToNote]) <-+ query_+ connection+ [sql|+ SELECT ulid, task_ulid, note+ FROM task_to_note+ ORDER BY ulid DESC+ |]++ let+ taskIdWidth = 7 -- TODO: Use dynamic width+ noteWidth = getIdLength $ fromIntegral $ P.length notes+ docHeader =+ annotate+ (conf.idStyle <> bold <> underlined)+ (fill taskIdWidth "Task ID")+ <++> annotate+ (conf.idStyle <> bold <> underlined)+ (fill noteWidth "ID")+ <++> annotate (conf.dateStyle <> bold <> underlined) "Created UTC"+ <++> annotate (bold <> underlined) "Note"+ <++> line++ showNote note =+ annotate+ conf.idStyle+ (fill 7 $ pretty $ T.takeEnd taskIdWidth note.task_ulid)+ <++> annotate+ conf.idStyle+ (fill noteWidth $ pretty $ T.takeEnd noteWidth note.ulid)+ <++> annotate+ conf.dateStyle+ ( note.ulid+ & ulidTextToDateTime+ <&> timePrint ISO8601_Date+ & pretty+ )+ <++> pretty note.note+ <> line++ pure $ docHeader <> vsep (notes <&> showNote)+++getStats :: Config -> Connection -> IO (Doc AnsiStyle)+getStats _ connection = do+ [NumRows numOfTasksTotal] <-+ query_ connection $+ Query "SELECT count(1) FROM tasks"+ [NumRows numOfTasksOpen] <-+ query_ connection $+ Query "SELECT count(1) FROM tasks WHERE closed_utc IS NULL"+ [NumRows numOfTasksClosed] <-+ query_ connection $+ Query "SELECT count(1) FROM tasks WHERE closed_utc IS NOT NULL"+ [NumRows numOfTasksDone] <-+ query_ connection $+ Query "SELECT count(1) FROM tasks WHERE state IS 'Done'"+ [NumRows numOfTasksObsolete] <-+ query_ connection $+ Query "SELECT count(1) FROM tasks WHERE state IS 'Obsolete'"+ [NumRows numOfTasksDeletable] <-+ query_ connection $+ Query "SELECT count(1) FROM tasks WHERE state IS 'Deletable'"++ let+ widthKey = 12+ widthValue = max 5 $ fromIntegral $ numDigits 10 numOfTasksTotal+ formatLine (name :: Text) (numTasks :: Integer) =+ let+ numTotalInt :: Double = fromIntegral numOfTasksTotal+ numTasksInt :: Double = fromIntegral numTasks+ share = T.pack $ showFFloat (Just 3) (numTasksInt / numTotalInt) ""+ in+ fill widthKey (pretty name)+ <++> fill+ widthValue+ (pretty $ T.justifyRight widthValue ' ' $ show numTasks) <++> pretty share pure $
source/Migrations.hs view
@@ -535,8 +535,8 @@ currentVersionList <- query_ connection- "PRAGMA user_version"- :: IO [UserVersion]+ "PRAGMA user_version" ::+ IO [UserVersion] let migrations = [_0_, _1_, _2_, _3_, _4_]
source/Task.hs view
@@ -73,7 +73,13 @@ import Test.QuickCheck.Instances.Text () import Config (defaultConfig, utcFormat)-import Database.SQLite.Simple (Connection, Only (Only), query)+import Control.Arrow ((>>>))+import Database.SQLite.Simple (+ Connection,+ Only (Only),+ SQLData (SQLNull),+ query,+ ) import Database.SQLite.Simple.QQ (sql) @@ -189,19 +195,20 @@ textToDerivedState :: Text -> Maybe DerivedState-textToDerivedState = \case- "open" -> Just IsOpen- "closed" -> Just IsClosed- "asleep" -> Just IsAsleep- "awake" -> Just IsAwake- "ready" -> Just IsReady- "waiting" -> Just IsWaiting- "review" -> Just IsReview- "done" -> Just IsDone- "obsolete" -> Just IsObsolete- "deletable" -> Just IsDeletable- "blocked" -> Just IsBlocked- _ -> Nothing+textToDerivedState =+ T.toLower >>> \case+ "open" -> Just IsOpen+ "closed" -> Just IsClosed+ "asleep" -> Just IsAsleep+ "awake" -> Just IsAwake+ "ready" -> Just IsReady+ "waiting" -> Just IsWaiting+ "review" -> Just IsReview+ "done" -> Just IsDone+ "obsolete" -> Just IsObsolete+ "deletable" -> Just IsDeletable+ "blocked" -> Just IsBlocked+ _ -> Nothing derivedStateToQuery :: DerivedState -> Text@@ -332,7 +339,9 @@ , Sql.ToField.toField task.recurrence_duration , Sql.ToField.toField task.priority_adjustment , Sql.ToField.toField task.user- , SQLText $ task.metadata & (decodeUtf8 . BSL.toStrict . Aeson.encode)+ , case task.metadata of+ Nothing -> SQLNull+ Just val -> SQLText $ val & (Aeson.encode >>> BSL.toStrict >>> decodeUtf8) ] @@ -363,8 +372,8 @@ arbitrary = genericArbitraryU -zeroTask :: Task-zeroTask =+emptyTask :: Task+emptyTask = Task { ulid = "" , body = ""@@ -398,54 +407,66 @@ } -{-| Convert a task to a YAML string that can be edited+{-| Convert a task to a Markdown string with YAML frontmatter that can be edited | and then converted back to a task. | Tags and notes are commented out, so they are not accidentally added again. -}-taskToEditableYaml :: Connection -> Task -> P.IO P.ByteString-taskToEditableYaml conn task = do+taskToEditableMarkdown :: Connection -> Task -> P.IO P.ByteString+taskToEditableMarkdown conn task = do (tags :: [[P.Text]]) <-- query- conn- [sql|- SELECT tag- FROM task_to_tag- WHERE task_ulid == ?- |]- (Only $ ulid task)+ if T.null task.ulid+ then pure []+ else+ query+ conn+ [sql|+ SELECT tag+ FROM task_to_tag+ WHERE task_ulid == ?+ |]+ (Only task.ulid) (notes :: [[P.Text]]) <-- query- conn- [sql|- SELECT note- FROM task_to_note- WHERE task_ulid == ?- |]- (Only $ ulid task)+ if T.null task.ulid+ then pure []+ else+ query+ conn+ [sql|+ SELECT note+ FROM task_to_note+ WHERE task_ulid == ?+ |]+ (Only task.ulid) - let indentNoteContent noteContent =- noteContent- & T.strip- & T.lines- <&> T.stripEnd- & T.intercalate "\n# "+ let+ indentNoteContent noteContent =+ noteContent+ & T.strip+ & T.lines+ <&> T.stripEnd+ & T.intercalate "\n# " + taskWithEmptyBody = task{body = ""}+ frontmatterYaml =+ ( taskWithEmptyBody+ & Yaml.encode+ & P.decodeUtf8+ & T.replace "\nbody: ''\n" "\n"+ )+ <> "\n# | Existing tags and notes can't be edited here, \+ \but new ones can be added\n\n"+ <> (("# tags: " :: Text) <> P.show (P.concat tags) <> "\n")+ <> "tags: []\n"+ <> ( ("\n# notes:\n" :: Text)+ <> ( notes+ & P.concat+ <&> (\note -> "# - " <> indentNoteContent note)+ & T.unlines+ )+ )+ <> "notes: []\n"+ pure $- ( task- & Yaml.encode- & P.decodeUtf8- )- <> "\n# | Existing tags and notes can't be edited here, \- \but new ones can be added\n\n"- <> (("# tags: " :: Text) <> P.show (P.concat tags) <> "\n")- <> "tags: []\n"- <> ( ("\n# notes:\n" :: Text)- <> ( notes- & P.concat- <&> (\note -> "# - " <> indentNoteContent note)- & T.unlines- )- )- <> "notes: []\n"- & P.encodeUtf8+ ("---\n" <> frontmatterYaml <> "...\n\n" <> body task)+ & P.encodeUtf8
source/Utils.hs view
@@ -20,7 +20,6 @@ Integer, Integral (div, mod), Maybe (..),- Monoid (mempty), Num ((*), (+)), Ord ((<), (>)), Rational,@@ -30,10 +29,10 @@ Show, Word16, flip,- forM, fromIntegral, fromMaybe, fst,+ mempty, otherwise, readMaybe, realToFrac,@@ -43,9 +42,12 @@ (&), (.), (<&>),+ (==), ) import Protolude qualified as P +import Base32 (decode)+import Control.Arrow ((>>>)) import Control.Monad.Catch (catchAll) import Data.Colour.RGBSpace (RGB (..)) import Data.Hourglass (@@ -63,41 +65,29 @@ timeParse, timePrint, )-import Data.Text as T (- Text,- chunksOf,- drop,- intercalate,- pack,- take,- toLower,- unlines,- unpack,- )+import Data.Text (Text, unpack)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL import Data.Time (UTCTime, ZonedTime, addUTCTime, zonedTimeToUTC) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.ULID (ULID (ULID, random, timeStamp)) import Data.ULID.Random (ULIDRandom, mkULIDRandom) import Data.ULID.TimeStamp (ULIDTimeStamp, mkULIDTimeStamp)-import Prettyprinter (Doc, Pretty (pretty), softline)+import Prettyprinter (Doc, hardline, softline)+import Prettyprinter.Internal.Type (Doc (Empty)) import Prettyprinter.Render.Terminal ( AnsiStyle, Color (Black),+ bgColorDull,+ color, colorDull, ) import System.Console.ANSI (ConsoleLayer (..), hGetLayerColor)-import System.Process (readProcess)--import Base32 (decode)-import Config (- Config (bodyStyle),- Hook (body, filePath, interpreter),- )-import Control.Arrow ((>>>))-import Prettyprinter.Internal.Type (Doc (Empty)) import System.Random (mkStdGen) +import Config (Config (..)) + type IdText = Text type TagText = Text @@ -110,6 +100,12 @@ deriving (Eq, Show) +-- | Always add a hardline after non-empty documents+(<!!>) :: Doc ann -> Doc ann -> Doc ann+Empty <!!> y = y+x <!!> y = x <> hardline <> y++ -- | Combine documents with 2 newlines (<++>) :: Doc ann -> Doc ann -> Doc ann x <++> y =@@ -142,6 +138,11 @@ } +-- | ULID time section if timestamp == 1970-01-01 00:00:00.000+zeroUlidTxt :: Text+zeroUlidTxt = "0000000000"++ utcFormatReadable :: TimeFormatString utcFormatReadable = toFormat ("YYYY-MM-DD H:MI:S" :: [Char])@@ -205,22 +206,22 @@ T.take 10 >>> parseUlidUtcSection -{-| `ulid2utc` converts a ULID to a UTC timestamp+{-| `ulidText2utc` converts a ULID to a UTC timestamp ->>> ulid2utc "01hq68smfe0r9entg3x4rb9441"+>>> ulidText2utc "01hq68smfe0r9entg3x4rb9441" Just "2024-02-21 16:43:17.358" -}-ulid2utc :: Text -> Maybe Text-ulid2utc ulid =- fmap- (T.pack . timePrint (toFormat ("YYYY-MM-DD H:MI:S.ms" :: [Char])))- (ulidTextToDateTime ulid)+ulidText2utc :: Text -> Maybe Text+ulidText2utc ulid =+ ulid+ & ulidTextToDateTime+ <&> (timePrint (toFormat ("YYYY-MM-DD H:MI:S.ms" :: [Char])) >>> T.pack) parseUlidText :: Text -> Maybe ULID parseUlidText ulidText = do let- mkUlidTimeMaybe text = fmap toUlidTime (ulidTextToDateTime text)+ mkUlidTimeMaybe text = text & ulidTextToDateTime <&> toUlidTime mkUlidRandomMaybe :: Text -> Maybe ULIDRandom mkUlidRandomMaybe = readMaybe . T.unpack . T.drop 10@@ -243,9 +244,17 @@ ((1e9 * fromIntegral s) + fromIntegral ns) / 1e9 +formatElapsedP :: Config -> IO ElapsedP -> IO Text+formatElapsedP conf =+ fmap (timePrint conf.utcFormat >>> T.pack)++ toUlidTime :: DateTime -> ULIDTimeStamp toUlidTime =- mkULIDTimeStamp . realToFrac . elapsedPToRational . timeGetElapsedP+ timeGetElapsedP+ >>> elapsedPToRational+ >>> realToFrac+ >>> mkULIDTimeStamp setDateTime :: ULID -> DateTime -> ULID@@ -303,31 +312,47 @@ 1 + fst (ilog base num) -executeHooks :: Text -> [Hook] -> IO (Doc AnsiStyle)-executeHooks stdinText hooks = do- let stdinStr = T.unpack stdinText- cmdOutput <- forM hooks $ \hook ->- case hook.filePath of- Just fPath -> readProcess fPath [] stdinStr- Nothing -> do- let ipret = hook.interpreter- if- | ipret `P.elem` ["ruby", "rb"] ->- readProcess "ruby" ["-e", T.unpack hook.body] stdinStr- | ipret `P.elem` ["javascript", "js", "node", "node.js"] ->- readProcess "node" ["-e", T.unpack hook.body] stdinStr- | ipret `P.elem` ["python", "python3", "py"] ->- readProcess "python3" ["-c", T.unpack hook.body] stdinStr- | otherwise ->- pure mempty+colr :: Config -> Color -> AnsiStyle+colr conf newColor =+ if conf.noColor+ then mempty+ else color newColor - pure $- cmdOutput- <&> T.pack- & T.unlines- & pretty +colrDull :: Config -> Color -> AnsiStyle+colrDull conf newColor =+ if conf.noColor+ then mempty+ else colorDull newColor ++bgColrDull :: Config -> Color -> AnsiStyle+bgColrDull conf newColor =+ if conf.noColor+ then mempty+ else bgColorDull newColor+++removeColorsIfNecessary :: Config -> IO Config+removeColorsIfNecessary conf = do+ if conf.noColor+ then+ pure+ conf+ { idStyle = mempty+ , priorityStyle = mempty+ , dateStyle = mempty+ , bodyStyle = mempty+ , bodyClosedStyle = mempty+ , closedStyle = mempty+ , dueStyle = mempty+ , overdueStyle = mempty+ , tagStyle = mempty+ }+ else+ pure conf++ applyColorMode :: Config -> IO Config applyColorMode conf = do layerColorBgMb <-@@ -352,5 +377,15 @@ pure $ if isLightMode- then conf{bodyStyle = colorDull Black}+ then conf{bodyStyle = colrDull conf Black} else conf+++countCharTL :: Char -> TL.Text -> P.Int64+countCharTL char =+ TL.filter (== char) >>> TL.length+++countChar :: Char -> Text -> P.Int+countChar char =+ T.filter (== char) >>> T.length
tasklite-core.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: tasklite-core-version: 0.3.0.0+version: 0.5.0.0 synopsis: CLI task / todo list manager with SQLite backend description: TaskLite is a CLI task / todo list manager with a SQLite backend. It is designed to be simple and easy to use,@@ -37,7 +37,9 @@ Cli Config FullTask+ Hooks ImportExport+ ImportTask Lib Migrations Note@@ -68,7 +70,7 @@ QuickCheck ==2.14.* , aeson >=2.2.1 && <2.3 , airgql >=0.7.1.2 && <0.8- , ansi-terminal >=0.11 && <1.1+ , ansi-terminal >=0.11 && <1.2 , base >=4.18 && <5 , bytestring >=0.11 && <0.13 , cassava >=0.5.2 && <0.6@@ -76,6 +78,7 @@ , directory ==1.3.* , editor-open >=0.4 && <0.7 , exceptions ==0.10.*+ , extra >=1.7 && <1.9 , file-embed >=0.0.14 && <0.1 , filepath >=1.4 && <1.6 , fuzzily ==0.2.*@@ -100,6 +103,7 @@ , simple-sql-parser >=0.6 && <0.8 , sqlite-simple ==0.4.* , syb ==0.7.*+ , terminal-size ==0.3.* , text >=1.2 && <2.2 , time >=1.11 && <1.15 , ulid ==0.3.*@@ -117,9 +121,13 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:+ ImportExportSpec LibSpec+ MigrationsSpec+ SpecHook TestUtils TypesSpec+ UtilsSpec Paths_tasklite_core autogen-modules: Paths_tasklite_core@@ -137,15 +145,19 @@ UndecidableInstances ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-orphans -Wredundant-constraints -Wunused-packages build-depends:- aeson+ MissingH >=1.4 && <1.7+ , aeson , base >=4.18 && <5+ , bytestring , hourglass- , hspec- , neat-interpolation+ , hspec >=2.11 && <3.0+ , iso8601-duration+ , neat-interpolation ==0.5.* , protolude >=0.3 , sqlite-simple , tasklite-core , text+ , ulid , yaml default-language: GHC2021 @@ -171,6 +183,6 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-orphans -Wredundant-constraints -Wunused-packages build-depends: base >=4.18 && <5- , criterion+ , criterion >=1.5 && <1.7 , protolude >=0.3 default-language: GHC2021
+ test/ImportExportSpec.hs view
@@ -0,0 +1,315 @@+module ImportExportSpec where++import Protolude (+ Either (Left, Right),+ Maybe (..),+ Text,+ fromMaybe,+ show,+ ($),+ (&),+ (<&>),+ (<>),+ )+import Protolude qualified as P++import Data.Aeson (Value (Object), decode, eitherDecode, eitherDecodeStrictText)+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy qualified as BSL+import Data.Hourglass (timePrint, toFormat)+import Data.Text (unpack)+import Data.Text qualified as T+import Data.ULID (ULID)+import Database.SQLite.Simple (query_)+import Test.Hspec (+ Spec,+ describe,+ it,+ shouldBe,+ shouldNotBe,+ shouldStartWith,+ )++import Config (defaultConfig)+import FullTask (FullTask, emptyFullTask)+import FullTask qualified+import ImportExport (getNdjsonLines, insertImportTask)+import ImportTask (ImportTask (ImportTask, notes, tags, task))+import Note (Note (Note))+import Task (Task (body, modified_utc, ulid, user), emptyTask)+import TaskToNote (TaskToNote (TaskToNote))+import TaskToNote qualified+import TestUtils (withMemoryDb)+import Utils (emptyUlid, parseUtc, setDateTime, ulidText2utc, zeroTime)+++spec :: Spec+spec = do+ let conf = defaultConfig++ describe "Import" $ do+ it "parses any sensible datetime string" $ do+ -- TODO: Maybe keep microseconds and nanoseconds+ -- , ("YYYY-MM-DDTH:MI:S.msusZ", "2024-03-15T22:20:05.637913Z")+ -- , ("YYYY-MM-DDTH:MI:S.msusnsZ", "2024-03-15T22:20:05.637913438Z")++ let dateMap :: [(Text, Text)] =+ [ ("YYYY-MM-DD", "2024-03-15")+ , ("YYYY-MM-DD H:MI", "2024-03-15 22:20")+ , ("YYYY-MM-DDTH:MIZ", "2024-03-15T22:20Z")+ , ("YYYY-MM-DD H:MI:S", "2024-03-15 22:20:05")+ , ("YYYY-MM-DDTH:MI:SZ", "2024-03-15T22:20:05Z")+ , ("YYYYMMDDTHMIS", "20240315T222005")+ , ("YYYY-MM-DDTH:MI:S.msZ", "2024-03-15T22:20:05.637Z")+ , ("YYYY-MM-DDTH:MI:S.msZ", "2024-03-15T22:20:05.637123Z")+ , ("YYYY-MM-DDTH:MI:S.msZ", "2024-03-15T22:20:05.637123456Z")+ ]++ P.forM_ dateMap $ \(formatTxt, utcTxt) -> do+ case parseUtc utcTxt of+ Nothing -> P.die "Invalid UTC string"+ Just utcStamp ->+ let timeFmt = formatTxt & T.unpack & toFormat+ in (utcStamp & timePrint timeFmt)+ `shouldBe` T.unpack+ ( utcTxt+ & T.replace "123" ""+ & T.replace "456" ""+ )++ let+ utcTxt = "2024-03-15T22:20:05.386777444Z"+ printFmt = "YYYY-MM-DDTH:MI:S.ms" & T.unpack & toFormat+ -- Truncates microseconds and nanoseconds+ expected = "2024-03-15T22:20:05.386"++ (utcTxt & parseUtc <&> timePrint printFmt) `shouldBe` Just expected++ it "imports a JSON task and puts unused fields into metadata" $ do+ withMemoryDb conf $ \memConn -> do+ let+ jsonTask =+ "\+ \ { 'body': 'Just a test' \+ \ , 'utc': '2024-03-15T10:32:51.853Z' \+ \ , 'tags': ['one', 'two'] \+ \ , 'notes': ['first note', 'second note'] \+ \ , 'xxx': 'yyy' \+ \ } \+ \"+ & T.replace "'" "\""++ case eitherDecodeStrictText jsonTask of+ Left error ->+ P.die $ "Error decoding JSON: " <> show error+ Right importTaskRecord -> do+ _ <- insertImportTask conf memConn importTaskRecord+ tasks :: [FullTask] <- query_ memConn "SELECT * FROM tasks_view"+ case tasks of+ [insertedTask] -> do+ insertedTask.body `shouldBe` "Just a test"+ insertedTask.tags `shouldBe` Just ["one", "two"]+ insertedTask.metadata+ `shouldBe` Just (Object $ KeyMap.fromList [("xxx", "yyy")])+ _ -> P.die "More than one task found"++ taskToNotes :: [TaskToNote] <-+ query_ memConn "SELECT * FROM task_to_note"+ taskToNotes+ `shouldBe` [ TaskToNote+ { ulid = "01hs0tqwwd0006vtdjjey5vdae"+ , task_ulid = "01hs0tqwwd0004yy9et9d4wksy"+ , note = "first note"+ }+ , TaskToNote+ { ulid = "01hs0tqwwd0003pynthn2xpd5s"+ , task_ulid = "01hs0tqwwd0004yy9et9d4wksy"+ , note = "second note"+ }+ ]+ it "imports a JSON task with notes" $ do+ withMemoryDb conf $ \memConn -> do+ let jsonTask = "{\"body\":\"Just a test\", \"notes\":[\"A note\"]}"++ case eitherDecode jsonTask of+ Left error ->+ P.die $ "Error decoding JSON: " <> show error+ Right importTaskRecord -> do+ result <- insertImportTask conf memConn importTaskRecord++ unpack (show result)+ `shouldStartWith` "📥 Imported task \"Just a test\" with ulid "++ taskToNotes :: [TaskToNote] <-+ query_ memConn "SELECT * FROM task_to_note"+ case taskToNotes of+ [taskToNote] -> do+ taskToNote.ulid `shouldNotBe` ""+ taskToNote.task_ulid `shouldNotBe` ""+ taskToNote.note `shouldBe` "A note"+ _ -> P.die "More than one task_to_note row found"++ tasks :: [FullTask] <- query_ memConn "SELECT * FROM tasks_view"++ case tasks of+ [updatedTask] -> do+ updatedTask.ulid `shouldNotBe` ""+ updatedTask.modified_utc `shouldNotBe` ""+ updatedTask.user `shouldNotBe` ""+ updatedTask+ { FullTask.ulid = ""+ , FullTask.modified_utc = ""+ , FullTask.user = ""+ }+ `shouldBe` emptyFullTask+ { FullTask.body = "Just a test"+ , -- TODO: Fix after notes are returned as a JSON array+ FullTask.notes = Just []+ , FullTask.priority = Just 1.0+ , FullTask.metadata = case decode jsonTask of+ Just (Object keyMap) ->+ keyMap+ & KeyMap.delete "body"+ & KeyMap.delete "notes"+ & \kMap ->+ if KeyMap.null kMap+ then Nothing+ else Just $ Object kMap+ _ -> Nothing+ }+ _ -> P.die "More than one task found"++ it "imports a JSON task with an ISO8601 created_at field" $ do+ withMemoryDb conf $ \memConn -> do+ let+ utc = "2024-03-15T10:32:51.386777444Z"+ -- ULID only has millisecond precision:+ utcFromUlid = "2024-03-15 10:32:51.387"+ jsonTask =+ "{\"body\":\"Just a test\",\"created_at\":\"{{utc}}\"}"+ & T.replace "{{utc}}" utc++ case eitherDecodeStrictText jsonTask of+ Left error ->+ P.die $ "Error decoding JSON: " <> show error+ Right importTaskRecord -> do+ _ <- insertImportTask conf memConn importTaskRecord+ tasks :: [FullTask] <- query_ memConn "SELECT * FROM tasks_view"+ case tasks of+ [insertedTask] ->+ ulidText2utc insertedTask.ulid `shouldBe` Just utcFromUlid+ _ -> P.die "More than one task found"++ it "imports JSON task with notes and sets the created_utc for notes" $ do+ withMemoryDb conf $ \memConn -> do+ let+ utc = "2024-03-15 10:32:51"+ jsonTask =+ "{\"body\":\"Just a test\",\+ \\"created_at\":\"{{utc}}\",\+ \\"notes\": [\"Just a note\"]}"+ & T.replace "{{utc}}" utc++ expectedTaskToNote =+ TaskToNote+ { ulid =+ emptyUlid+ & P.flip setDateTime (utc & parseUtc & fromMaybe zeroTime)+ & show @ULID+ & T.toLower+ , task_ulid = "01hs0tqw1r0007h0mj78s1jntz"+ , note = "Just a note"+ }++ case eitherDecodeStrictText jsonTask of+ Left error ->+ P.die $ "Error decoding JSON: " <> show error+ Right importTaskRecord -> do+ _ <- insertImportTask conf memConn importTaskRecord+ taskToNoteList :: [TaskToNote] <-+ query_ memConn "SELECT * FROM task_to_note"+ case taskToNoteList of+ [taskToNote] -> do+ taskToNote.ulid `shouldNotBe` expectedTaskToNote.ulid+ (taskToNote.ulid & T.take 10)+ `shouldBe` (expectedTaskToNote.ulid & T.take 10)+ _ -> P.die "Found more than one note"++ it "imports a GitHub issue" $ do+ gitHubIssue <- BSL.readFile "test/fixtures/github-issue.json"+ withMemoryDb conf $ \memConn -> do+ let+ expectedImpTask =+ ImportTask+ { task =+ emptyTask+ { Task.ulid = "01hrz2qz7g0001qzskfchf4dek"+ , Task.body = "Support getting the note body from stdin"+ , Task.user = "ad-si"+ , Task.modified_utc = "2024-03-14 18:14:14.000"+ }+ , notes = []+ , tags = []+ }++ case eitherDecode gitHubIssue of+ Left error -> P.die $ "Error decoding JSON: " <> show error+ Right importTaskRecord -> do+ _ <- insertImportTask conf memConn importTaskRecord+ taskList :: [Task] <- query_ memConn "SELECT * FROM tasks"+ case taskList of+ [task] -> do+ task.ulid `shouldBe` expectedImpTask.task.ulid+ task.body `shouldBe` expectedImpTask.task.body+ task.user `shouldBe` expectedImpTask.task.user+ task.modified_utc `shouldBe` expectedImpTask.task.modified_utc+ _ -> P.die "Found more than one note"++ describe "Export" $ do+ it "exports several tasks as NDJSON including notes" $ do+ let+ task =+ emptyTask+ { Task.ulid = "01jczsz9c328fm7xydcwxbmv6n"+ , Task.body = "Buy milk"+ , Task.user = "ad-si"+ , Task.modified_utc = "2024-09-24 22:31:09.123"+ }++ importTask =+ ImportTask+ { task = task+ , notes = [Note "01jczszra25ec48pagzcw5qw6j" "Test note"]+ , tags = []+ }++ taskJson =+ "[{\+ \\"awake_utc\":null,\+ \\"body\":\"Buy milk\",\+ \\"closed_utc\":null,\+ \\"due_utc\":null,\+ \\"group_ulid\":null,\+ \\"metadata\":null,\+ \\"modified_utc\":\"2024-09-24 22:31:09.123\",\+ \\"notes\":[{\+ \\"body\":\"Test note\",\+ \\"ulid\":\"01jczsz9c35ec48pagzcw5qw6j\"\+ \}],\+ \\"priority\":1,\+ \\"ready_utc\":null,\+ \\"recurrence_duration\":null,\+ \\"repetition_duration\":null,\+ \\"review_utc\":null,\+ \\"state\":null,\+ \\"tags\":null,\+ \\"ulid\":\"01jczsz9c328fm7xydcwxbmv6n\",\+ \\"user\":\"ad-si\",\+ \\"waiting_utc\":null\+ \}]"++ res <- withMemoryDb conf $ \memConn -> do+ _ <- insertImportTask conf memConn importTask+ getNdjsonLines memConn++ (show res :: P.Text) `shouldBe` taskJson
test/LibSpec.hs view
@@ -1,132 +1,684 @@ module LibSpec where import Protolude (+ Bool (True),+ ExitCode (ExitFailure), Maybe (..), Text,+ isJust, pure, show, ($),+ (&),+ (/=),+ (<), (<>),+ (==), ) import Protolude qualified as P -import Config (defaultConfig)+import Control.Arrow ((>>>))+import Data.Aeson (decode)+import Data.List.Utils (subIndex)+import Data.Text (unpack)+import Data.Text qualified as T+import Data.Time.ISO8601.Duration qualified as Iso+import Database.SQLite.Simple (SQLData (SQLNull), query_) import Test.Hspec ( Spec,- describe,+ context, it, shouldBe, shouldContain, shouldEndWith,+ shouldNotBe, shouldNotContain,+ shouldNotSatisfy,+ shouldSatisfy,+ shouldStartWith,+ shouldThrow, ) -import Data.Hourglass (DateTime)-import Data.Text qualified as T-import ImportExport (PreEdit (ApplyPreEdit), editTaskByTask)-import Lib (addTag, countTasks, deleteNote, insertRecord, insertTags, newTasks)-import Task (Task (body, closed_utc, state, ulid), TaskState (Done), zeroTask)-import TaskToNote (TaskToNote (TaskToNote))+import Config (defaultConfig)+import Data.Hourglass (TimeFormat (..), timePrint)+import FullTask (FullTask, emptyFullTask)+import FullTask qualified+import ImportExport (EditMode (ApplyPreEdit), editTaskByTask)+import Lib (+ addNote,+ addTag,+ addTask,+ countTasks,+ deleteNote,+ deleteTag,+ deleteTasks,+ doTasks,+ duplicateTasks,+ headTasks,+ infoTask,+ insertRecord,+ insertTags,+ listNotes,+ logTask,+ newTasks,+ nextTask,+ recurTasks,+ repeatTasks,+ runFilter,+ setDueUtc,+ setReadyUtc,+ unrepeatTasks,+ updateTask,+ )+import Note (Note)+import System.Hourglass (dateCurrent)+import Task (+ Task (+ body,+ closed_utc,+ due_utc,+ group_ulid,+ metadata,+ modified_utc,+ ready_utc,+ repetition_duration,+ state,+ ulid,+ user+ ),+ TaskState (Done),+ emptyTask,+ )+import TaskToNote (TaskToNote (TaskToNote, ulid)) import TaskToNote qualified+import TaskToTag (TaskToTag)+import TaskToTag qualified import TestUtils (withMemoryDb)+import Utils (parseUtc, zeroTime, zeroUlidTxt) +exampleTask :: Task+exampleTask =+ emptyTask+ { Task.ulid = "01hq68smfe0r9entg3x4rb9441"+ , Task.body = "Buy milk"+ , Task.state = Nothing+ , Task.modified_utc = "2024-02-21 16:43:17"+ , Task.due_utc = Just "2025-07-08 10:22:56"+ , Task.user = "john_vdg1c2hz"+ , Task.metadata = "{\"source\":\"fridge\"}" & decode+ }++ task1 :: Task task1 =- zeroTask- { ulid = "01hs68z7mdg4ktpxbv0yfafznq"- , body = "New task 1"+ emptyTask+ { Task.ulid = "01hs68z7mdg4ktpxbv0yfafznq"+ , Task.body = "New task 1"+ , Task.modified_utc = "2024-03-17 13:17:44.461" } -spec :: DateTime -> Spec-spec now = do- describe "Lib" $ do- it "counts tasks" $ do- withMemoryDb defaultConfig $ \memConn -> do- let- task2 =- zeroTask- { ulid = "01hs690f9hkzk9z7zews9j2k1d"- , body = "New task 2"+taskMultiLine :: Task+taskMultiLine =+ emptyTask+ { Task.ulid = "01hx48cnjhp18mts3c44zk3gen"+ , Task.body =+ "New task\n\+ \with several lines\n\+ \and line breaks"+ }+++normTask :: Task -> Task+normTask task =+ task+ { Task.ulid = ""+ , Task.modified_utc = ""+ , Task.due_utc = Nothing+ , Task.user = ""+ }+++replaceBs :: P.ByteString -> P.ByteString -> P.ByteString -> P.ByteString+replaceBs needle replacement haystack = do+ haystack+ & P.decodeUtf8+ & T.replace (P.decodeUtf8 needle) (P.decodeUtf8 replacement)+ & P.encodeUtf8+++spec :: Spec+spec = do+ let+ now = "2024-05-08 10:04:17" & parseUtc & P.fromMaybe zeroTime+ conf = defaultConfig++ it "initially contains no tasks" $ do+ withMemoryDb conf $ \memConn -> do+ tasks <- headTasks conf now memConn Nothing+ unpack (show tasks) `shouldStartWith` "No tasks available"++ it "inserts a task" $ do+ withMemoryDb conf $ \memConn -> do+ let task =+ emptyTask+ { Task.ulid = "01hrvhc0h1pncbczxym16642mm"+ , Task.body = "Directly inserted task"+ , Task.state = Just Done } - count0 <- countTasks defaultConfig memConn P.mempty- show count0 `shouldBe` ("0" :: Text)+ insertRecord "tasks" memConn task+ tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"+ tasks `shouldBe` [task] - insertRecord "tasks" memConn task1- count1 <- countTasks defaultConfig memConn P.mempty- show count1 `shouldBe` ("1" :: Text)+ it "adds a new task" $ do+ withMemoryDb conf $ \memConn -> do+ result <- addTask conf memConn ["Just a test"]+ unpack (show result)+ `shouldStartWith` "🆕 Added task \"Just a test\" with id" - insertRecord "tasks" memConn task2- count2 <- countTasks defaultConfig memConn P.mempty- show count2 `shouldBe` ("2" :: Text)+ context "When a task exists" $ do+ it "updates a task" $ do+ withMemoryDb conf $ \memConn -> do+ let initialTask =+ emptyTask+ { Task.ulid = "01hrvhdddfwsrnp6dd8h7tp8h4"+ , Task.body = "New task"+ , Task.state = Just Done+ }+ newTask = initialTask{body = "Updated task"} - warnings <- insertTags memConn Nothing task2 ["test"]- P.show warnings `shouldBe` T.empty- countWithTag <- countTasks defaultConfig memConn (Just ["+test"])- show countWithTag `shouldBe` ("1" :: Text)+ insertRecord "tasks" memConn initialTask+ updateTask memConn newTask+ tasks :: [Task] <- query_ memConn "SELECT * FROM tasks" - pure ()+ case tasks of+ [updatedTask] -> do+ -- Task should have a different `modified_utc` value+ updatedTask `shouldSatisfy` (\task -> task.modified_utc /= "")+ updatedTask{modified_utc = ""} `shouldBe` newTask+ _ ->+ P.die "Found more than one task" - it "gets new tasks" $ do- withMemoryDb defaultConfig $ \memConn -> do+ it "lists next task" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ result <- nextTask conf memConn+ unpack (show result) `shouldContain` "Buy milk"++ it "adds a tag" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ tagResult <- addTag conf memConn "test" [exampleTask.ulid]+ unpack (show tagResult)+ `shouldStartWith` "🏷 Added tag \"test\" to task"+ taskToTags :: [TaskToTag] <-+ query_ memConn "SELECT * FROM task_to_tag"+ case taskToTags of+ [taskToTag] -> do+ taskToTag.ulid `shouldNotBe` ""+ taskToTag.task_ulid `shouldNotBe` ""+ taskToTag.tag `shouldBe` "test"+ _ -> P.die "More than one task_to_tag row found"++ it "strips leading + when adding a tag" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ tagResult <- addTag conf memConn "+test" [exampleTask.ulid]+ unpack (show tagResult)+ `shouldStartWith` "🏷 Added tag \"test\" to task"+ taskToTags :: [TaskToTag] <-+ query_ memConn "SELECT * FROM task_to_tag"+ case taskToTags of+ [taskToTag] -> taskToTag.tag `shouldBe` "test"+ _ -> P.die "More than one task_to_tag row found"++ it "deletes a tag" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ _ <- addTag conf memConn "test" [exampleTask.ulid]+ delResult <- deleteTag conf memConn "test" [exampleTask.ulid]+ unpack (show delResult)+ `shouldStartWith` "💥 Removed tag \"test\" of task"+ taskToTags :: [TaskToTag] <-+ query_ memConn "SELECT * FROM task_to_tag"+ taskToTags `shouldBe` []++ it "doesn't delete a tag that does not exist" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ delResult <- deleteTag conf memConn "test" [exampleTask.ulid]+ unpack (show delResult) `shouldContain` "not set"++ it "adds a note" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ noteResult <- addNote conf memConn "A test note" [exampleTask.ulid]+ unpack (show noteResult)+ `shouldStartWith` "🗒 Added a note to task"++ -- it "correctly wraps multiline notes" $ do+ -- See error:+ -- tl info x795vqf++ it "sets due UTC" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ let utcTxt = "2087-03-21 17:43:00"+ case parseUtc utcTxt of+ Nothing -> P.die "Invalid UTC string"+ Just utcStamp -> do+ result <- setDueUtc conf memConn utcStamp [exampleTask.ulid]+ unpack (show result)+ `shouldStartWith` ( "📅 Set due UTC of task \""+ <> T.unpack exampleTask.body+ <> "\" with id \""+ <> T.unpack exampleTask.ulid+ <> "\" to \""+ <> T.unpack utcTxt+ <> "\""+ )++ it "sets ready UTC" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ let utcTxt = "2059-07-11 04:55:16"+ case parseUtc utcTxt of+ Nothing -> P.die "Invalid UTC string"+ Just utcStamp -> do+ result <- setReadyUtc conf memConn utcStamp [exampleTask.ulid]+ unpack (show result)+ `shouldStartWith` ( "📅 Set ready UTC of task \""+ <> T.unpack exampleTask.body+ <> "\" with id \""+ <> T.unpack exampleTask.ulid+ <> "\" to \""+ <> T.unpack utcTxt+ <> "\""+ )+ tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"+ case tasks of+ [updatedTask] -> do+ updatedTask `shouldSatisfy` (\task -> isJust task.ready_utc)+ _ -> P.die "Found more than one task"++ it "completes it" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ doResult <- doTasks conf memConn Nothing [exampleTask.ulid]+ unpack (show doResult) `shouldStartWith` "✅ Finished task"+ tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"+ case tasks of+ [updatedTask] -> do+ updatedTask `shouldSatisfy` (\task -> task.state == Just Done)+ updatedTask `shouldSatisfy` (\task -> isJust task.closed_utc)+ _ -> P.die "Found more than one task"++ it "deletes it" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ deleteResult <- deleteTasks conf memConn [exampleTask.ulid]+ unpack (show deleteResult) `shouldStartWith` "❌ Deleted task"+ tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"+ tasks `shouldBe` []+ tags :: [TaskToTag] <- query_ memConn "SELECT * FROM task_to_tag"+ tags `shouldBe` []+ notes :: [Note] <- query_ memConn "SELECT * FROM task_to_note"+ notes `shouldBe` []++ it "duplicates a task" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask+ duplicationResult <- duplicateTasks conf memConn [exampleTask.ulid]+ unpack (show duplicationResult)+ `shouldStartWith` "👯 Created a duplicate of task \"Buy milk\""+ tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"+ case tasks of+ [taskA, taskB] -> do+ normTask taskA `shouldBe` normTask exampleTask+ normTask taskB `shouldBe` normTask exampleTask+ _ -> P.die "Must have exactly two tasks"++ it "deletes obsolete fields on duplication" $ do+ withMemoryDb conf $ \memConn -> do+ insertRecord "tasks" memConn exampleTask let- task2 =- zeroTask- { ulid = "01hs6zsf3c0vqx6egfnmbqtmvy"- , body = "New task 2"- , closed_utc = Just "2024-04-10T18:54:10Z"- , state = Just Done+ zeroDur = Iso.DurationWeek (Iso.DurWeek 0)+ oneMonth = "P1M" & Iso.parseDuration & P.fromRight zeroDur+ _ <- repeatTasks conf memConn oneMonth [exampleTask.ulid]+ _ <- duplicateTasks conf memConn [exampleTask.ulid]+ tasks :: [Task] <-+ query_ memConn "SELECT * FROM tasks ORDER BY ulid DESC"+ case tasks of+ [dupe, original] -> do+ original.group_ulid `shouldSatisfy` P.isJust+ original.repetition_duration `shouldSatisfy` P.isJust+ dupe.group_ulid `shouldSatisfy` P.isNothing+ dupe.repetition_duration `shouldSatisfy` P.isNothing+ dupe.user `shouldNotBe` original.user+ normTask dupe `shouldBe` normTask exampleTask+ _ -> P.die "Must have exactly two tasks"++ it "adds a task with tags and due date" $ do+ withMemoryDb conf $ \memConn -> do+ _ <- addTask conf memConn ["Just a test +tag due:2082-10-03 +what"]+ (tasks :: [FullTask]) <- query_ memConn "SELECT * FROM tasks_view"+ case tasks of+ [updatedTask] -> do+ updatedTask `shouldSatisfy` (\task -> task.ulid /= "")+ updatedTask `shouldSatisfy` (\task -> task.modified_utc /= "")+ updatedTask `shouldSatisfy` (\task -> task.user /= "")+ updatedTask+ { FullTask.ulid = ""+ , FullTask.modified_utc = ""+ , FullTask.user = ""+ }+ `shouldBe` emptyFullTask+ { FullTask.body = "Just a test"+ , FullTask.due_utc = Just "2082-10-03 00:00:00"+ , FullTask.priority = Just 2.0+ , FullTask.tags = Just ["tag", "what"] }+ _ -> P.die "Found more than one task" - insertRecord "tasks" memConn task1- insertRecord "tasks" memConn task2+ it "deduplicates tags when adding a task" $ do+ withMemoryDb conf $ \memConn -> do+ _ <- addTask conf memConn ["Buy milk +drink +drink"]+ (tasks :: [FullTask]) <- query_ memConn "SELECT * FROM tasks_view"+ case tasks of+ [updatedTask] -> do+ updatedTask `shouldSatisfy` (\task -> task.ulid /= "")+ updatedTask `shouldSatisfy` (\task -> task.modified_utc /= "")+ updatedTask `shouldSatisfy` (\task -> task.user /= "")+ updatedTask+ { FullTask.ulid = ""+ , FullTask.modified_utc = ""+ , FullTask.user = ""+ }+ `shouldBe` emptyFullTask+ { FullTask.body = "Buy milk"+ , FullTask.priority = Just 2.0+ , FullTask.tags = Just ["drink"]+ }+ _ -> P.die "Found more than one task" - cliOutput <- newTasks defaultConfig now memConn (Just ["state:done"])- show cliOutput `shouldContain` "New task 2"- show cliOutput `shouldNotContain` "New task 1"+ it "logs a task" $ do+ withMemoryDb conf $ \memConn -> do+ result <- logTask conf memConn ["Just a test"]+ unpack (show result)+ `shouldStartWith` "📝 Logged task \"Just a test\" with id" - it "shows warning if a tag is duplicated" $ do- withMemoryDb defaultConfig $ \memConn -> do- let newTag = "test"- insertRecord "tasks" memConn task1- warnings <- insertTags memConn Nothing task1 [newTag]- P.show warnings `shouldBe` T.empty+ it "dies on invalid filter expressions" $ do+ withMemoryDb conf $ \memConn -> do+ runFilter conf now memConn [" "] Nothing `shouldThrow` (== ExitFailure 1) - cliOutput <- addTag defaultConfig memConn newTag [task1.ulid]- show cliOutput `shouldEndWith` "Tag \"test\" is already assigned"+ it "counts tasks" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ let+ task2 =+ emptyTask+ { Task.ulid = "01hs690f9hkzk9z7zews9j2k1d"+ , Task.body = "New task 2"+ } - it "lets you edit a task and shows warning if a tag was duplicated" $ do+ count0 <- countTasks defaultConfig memConn P.mempty+ show count0 `shouldBe` ("0" :: Text)++ insertRecord "tasks" memConn task1+ count1 <- countTasks defaultConfig memConn P.mempty+ show count1 `shouldBe` ("1" :: Text)++ insertRecord "tasks" memConn task2+ count2 <- countTasks defaultConfig memConn P.mempty+ show count2 `shouldBe` ("2" :: Text)++ warnings <- insertTags conf memConn Nothing task2 ["test"]+ P.show warnings `shouldBe` T.empty+ countWithTag <- countTasks defaultConfig memConn (Just ["+test"])+ show countWithTag `shouldBe` ("1" :: Text)++ pure ()++ it "gets new tasks" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ let+ task2 =+ emptyTask+ { Task.ulid = "01hs6zsf3c0vqx6egfnmbqtmvy"+ , Task.body = "New task 2"+ , Task.closed_utc = Just "2024-04-10T18:54:10Z"+ , Task.state = Just Done+ }++ insertRecord "tasks" memConn task1+ insertRecord "tasks" memConn task2++ cliOutput <- newTasks defaultConfig now memConn (Just ["state:done"]) Nothing+ show cliOutput `shouldContain` "New task 2"+ show cliOutput `shouldNotContain` "New task 1"++ it "shows warning if a tag is duplicated" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ let newTag = "test"+ insertRecord "tasks" memConn task1+ warnings <- insertTags conf memConn Nothing task1 [newTag]+ P.show warnings `shouldBe` T.empty++ cliOutput <- addTag defaultConfig memConn newTag [task1.ulid]+ show cliOutput `shouldEndWith` "Tag \"test\" is already assigned"++ it "repeats a task and prevents recurring same task" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ insertRecord "tasks" memConn task1+ let oneWeek = Iso.DurationWeek (Iso.DurWeek 1)+ repeatRes <- repeatTasks defaultConfig memConn oneWeek [task1.ulid]+ P.show repeatRes `shouldContain` "Set repeat duration of task"++ recurRes <- recurTasks defaultConfig memConn oneWeek [task1.ulid]+ P.show recurRes `shouldContain` "is already in a repetition series"++ unrepeatRes <- unrepeatTasks defaultConfig memConn [task1.ulid]+ P.show unrepeatRes `shouldContain` "Removed repetition duration"++ recurRes2 <- recurTasks defaultConfig memConn oneWeek [task1.ulid]+ P.show recurRes2 `shouldContain` "Set recurrence duration of task"++ repeatRes2 <- repeatTasks defaultConfig memConn oneWeek [task1.ulid]+ P.show repeatRes2 `shouldContain` "is already in a recurrence series"++ context "Editing a task" $ do+ it "shows warning if a tag was duplicated" $ do withMemoryDb defaultConfig $ \memConn -> do let existTag = "existing-tag" insertRecord "tasks" memConn task1- warnings <- insertTags memConn Nothing task1 [existTag]+ warnings <- insertTags conf memConn Nothing task1 [existTag] P.show warnings `shouldBe` T.empty- cliOutput <- editTaskByTask- (ApplyPreEdit (<> ("\ntags: " <> P.show [existTag, "new-tag"])))+ conf+ ( ApplyPreEdit $+ replaceBs+ "\n...\n"+ ("\ntags: " <> P.show [existTag, "new-tag"] <> "\n...\n")+ ) memConn task1 let errMsg = "Tag \"" <> T.unpack existTag <> "\" is already assigned" show cliOutput `shouldContain` errMsg - it "lets you delete a note" $ do+ it "lets you change the closed_utc" $ do withMemoryDb defaultConfig $ \memConn -> do insertRecord "tasks" memConn task1- let noteId = "01hwcqk9nnwjypzw9kr646nqce"++ cliOutput <-+ editTaskByTask+ conf+ ( ApplyPreEdit $+ replaceBs+ "state: null"+ "state: Done"+ >>> replaceBs+ "closed_utc: null"+ "closed_utc: 2024-05-08 10:04"+ )+ memConn+ task1+ show cliOutput `shouldContain` "Edited task"+ tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"+ case tasks of+ [task] -> do+ task.closed_utc `shouldBe` Just "2024-05-08 10:04:00.000"+ task.state `shouldBe` Just Done+ now_ <- dateCurrent+ let today = now_ & timePrint (toFormat ("YYYY-MM-DD" :: [P.Char]))+ T.unpack task.modified_utc `shouldStartWith` today+ _ -> P.die "Found more than one task"++ it "lets you add notes" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ insertRecord "tasks" memConn task1+ cliOutput <-+ editTaskByTask+ conf+ ( ApplyPreEdit $+ replaceBs+ "\n...\n"+ ("\nnotes: " <> P.show ["A short note" :: Text] <> "\n...\n")+ )+ memConn+ task1+ show cliOutput `shouldStartWith` "✏️ Edited task \"New task 1\""++ taskToNotes :: [TaskToNote] <-+ query_ memConn "SELECT * FROM task_to_note"+ case taskToNotes of+ [taskToNote] -> do+ taskToNote.ulid+ `shouldNotSatisfy` (\ulid -> zeroUlidTxt `T.isPrefixOf` ulid)+ taskToNote.note `shouldBe` "A short note"+ _ -> P.die "Found more than one task_to_tag row"++ it "de-duplicates notes" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ insertRecord "tasks" memConn task1+ let note = "A short note" insertRecord "task_to_note" memConn TaskToNote- { TaskToNote.ulid = noteId+ { TaskToNote.ulid = "01hxsjgzmdx48yzk39v852razr" , TaskToNote.task_ulid = task1.ulid- , TaskToNote.note = "The note content"+ , TaskToNote.note = note }+ taskInfo <- infoTask defaultConfig memConn task1.ulid+ show taskInfo `shouldContain` T.unpack note+ cliOutput <-+ editTaskByTask+ conf+ ( ApplyPreEdit $+ replaceBs "notes: []" $+ "notes: " <> P.show [note, note]+ )+ memConn+ task1+ show cliOutput `shouldStartWith` "✏️ Edited task \"New task 1\"" - cliOutput <- deleteNote defaultConfig memConn noteId+ taskToNotes :: [TaskToNote] <-+ query_ memConn "SELECT * FROM task_to_note"+ case taskToNotes of+ [taskToNoteA, taskToNoteB] -> do+ taskToNoteA.ulid+ `shouldNotSatisfy` (\ulid -> zeroUlidTxt `T.isPrefixOf` ulid)+ taskToNoteB.ulid+ `shouldNotSatisfy` (\ulid -> zeroUlidTxt `T.isPrefixOf` ulid)+ taskToNoteA.note `shouldBe` "A short note"+ taskToNoteB.note `shouldBe` "A short note"+ _ -> P.die "Found more than one task_to_tag row" - (show cliOutput :: Text)- `shouldBe` "\128165 Deleted note \"01hwcqk9nnwjypzw9kr646nqce\" \- \of task \"01hs68z7mdg4ktpxbv0yfafznq\""+ it "lets you set metadata to null" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ insertRecord "tasks" memConn task1{metadata = Just "{\"a\":\"b\"}"}+ cliOutput <-+ editTaskByTask+ conf+ (ApplyPreEdit $ replaceBs "\n...\n" "\nmetadata: null\n...\n")+ memConn+ task1+ show cliOutput `shouldStartWith` "✏️ Edited task \"New task 1\""+ tasks :: [[SQLData]] <- query_ memConn "SELECT metadata FROM tasks"+ case tasks of+ [[metadata]] -> do+ metadata `shouldBe` SQLNull+ _ -> P.die "Found more than one task"++ it "only shows first line of multi-line tasks in task listing" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ insertRecord "tasks" memConn taskMultiLine++ tasks <- headTasks conf now memConn Nothing+ show tasks `shouldContain` "New task ▼"+ show tasks `shouldNotContain` "with several lines"++ it "keeps line breaks of multi-line tasks in info view" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ insertRecord "tasks" memConn taskMultiLine++ cliOutput <- infoTask defaultConfig memConn taskMultiLine.ulid+ show cliOutput+ `shouldContain` "New task\n\+ \with several lines\n\+ \and line breaks"++ it "lists all notes descending by creation UTC" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ insertRecord "tasks" memConn task1+ let+ taskToNote1 =+ TaskToNote+ { TaskToNote.ulid = "01hx4eyxxvs5b75ynxrztcz87f"+ , TaskToNote.task_ulid = task1.ulid+ , TaskToNote.note = "The first note"+ }+ note1Id = taskToNote1.ulid & T.takeEnd 3 & T.unpack+ taskToNote2 =+ TaskToNote+ { TaskToNote.ulid = "01hx4f3f764sma7n8bahvwjeed"+ , TaskToNote.task_ulid = task1.ulid+ , TaskToNote.note = "The second note"+ }+ note2Id = taskToNote2.ulid & T.takeEnd 3 & T.unpack++ insertRecord "task_to_note" memConn taskToNote1+ insertRecord "task_to_note" memConn taskToNote2++ cliOutput <- listNotes defaultConfig memConn++ show cliOutput `shouldContain` note1Id+ show cliOutput `shouldContain` note2Id++ let+ posUlid1 = subIndex note1Id (show cliOutput)+ posUlid2 = subIndex note2Id (show cliOutput)++ -- Newer notes should be listed first+ (posUlid2 < posUlid1) `shouldBe` True++ it "lets you delete a note" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ insertRecord "tasks" memConn task1+ let noteId = "01hwcqk9nnwjypzw9kr646nqce"+ insertRecord+ "task_to_note"+ memConn+ TaskToNote+ { TaskToNote.ulid = noteId+ , TaskToNote.task_ulid = task1.ulid+ , TaskToNote.note = "The note content"+ }++ cliOutput <- deleteNote defaultConfig memConn noteId++ (show cliOutput :: Text)+ `shouldBe` "\128165 Deleted note \"01hwcqk9nnwjypzw9kr646nqce\" \+ \of task \"01hs68z7mdg4ktpxbv0yfafznq\""
+ test/MigrationsSpec.hs view
@@ -0,0 +1,22 @@+module MigrationsSpec where++import Protolude (show, ($))++import Data.Text (unpack)+import Database.SQLite.Simple qualified as Sql+import Test.Hspec (+ Spec,+ it,+ shouldStartWith,+ )++import Config (defaultConfig)+import Migrations (runMigrations)+++spec :: Spec+spec = do+ it "creates tables on initial run migrates tables to latest version" $ do+ Sql.withConnection ":memory:" $ \memConn -> do+ migrationStatus <- runMigrations defaultConfig memConn+ unpack (show migrationStatus) `shouldStartWith` "Migration succeeded"
test/Spec.hs view
@@ -1,445 +1,2 @@-import Protolude (- Either (Left, Right),- Eq ((==)),- ExitCode (ExitFailure),- Functor (fmap),- IO,- Maybe (..),- Text,- isJust,- show,- ($),- (&),- (/=),- (<&>),- (<>),- )-import Protolude qualified as P--import Data.Aeson (decode, eitherDecode, eitherDecodeStrictText)-import Data.Hourglass (- DateTime,- Elapsed (Elapsed),- ElapsedP (ElapsedP),- Time (timeFromElapsedP),- timeGetDateTimeOfDay,- timePrint,- toFormat,- )-import Data.Text (unpack)-import Data.Text qualified as T-import Database.SQLite.Simple (query_)-import Database.SQLite.Simple qualified as Sql-import Test.Hspec (- SpecWith,- context,- describe,- hspec,- it,- shouldBe,- shouldContain,- shouldSatisfy,- shouldStartWith,- shouldThrow,- )-import Time.System (timeCurrentP)--import Config (Config (..), defaultConfig)-import FullTask (FullTask, emptyFullTask)-import FullTask qualified-import ImportExport (insertImportTask)-import Lib (- addNote,- addTag,- addTask,- deleteTag,- deleteTasks,- doTasks,- headTasks,- insertRecord,- logTask,- nextTask,- runFilter,- setDueUtc,- setReadyUtc,- updateTask,- )-import LibSpec qualified-import Migrations (runMigrations)-import Note (Note)-import Task (- Task (- body,- closed_utc,- due_utc,- metadata,- modified_utc,- ready_utc,- state,- ulid,- user- ),- TaskState (Done),- zeroTask,- )-import TaskToNote (TaskToNote)-import TaskToNote qualified-import TaskToTag (TaskToTag)-import TaskToTag qualified-import TestUtils (withMemoryDb)-import TypesSpec qualified-import Utils (parseUlidText, parseUlidUtcSection, parseUtc, ulid2utc)---exampleTask :: Task-exampleTask =- zeroTask- { ulid = "01hq68smfe0r9entg3x4rb9441"- , body = "Buy milk"- , state = Nothing- , modified_utc = "2024-02-21 16:43:17"- , due_utc = Just "2025-07-08 10:22:56"- , user = "john"- , metadata = "{\"source\":\"fridge\"}" & decode- }---testSuite :: Config -> DateTime -> SpecWith ()-testSuite conf now = do- describe "Utils" $ do- it "correctly parses beginning of UNIX epoch" $- do- parseUlidUtcSection "0000000000"- `shouldBe` Just (timeGetDateTimeOfDay $ Elapsed 0)-- it "correctly parses 36 ms after UNIX epoch" $- do- parseUlidUtcSection "0000000014"- `shouldBe` Just (timeGetDateTimeOfDay $ ElapsedP 0 36000000)-- it "correctly parses a ULID string" $ do- let ulidText = "0000000014T4R3JR7HMQNREEW8" :: Text-- fmap show (parseUlidText ulidText) `shouldBe` Just ulidText-- describe "TaskLite" $ do- it "creates tables on initial run migrates tables to latest version" $ do- Sql.withConnection ":memory:" $ \memConn -> do- migrationStatus <- runMigrations conf memConn- unpack (show migrationStatus) `shouldStartWith` "Migration succeeded"-- it "initially contains no tasks" $ do- withMemoryDb conf $ \memConn -> do- tasks <- headTasks conf now memConn- unpack (show tasks) `shouldStartWith` "No tasks available"-- it "inserts a task" $ do- withMemoryDb conf $ \memConn -> do- let task =- zeroTask- { ulid = "01hrvhc0h1pncbczxym16642mm"- , body = "Directly inserted task"- , state = Just Done- }-- insertRecord "tasks" memConn task- tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"- tasks `shouldBe` [task]-- it "adds a new task" $ do- withMemoryDb conf $ \memConn -> do- result <- addTask conf memConn ["Just a test"]- unpack (show result)- `shouldStartWith` "🆕 Added task \"Just a test\" with id"-- context "When a task exists" $ do- it "updates a task" $ do- withMemoryDb conf $ \memConn -> do- let initialTask =- zeroTask- { ulid = "01hrvhdddfwsrnp6dd8h7tp8h4"- , body = "New task"- , state = Just Done- }- newTask = initialTask{body = "Updated task"}-- insertRecord "tasks" memConn initialTask- updateTask memConn newTask- tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"-- case tasks of- [updatedTask] -> do- -- Task should have a different `modified_utc` value- updatedTask `shouldSatisfy` (\task -> task.modified_utc /= "")- updatedTask{modified_utc = ""} `shouldBe` newTask- _ ->- P.die "More than one task found"-- it "lists next task" $ do- withMemoryDb conf $ \memConn -> do- insertRecord "tasks" memConn exampleTask- result <- nextTask conf memConn- unpack (show result) `shouldContain` "Buy milk"-- it "adds a tag" $ do- withMemoryDb conf $ \memConn -> do- insertRecord "tasks" memConn exampleTask- tagResult <- addTag conf memConn "test" [exampleTask.ulid]- unpack (show tagResult)- `shouldStartWith` "🏷 Added tag \"test\" to task"- taskToTags :: [TaskToTag] <-- query_ memConn "SELECT * FROM task_to_tag"- case taskToTags of- [taskToTag] -> do- taskToTag `shouldSatisfy` (\t -> t.ulid /= "")- taskToTag `shouldSatisfy` (\t -> t.task_ulid /= "")- taskToTag `shouldSatisfy` (\t -> t.tag == "test")- _ -> P.die "More than one task_to_tag row found"-- it "deletes a tag" $ do- withMemoryDb conf $ \memConn -> do- insertRecord "tasks" memConn exampleTask- _ <- addTag conf memConn "test" [exampleTask.ulid]- delResult <- deleteTag conf memConn "test" [exampleTask.ulid]- unpack (show delResult)- `shouldStartWith` "💥 Removed tag \"test\" of task"- taskToTags :: [TaskToTag] <-- query_ memConn "SELECT * FROM task_to_tag"- taskToTags `shouldBe` []-- it "adds a note" $ do- withMemoryDb conf $ \memConn -> do- insertRecord "tasks" memConn exampleTask- noteResult <- addNote conf memConn "A test note" [exampleTask.ulid]- unpack (show noteResult)- `shouldStartWith` "🗒 Added a note to task"-- it "sets due UTC" $ do- withMemoryDb conf $ \memConn -> do- insertRecord "tasks" memConn exampleTask- let utcTxt = "2087-03-21 17:43:00"- case parseUtc utcTxt of- Nothing -> P.die "Invalid UTC string"- Just utcStamp -> do- result <- setDueUtc conf memConn utcStamp [exampleTask.ulid]- unpack (show result)- `shouldStartWith` ( "📅 Set due UTC of task \""- <> T.unpack exampleTask.body- <> "\" with id \""- <> T.unpack exampleTask.ulid- <> "\" to \""- <> T.unpack utcTxt- <> "\""- )-- it "sets ready UTC" $ do- withMemoryDb conf $ \memConn -> do- insertRecord "tasks" memConn exampleTask- let utcTxt = "2059-07-11 04:55:16"- case parseUtc utcTxt of- Nothing -> P.die "Invalid UTC string"- Just utcStamp -> do- result <- setReadyUtc conf memConn utcStamp [exampleTask.ulid]- unpack (show result)- `shouldStartWith` ( "📅 Set ready UTC of task \""- <> T.unpack exampleTask.body- <> "\" with id \""- <> T.unpack exampleTask.ulid- <> "\" to \""- <> T.unpack utcTxt- <> "\""- )- tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"- case tasks of- [updatedTask] -> do- updatedTask `shouldSatisfy` (\task -> isJust task.ready_utc)- _ -> P.die "More than one task found"-- it "completes it" $ do- withMemoryDb conf $ \memConn -> do- insertRecord "tasks" memConn exampleTask- doResult <- doTasks conf memConn Nothing [exampleTask.ulid]- unpack (show doResult) `shouldStartWith` "✅ Finished task"- tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"- case tasks of- [updatedTask] -> do- updatedTask `shouldSatisfy` (\task -> task.state == Just Done)- updatedTask `shouldSatisfy` (\task -> isJust task.closed_utc)- _ -> P.die "More than one task found"-- it "deletes it" $ do- withMemoryDb conf $ \memConn -> do- insertRecord "tasks" memConn exampleTask- deleteResult <- deleteTasks conf memConn [exampleTask.ulid]- unpack (show deleteResult) `shouldStartWith` "❌ Deleted task"- tasks :: [Task] <- query_ memConn "SELECT * FROM tasks"- tasks `shouldBe` []- tags :: [TaskToTag] <- query_ memConn "SELECT * FROM task_to_tag"- tags `shouldBe` []- notes :: [Note] <- query_ memConn "SELECT * FROM task_to_note"- notes `shouldBe` []-- it "adds a task with tags and due date" $ do- withMemoryDb conf $ \memConn -> do- _ <- addTask conf memConn ["Just a test +tag due:2082-10-03 +what"]- (tasks :: [FullTask]) <- query_ memConn "SELECT * FROM tasks_view"- case tasks of- [updatedTask] -> do- updatedTask `shouldSatisfy` (\task -> task.ulid /= "")- updatedTask `shouldSatisfy` (\task -> task.modified_utc /= "")- updatedTask `shouldSatisfy` (\task -> task.user /= "")- updatedTask- { FullTask.ulid = ""- , FullTask.modified_utc = ""- , FullTask.user = ""- }- `shouldBe` emptyFullTask- { FullTask.body = "Just a test"- , FullTask.due_utc = Just "2082-10-03 00:00:00"- , FullTask.priority = Just 2.0- , FullTask.tags = Just ["tag", "what"]- }- _ -> P.die "More than one task found"-- it "deduplicates tags when adding a task" $ do- withMemoryDb conf $ \memConn -> do- _ <- addTask conf memConn ["Buy milk +drink +drink"]- (tasks :: [FullTask]) <- query_ memConn "SELECT * FROM tasks_view"- case tasks of- [updatedTask] -> do- updatedTask `shouldSatisfy` (\task -> task.ulid /= "")- updatedTask `shouldSatisfy` (\task -> task.modified_utc /= "")- updatedTask `shouldSatisfy` (\task -> task.user /= "")- updatedTask- { FullTask.ulid = ""- , FullTask.modified_utc = ""- , FullTask.user = ""- }- `shouldBe` emptyFullTask- { FullTask.body = "Buy milk"- , FullTask.priority = Just 2.0- , FullTask.tags = Just ["drink"]- }- _ -> P.die "More than one task found"-- it "logs a task" $ do- withMemoryDb conf $ \memConn -> do- result <- logTask conf memConn ["Just a test"]- unpack (show result)- `shouldStartWith` "📝 Logged task \"Just a test\" with id"-- it "dies on invalid filter expressions" $ do- withMemoryDb conf $ \memConn -> do- runFilter conf now memConn [" "] `shouldThrow` (== ExitFailure 1)-- describe "Import & Export" $ do- it "parses any sensible datetime string" $ do- -- TODO: Maybe keep microseconds and nanoseconds- -- , ("YYYY-MM-DDTH:MI:S.msusZ", "2024-03-15T22:20:05.637913Z")- -- , ("YYYY-MM-DDTH:MI:S.msusnsZ", "2024-03-15T22:20:05.637913438Z")-- let dateMap :: [(Text, Text)] =- [ ("YYYY-MM-DD", "2024-03-15")- , ("YYYY-MM-DD H:MI", "2024-03-15 22:20")- , ("YYYY-MM-DDTH:MIZ", "2024-03-15T22:20Z")- , ("YYYY-MM-DD H:MI:S", "2024-03-15 22:20:05")- , ("YYYY-MM-DDTH:MI:SZ", "2024-03-15T22:20:05Z")- , ("YYYYMMDDTHMIS", "20240315T222005")- , ("YYYY-MM-DDTH:MI:S.msZ", "2024-03-15T22:20:05.637Z")- , ("YYYY-MM-DDTH:MI:S.msZ", "2024-03-15T22:20:05.637123Z")- , ("YYYY-MM-DDTH:MI:S.msZ", "2024-03-15T22:20:05.637123456Z")- ]-- P.forM_ dateMap $ \(formatTxt, utcTxt) -> do- case parseUtc utcTxt of- Nothing -> P.die "Invalid UTC string"- Just utcStamp ->- let timeFmt = formatTxt & T.unpack & toFormat- in (utcStamp & timePrint timeFmt)- `shouldBe` T.unpack- ( utcTxt- & T.replace "123" ""- & T.replace "456" ""- )-- let- utcTxt = "2024-03-15T22:20:05.386777444Z"- printFmt = "YYYY-MM-DDTH:MI:S.ms" & T.unpack & toFormat- -- Truncates microseconds and nanoseconds- expected = "2024-03-15T22:20:05.386"-- (utcTxt & parseUtc <&> timePrint printFmt) `shouldBe` Just expected-- it "imports a JSON task" $ do- withMemoryDb conf $ \memConn -> do- let jsonTask = "{\"body\":\"Just a test\", \"notes\":[\"A note\"]}"-- case eitherDecode jsonTask of- Left error ->- P.die $ "Error decoding JSON: " <> show error- Right importTaskRecord -> do- result <- insertImportTask memConn importTaskRecord-- unpack (show result)- `shouldStartWith` "📥 Imported task \"Just a test\" with ulid "-- taskToNotes :: [TaskToNote] <-- query_ memConn "SELECT * FROM task_to_note"- case taskToNotes of- [taskToNote] -> do- taskToNote `shouldSatisfy` (\task -> task.ulid /= "")- taskToNote `shouldSatisfy` (\task -> task.task_ulid /= "")- taskToNote `shouldSatisfy` (\task -> task.note == "A note")- _ -> P.die "More than one task_to_note row found"-- tasks :: [FullTask] <- query_ memConn "SELECT * FROM tasks_view"-- case tasks of- [updatedTask] -> do- updatedTask `shouldSatisfy` (\task -> task.ulid /= "")- updatedTask `shouldSatisfy` (\task -> task.modified_utc /= "")- updatedTask `shouldSatisfy` (\task -> task.user /= "")- updatedTask- { FullTask.ulid = ""- , FullTask.modified_utc = ""- , FullTask.user = ""- }- `shouldBe` emptyFullTask- { FullTask.body = "Just a test"- , -- TODO: Fix after notes are returned as a JSON array- FullTask.notes = Just []- , FullTask.priority = Just 1.0- , FullTask.metadata = decode jsonTask- }- _ -> P.die "More than one task found"-- it "imports a JSON task with an ISO8601 created_at field" $ do- withMemoryDb conf $ \memConn -> do- let- utc = "2024-03-15T10:32:51.386777444Z"- -- ULID only has millisecond precision:- utcFromUlid = "2024-03-15 10:32:51.387"- jsonTask =- "{\"body\":\"Just a test\",\"created_at\":\"{{utc}}\"}"- & T.replace "{{utc}}" utc-- case eitherDecodeStrictText jsonTask of- Left error ->- P.die $ "Error decoding JSON: " <> show error- Right importTaskRecord -> do- _ <- insertImportTask memConn importTaskRecord- tasks :: [FullTask] <- query_ memConn "SELECT * FROM tasks_view"- case tasks of- [updatedTask] ->- ulid2utc updatedTask.ulid `shouldBe` Just utcFromUlid- _ -> P.die "More than one task found"-- TypesSpec.spec- LibSpec.spec now-+{-# OPTIONS_GHC -F -pgmF hspec-discover #-} -main :: IO ()-main = do- nowElapsed <- timeCurrentP- let now = timeFromElapsedP nowElapsed :: DateTime- hspec $ testSuite defaultConfig now
+ test/SpecHook.hs view
@@ -0,0 +1,7 @@+module SpecHook where++import Test.Hspec+++hook :: Spec -> Spec+hook = parallel
test/TypesSpec.hs view
@@ -14,7 +14,7 @@ import Lib (insertNotes, insertRecord, insertTags) import NeatInterpolation (trimming) import Note (Note (Note, body, ulid))-import Task (Task (body, ulid), taskToEditableYaml, zeroTask)+import Task (Task (body, ulid), emptyTask, taskToEditableMarkdown) import TestUtils (withMemoryDb) @@ -38,22 +38,21 @@ spec :: Spec spec = do- describe "Types" $ do- describe "Task" $ do- let- sampleTask =- zeroTask- { Task.ulid = "01hs68z7mdg4ktpxbv0yfafznq"- , Task.body = "Sample task"- }+ describe "Task" $ do+ let+ sampleTask =+ emptyTask+ { Task.ulid = "01hs68z7mdg4ktpxbv0yfafznq"+ , Task.body = "Sample task"+ } - it "can be converted to YAML" $ do- let- taskYaml = sampleTask & Data.Yaml.encode & P.decodeUtf8+ it "can be converted to YAML" $ do+ let+ taskYaml = sampleTask & Data.Yaml.encode & P.decodeUtf8 - expected :: Text- expected =- [trimming|+ expected :: Text+ expected =+ [trimming| awake_utc: null body: Sample task closed_utc: null@@ -71,25 +70,28 @@ user: '' waiting_utc: null |]- <> "\n"+ <> "\n" - taskYaml `shouldBe` expected+ taskYaml `shouldBe` expected - it "can be converted to YAML for editing" $ do- withMemoryDb defaultConfig $ \memConn -> do- Lib.insertRecord "tasks" memConn sampleTask- let tags = [0 .. 9] <&> \(i :: P.Int) -> "tag-" <> P.show i- warnings <- Lib.insertTags memConn Nothing sampleTask tags- P.show warnings `shouldBe` T.empty- Lib.insertNotes memConn Nothing sampleTask sampleNotes+ it "can be converted to YAML for editing" $ do+ withMemoryDb defaultConfig $ \memConn -> do+ Lib.insertRecord "tasks" memConn sampleTask+ let tags = [0 .. 9] <&> \(i :: P.Int) -> "tag-" <> P.show i+ tagWarnings <- Lib.insertTags defaultConfig memConn Nothing sampleTask tags+ P.show tagWarnings `shouldBe` T.empty - taskYaml <- taskToEditableYaml memConn sampleTask- let- expected :: P.ByteString- expected =- [trimming|+ noteWarnings <-+ Lib.insertNotes defaultConfig memConn Nothing sampleTask sampleNotes+ P.show noteWarnings `shouldBe` T.empty++ taskYaml <- taskToEditableMarkdown memConn sampleTask+ let+ expected :: P.ByteString+ expected =+ [trimming|+ --- awake_utc: null- body: Sample task closed_utc: null due_utc: null group_ulid: null@@ -117,29 +119,31 @@ # surprising # line breaks. notes: []+ ...++ Sample task |]- <> "\n"- & P.encodeUtf8+ & P.encodeUtf8 - taskYaml `shouldBe` expected+ taskYaml `shouldBe` expected - describe "FullTask" $ do- let- sampleFullTask =- emptyFullTask- { FullTask.ulid = "01hs68z7mdg4ktpxbv0yfafznq"- , FullTask.body = "Sample task"- , FullTask.tags = Just ["tag1", "tag2"]- , FullTask.notes = Just sampleNotes- }+ describe "FullTask" $ do+ let+ sampleFullTask =+ emptyFullTask+ { FullTask.ulid = "01hs68z7mdg4ktpxbv0yfafznq"+ , FullTask.body = "Sample task"+ , FullTask.tags = Just ["tag1", "tag2"]+ , FullTask.notes = Just sampleNotes+ } - it "can be converted to YAML" $ do- let- taskYaml = sampleFullTask & Data.Yaml.encode & P.decodeUtf8+ it "can be converted to YAML" $ do+ let+ taskYaml = sampleFullTask & Data.Yaml.encode & P.decodeUtf8 - expected :: Text- expected =- [trimming|+ expected :: Text+ expected =+ [trimming| awake_utc: null body: Sample task closed_utc: null@@ -166,6 +170,6 @@ user: '' waiting_utc: null |]- <> "\n"+ <> "\n" - taskYaml `shouldBe` expected+ taskYaml `shouldBe` expected
+ test/UtilsSpec.hs view
@@ -0,0 +1,55 @@+module UtilsSpec where++import Protolude (+ Functor (fmap),+ Maybe (..),+ Text,+ show,+ ($),+ (&),+ )++import Data.Aeson (decode)+import Data.Hourglass (+ Elapsed (Elapsed),+ ElapsedP (ElapsedP),+ timeGetDateTimeOfDay,+ )+import Test.Hspec (Spec, it, shouldBe)++import Task (+ Task (body, due_utc, metadata, modified_utc, state, ulid, user),+ emptyTask,+ )+import Utils (parseUlidText, parseUlidUtcSection)+++exampleTask :: Task+exampleTask =+ emptyTask+ { ulid = "01hq68smfe0r9entg3x4rb9441"+ , body = "Buy milk"+ , state = Nothing+ , modified_utc = "2024-02-21 16:43:17"+ , due_utc = Just "2025-07-08 10:22:56"+ , user = "john"+ , metadata = "{\"source\":\"fridge\"}" & decode+ }+++spec :: Spec+spec = do+ it "correctly parses beginning of UNIX epoch" $+ do+ parseUlidUtcSection "0000000000"+ `shouldBe` Just (timeGetDateTimeOfDay $ Elapsed 0)++ it "correctly parses 36 ms after UNIX epoch" $+ do+ parseUlidUtcSection "0000000014"+ `shouldBe` Just (timeGetDateTimeOfDay $ ElapsedP 0 36000000)++ it "correctly parses a ULID string" $ do+ let ulidText = "0000000014T4R3JR7HMQNREEW8" :: Text++ fmap show (parseUlidText ulidText) `shouldBe` Just ulidText