diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# TaskLite Core + +This Haskell package provides the core functionality for TaskLite. +Use it to interact with a TaskLite database programmatically. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,35 @@ +module Main where + +import Criterion.Main (bench, bgroup, defaultMain, whnf) +import Protolude ( + IO, + Int, + Maybe (..), + Num ((+), (-)), + Ord ((<)), + otherwise, + ($), + ) + + +fib :: Int -> Maybe Int +fib m + | m < 0 = Nothing + | otherwise = Just $ go m + where + go 0 = 0 + go 1 = 1 + go n = go (n - 1) + go (n - 2) + + +main :: IO () +main = + defaultMain + [ bgroup + "fib" + [ bench "1" $ whnf fib 1 + , bench "5" $ whnf fib 5 + , bench "9" $ whnf fib 9 + , bench "11" $ whnf fib 11 + ] + ] diff --git a/example-config.yaml b/example-config.yaml new file mode 100644 --- /dev/null +++ b/example-config.yaml @@ -0,0 +1,35 @@ +tableName: tasks +idWidth: 4 +idStyle: green +priorityStyle: magenta +dateStyle: dull black +bodyStyle: white +bodyClosedStyle: black +closedStyle: dull black +dueStyle: yellow +overdueStyle: red +tagStyle: blue +utcFormat: YYYY-MM-DD H:MI:S +#| FIXME: Blocked by https://github.com/vincenthz/hs-hourglass/issue +# utcFormatShort: YYYY-DDD H:MI +utcFormatShort: YYYY-MM-DD H:MI + +#| Optional, uses the XDG directory per default +#| https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html +# dataDir: /custom/path/tasklite + +dbName: main.db +dateWidth: 10 +bodyWidth: 10 +prioWidth: 4 +headCount: 20 +maxWidth: 120 +progressBarWidth: 24 + +# hooks: +# #| Is per default the "hooks" directory in the `dataDir` +# # directory: /custom/path/hooks +# launch: +# pre: +# - interpreter: python3 +# body: print('Python test') diff --git a/source/Base32.hs b/source/Base32.hs new file mode 100644 --- /dev/null +++ b/source/Base32.hs @@ -0,0 +1,64 @@ +-- | Adapted from https://hackage.haskell.org/package/crockford +module Base32 (decode) where + +import Data.Char as C (Char, toUpper) +import Data.Text as T (Text, unpack) +import Protolude ( + Applicative (pure), + Integral, + Maybe (..), + Traversable (mapM), + ($), + ) + +import Data.ULID.Digits (unDigits) + + +{-| +Decodes a Crockford-encoded `String` into an integer, if possible. +Returns `Nothing` if the string is not a valid Crockford-encoded value. +-} +decode :: (Integral i) => Text -> Maybe i +decode base32text = do + numbers <- mapM decodeChar $ T.unpack base32text + pure $ unDigits 32 numbers + + +decodeChar :: (Integral i) => Char -> Maybe i +decodeChar c = case C.toUpper c of + '0' -> Just 0 + 'O' -> Just 0 + '1' -> Just 1 + 'I' -> Just 1 + 'L' -> Just 1 + '2' -> Just 2 + '3' -> Just 3 + '4' -> Just 4 + '5' -> Just 5 + '6' -> Just 6 + '7' -> Just 7 + '8' -> Just 8 + '9' -> Just 9 + 'A' -> Just 10 + 'B' -> Just 11 + 'C' -> Just 12 + 'D' -> Just 13 + 'E' -> Just 14 + 'F' -> Just 15 + 'G' -> Just 16 + 'H' -> Just 17 + 'J' -> Just 18 + 'K' -> Just 19 + 'M' -> Just 20 + 'N' -> Just 21 + 'P' -> Just 22 + 'Q' -> Just 23 + 'R' -> Just 24 + 'S' -> Just 25 + 'T' -> Just 26 + 'V' -> Just 27 + 'W' -> Just 28 + 'X' -> Just 29 + 'Y' -> Just 30 + 'Z' -> Just 31 + _ -> Nothing diff --git a/source/Cli.hs b/source/Cli.hs new file mode 100644 --- /dev/null +++ b/source/Cli.hs @@ -0,0 +1,1358 @@ +-- Necessary to print git hash in help output +-- and to embed example config file +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use camelCase" #-} + +module Cli where + +import Protolude ( + Alternative (some, (<|>)), + Applicative (pure, (<*>)), + Bool (True), + Char, + Either (..), + Eq ((==)), + FilePath, + Float, + Foldable (foldr, null), + Functor (fmap), + IO, + Maybe (..), + Monad ((>>=)), + Semigroup ((<>)), + Show, + Text, + filter, + foldMap, + fst, + getArgs, + isPrefixOf, + isSpace, + not, + optional, + readFile, + show, + snd, + ($), + (&), + (&&), + (.), + (<$>), + (<&>), + (||), + ) +import Protolude qualified as P + +import AirGQL.Config qualified as AirGQL +import Control.Monad.Catch (catchAll) +import Data.Aeson as Aeson (KeyValue ((.=)), encode, object) +import Data.FileEmbed (embedStringFile, makeRelativeToProject) +import Data.Hourglass (DateTime, Time (timeFromElapsedP)) +import Data.String (fromString) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TL +import Data.Time.ISO8601.Duration qualified as Iso +import Data.Version (showVersion) +import Database.SQLite.Simple (Connection (..)) +import Database.SQLite.Simple qualified as SQLite +import GitHash (giDirty, giTag, tGitInfoCwd) +import Options.Applicative ( + ArgumentFields, + CommandFields, + Mod, + ParseError (ShowHelpText), + Parser, + ParserHelp, + ParserInfo, + ParserResult (CompletionInvoked, Failure, Success), + argument, + auto, + briefDesc, + command, + commandGroup, + defaultPrefs, + eitherReader, + execParserPure, + footerDoc, + fullDesc, + headerDoc, + help, + helpHeader, + helper, + hsubparser, + idm, + info, + internal, + maybeReader, + metavar, + noIntersperse, + parserFailure, + progDesc, + progDescDoc, + renderFailure, + strArgument, + ) +import Options.Applicative.Help.Chunk (Chunk (Chunk), (<<+>>)) +import Options.Applicative.Help.Core (parserHelp) +import Paths_tasklite_core (version) +import Prettyprinter ( + Doc, + Pretty (pretty), + annotate, + dquotes, + enclose, + hardline, + hcat, + indent, + parens, + (<+>), + ) +import Prettyprinter.Render.Terminal ( + AnsiStyle, + Color (Black, Blue, Cyan, Red, Yellow), + bold, + color, + colorDull, + hPutDoc, + putDoc, + ) +import System.Directory ( + Permissions, + XdgDirectory (..), + createDirectoryIfMissing, + executable, + getHomeDirectory, + getPermissions, + getXdgDirectory, + listDirectory, + ) +import System.FilePath (()) +import System.Process (readProcess) +import Time.System (timeCurrentP) + +import Config ( + Config (..), + HookSet (..), + HooksConfig (..), + addHookFilesToConfig, + ) +import ImportExport ( + backupDatabase, + dumpCsv, + dumpJson, + dumpNdjson, + dumpSql, + editTask, + importEml, + importFile, + importJson, + ingestFile, + ) +import Lib ( + addNote, + addTag, + addTask, + adjustPriority, + countTasks, + deletableTasks, + deleteNote, + deleteTag, + deleteTasks, + doTasks, + doneTasks, + duplicateTasks, + endTasks, + findTask, + getStats, + headTasks, + infoTask, + listAll, + listNoTag, + listOldTasks, + listProjects, + listReady, + listRecurring, + listRepeating, + listTags, + listWaiting, + listWithTag, + logTask, + modifiedTasks, + newTasks, + nextTask, + obsoleteTasks, + openTasks, + overdueTasks, + queryTasks, + randomTask, + recurTasks, + repeatTasks, + reviewTasksIn, + runFilter, + runSql, + setDueUtc, + setReadyUtc, + setupConnection, + startTasks, + stopTasks, + trashTasks, + uncloseTasks, + undueTasks, + unmetaTasks, + unnoteTasks, + unprioTasks, + unreadyTasks, + unrecurTasks, + unrepeatTasks, + unreviewTasks, + untagTasks, + unwaitTasks, + unwakeTasks, + waitFor, + waitTasks, + ) +import Migrations (runMigrations) +import Server (startServer) +import System.Environment (getProgName) +import Utils ( + IdText, + ListModifiedFlag (AllItems, ModifiedItemsOnly), + TagText, + executeHooks, + parseUtc, + ulid2utc, + ) + + +type String = [Char] + + +data Command + = {- Add -} + AddTask [Text] + | AddWrite [Text] + | AddRead [Text] + | AddIdea [Text] + | AddWatch [Text] + | AddListen [Text] + | AddBuy [Text] + | AddSell [Text] + | AddPay [Text] + | AddShip [Text] + | LogTask [Text] -- + {- Modify -} + | ReadyOn DateTime [IdText] + | WaitTasks [IdText] + | WaitFor Iso.Duration [IdText] + | ReviewTasks [IdText] + | ReviewTasksIn Iso.Duration [IdText] + | DoTasks [IdText] + | DoOneTask IdText (Maybe [Text]) + | EndTasks [IdText] + | TrashTasks [IdText] + | DeleteTasks [IdText] + | RepeatTasks Iso.Duration [IdText] + | RecurTasks Iso.Duration [IdText] + | BoostTasks [IdText] + | HushTasks [IdText] -- + {- Modify With Parameter -} + | -- | Modify [IdText] Text -- DSL for modifying a task + Prioritize Float [IdText] + | AddTag TagText [IdText] + | DeleteTag TagText [IdText] + | AddNote Text [IdText] + | DeleteNote IdText + | SetDueUtc DateTime [IdText] + | Start [IdText] + | Stop [IdText] + | Duplicate [IdText] + | EditTask IdText -- Launch editor with YAML version of task + {- Show -} + | -- \| Append -- Append words to a task description + -- \| Prepend -- Prepend words to a task description + -- \| Undo -- Revert last change + InfoTask IdText + | NextTask + | RandomTask + | FindTask Text -- + {- I/O -} + | ImportFile FilePath + | ImportJson + | ImportEml + | IngestFile FilePath + | Csv + | Json + | Ndjson + | Sql + | Backup -- + {- List -} + -- \| Fork -- Create new SQLite db with the tasks of the specified query + | ListAll + | ListHead + | ListNewFiltered (Maybe [Text]) + | ListOld + | ListOpen + | ListModified + | ListModifiedOnly + | ListDone + | ListObsolete + | ListDeletable + | ListReady + | ListWaiting + | ListOverdue + | ListRepeating + | ListRecurring + | ListNoTag + | ListWithTag [Text] + | CountFiltered (Maybe [Text]) + | QueryTasks Text + | RunSql Text + | RunFilter [Text] -- + -- \| Views -- List all available views + | Tags -- List all used tags + | Projects -- List all active tags + | Stats -- List statistics about tasks + {- Unset -} + | -- \| Active -- Started tasks + -- \| Blocked -- Tasks that are blocked by other tasks (newest first) + -- \| Blockers -- Tasks that block other tasks (newest first) + -- \| Unblocked -- Tasks that are not blocked + UnCloseTasks [IdText] + | UnDueTasks [IdText] + | UnWaitTasks [IdText] + | UnWakeTasks [IdText] + | UnReadyTasks [IdText] + | UnReviewTasks [IdText] + | UnRepeatTasks [IdText] + | UnRecurTasks [IdText] + | UnTagTasks [IdText] + | UnNoteTasks [IdText] + | UnPrioTasks [IdText] + | UnMetaTasks [IdText] -- + {- Misc -} + | -- \| Demo -- Switch to demo mode + Version -- Show version + | -- \| License -- Show license + Alias Text (Maybe [Text]) + | Help + | PrintConfig + | StartServer + | UlidToUtc Text + | ExternalCommand Text (Maybe [Text]) + deriving (Show, Eq) + + +nameToAliasList :: [(Text, Text)] +nameToAliasList = + [ ("annotate", "note") + , ("clone", "duplicate") + , ("close", "end") + , ("decrease", "hush") + , ("erase", "delete") + , ("finish", "do") + , ("fix", "do") + , ("implement", "do") + , ("inbox", "notag") + , ("increase", "boost") + , ("remove", "delete") + , ("reopen", "unclose") + , ("rm", "delete") + , ("search", "find") + , ("stop", "end") + -- , ("week", "sunday") + -- , ("latest", "newest") + -- , ("schedule", "activate") + -- , ("blocking", "blockers") + -- , ("denotate", "denote") + ] + + +{- Imitates output from `git describe` -} +versionSlug :: Text +versionSlug = do + let + gitInfo = $$tGitInfoCwd + + fromString $ + giTag gitInfo + <> if giDirty gitInfo then "-dirty" else "" + + +aliasWarning :: Text -> Doc AnsiStyle +aliasWarning alias = + "Invalid command." + <+> "Use" + <+> dquotes (pretty alias) + <+> "instead." + <> hardline + + +getCommand :: (Text, Text) -> Mod CommandFields Command +getCommand (alias, commandName) = + command (T.unpack alias) $ + info + (Alias commandName <$> optional (some $ strArgument idm)) + (progDesc $ T.unpack $ alias <> "-> " <> commandName) + + +toParserInfo :: Parser a -> Text -> ParserInfo a +toParserInfo parser description = + info parser (fullDesc <> progDesc (T.unpack description)) + + +idVar :: Mod ArgumentFields a +idVar = + metavar "TASK_ID" <> help "Id of the task (Ulid)" + + +idsVar :: Mod ArgumentFields a +idsVar = + metavar "TASK_ID ..." <> help "Ids of the tasks (Ulid)" + + +-- | Help Sections +basic_sec + , shortcut_sec + , list_sec + , vis_sec + , i_o_sec + , advanced_sec + , alias_sec + , unset_sec + , 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") +vis_sec = ("{{vis_sec}}", "Visualizations") +i_o_sec = ("{{i_o_sec}}", "I/O Commands") +advanced_sec = ("{{advanced_sec}}", "Advanced Commands") +alias_sec = ("{{alias_sec}}", "Aliases") +unset_sec = ("{{unset_sec}}", "Unset Commands") +utils_sec = ("{{utils_sec}}", "Utils") + + +parseDurationString :: String -> Either String Iso.Duration +parseDurationString text = + text + & fromString + & Iso.parseDuration + +{- FOURMOLU_DISABLE -} +commandParser :: Config -> Parser Command +commandParser conf = + let + numTasks = show (headCount conf) + in + pure ListReady + <|> + ( hsubparser + ( metavar (T.unpack $ snd basic_sec) + <> commandGroup (T.unpack $ fst basic_sec) + + <> command "add" (toParserInfo (AddTask <$> some (strArgument + (metavar "BODY" <> help "Body of the task" ))) + "Add a new task") + + -- <> command "prompt" (toParserInfo (pure AddInteractive) + -- "Add a new task via an interactive prompt") + + <> command "log" (toParserInfo (LogTask <$> some (strArgument + (metavar "BODY" <> help "Body of the task"))) + "Log an already completed task") + + <> command "readyon" (toParserInfo (ReadyOn + <$> argument (maybeReader (parseUtc . T.pack)) + (metavar "READY_UTC" <> help "Timestamp when task is ready") + <*> some (strArgument idsVar)) + "Set ready UTC of tasks") + + <> command "wait" (toParserInfo (WaitTasks <$> some (strArgument idsVar)) + "Mark a task as waiting (e.g. for feedback) and review it in 3 days") + + <> command "waitfor" (toParserInfo (WaitFor + <$> argument (eitherReader parseDurationString) + (metavar "DURATION" + <> help "ISO8601 duration (e.g. P1DT5H for 1 day and 5 hours)") + <*> some (strArgument idsVar)) + "Wait DURATION until it's ready for review") + + <> command "review" (toParserInfo (ReviewTasks + <$> some (strArgument idsVar)) + "Finish review and set new review date in 3 days") + + <> command "reviewin" (toParserInfo (ReviewTasksIn + <$> argument (eitherReader parseDurationString) + (metavar "DURATION" + <> help "ISO8601 duration (e.g. P1DT5H for 1 day and 5 hours)") + <*> some (strArgument idsVar)) + "Finish review and set new review date in DURATION") + + <> command "do" (toParserInfo (DoOneTask + <$> strArgument idsVar + <*> optional (some (strArgument (metavar "CLOSING_NOTE" + <> help "Final note to explain why and how it was done")))) + "Mark a task as done and add optional closing note") + + <> command "doonly" (toParserInfo + (DoOneTask <$> strArgument idsVar <*> pure Nothing) + "Mark only one task as done") + + <> command "doall" (toParserInfo (DoTasks <$> some (strArgument idsVar)) + "Mark one or more tasks as done") + + <> command "end" (toParserInfo (EndTasks <$> some (strArgument idsVar)) + "Mark a task as obsolete") + + <> command "edit" (toParserInfo (EditTask <$> strArgument idVar) + "Edit YAML version of task in your $EDITOR") + + <> command "trash" (toParserInfo (TrashTasks <$> some (strArgument idsVar)) + "Mark a task as deletable") + + <> command "delete" (toParserInfo (DeleteTasks + <$> some (strArgument idsVar)) + "Delete a task from the database (Attention: Irreversible)") + + <> command "repeat" (toParserInfo (RepeatTasks + <$> argument (eitherReader parseDurationString) + (metavar "DURATION" + <> help "ISO8601 duration (e.g. P1DT5H for 1 day and 5 hours)") + <*> some (strArgument idsVar)) + "Repeat a task DURATION after it gets closed") + + <> command "recur" (toParserInfo (RecurTasks + <$> argument (eitherReader parseDurationString) + (metavar "DURATION" <> help "ISO8601 duration \ + \(e.g. P1DT5H for 1 day and 5 hours)") + <*> some (strArgument idsVar)) + "Recur a task DURATION after its due UTC") + + <> command "duplicate" (toParserInfo + (Duplicate <$> some (strArgument idsVar)) + "Duplicates a task (and resets the closed and due UTC fields)") + + <> command "boost" (toParserInfo (BoostTasks <$> some (strArgument idsVar)) + "Increase priority of specified tasks by 1") + + <> command "hush" (toParserInfo (HushTasks <$> some (strArgument idsVar)) + "Decrease priority of specified tasks by 1") + + <> command "prioritize" (toParserInfo (Prioritize + <$> argument auto (metavar "VALUE" + <> help "Value to adjust priority by") + <*> some (strArgument idsVar)) + "Adjust priority of specified tasks") + + -- <> command "snooze" (toParserInfo + -- (SnoozeTasks <$> some (strArgument idsVar)) + -- "Add 1 day to awakening datetime") + + <> command "info" (toParserInfo (InfoTask <$> strArgument idVar) + "Show detailed information and metadata of task") + + <> command "next" (toParserInfo (pure NextTask) + "Show the task with the highest priority") + + <> command "random" (toParserInfo (pure RandomTask) + "Show a random open task") + + <> command "find" (toParserInfo (FindTask <$> strArgument + (metavar "PATTERN" <> help "Search pattern")) + "Fuzzy search a task") + + <> command "tag" (toParserInfo (AddTag + <$> strArgument (metavar "TAG" <> help "The tag") + <*> some (strArgument idsVar)) + "Add a tag to specified tasks") + + <> command "deletetag" (toParserInfo (DeleteTag + <$> strArgument (metavar "TAG" <> help "The tag") + <*> some (strArgument idsVar)) + "Delete a tag from specified tasks") + + <> command "note" (toParserInfo (AddNote + <$> strArgument (metavar "NOTE" <> help "The note") + <*> some (strArgument idsVar)) + "Add a note to specified tasks") + + <> command "deletenote" (toParserInfo (DeleteNote + <$> strArgument (metavar "ULID" <> help "The ULID of the note")) + "Delete the specified note") + + <> command "due" (toParserInfo (SetDueUtc + <$> argument (maybeReader (parseUtc . T.pack)) + (metavar "DUE_UTC" <> help "Due timestamp in UTC") + <*> some (strArgument idsVar)) + "Set due UTC of specified tasks") + + <> command "start" (toParserInfo + (Start <$> some (strArgument idsVar)) + "Add a note that work on task was started") + + <> command "stop" (toParserInfo + (Stop <$> some (strArgument idsVar)) + "Add a note that work on task was stopped") + + -- <> command "active" (toParserInfo + -- (Active <$> some (strArgument idsVar)) + -- "List all currently worked on tasks") + + -- <> command "touch" (toParserInfo (TouchTask <$> strArgument idVar) + -- "Update modified UTC") + + -- <> command "timer" (toParserInfo (TouchTask <$> strArgument idVar) + -- "Show an overview of the currently active task \ + -- \with a timer of the past time since you started the task") + ) + + <|> hsubparser + ( metavar (T.unpack $ snd shortcut_sec) + <> commandGroup (T.unpack $ fst shortcut_sec) + + <> command "write" (toParserInfo (AddWrite <$> some (strArgument + (metavar "BODY" <> help "Body of the task"))) + "Write a message or a post") + + <> command "read" (toParserInfo (AddRead <$> some (strArgument + (metavar "BODY" <> help "Url or title to a website or blog post"))) + "Read the specified URL") + + <> command "idea" (toParserInfo (AddIdea <$> some (strArgument + (metavar "BODY" <> help "Description of your idea"))) + "Quickly capture an idea") + + <> command "watch" (toParserInfo (AddWatch <$> some (strArgument + (metavar "BODY" <> help "Url or title of a video or movie to watch"))) + "Watch a movie or a video") + + <> command "listen" (toParserInfo (AddListen <$> some (strArgument + (metavar "BODY" + <> help "Url or title of a song or podcast to listen to"))) + "Listen to a song or podcast") + + <> command "buy" (toParserInfo (AddBuy <$> some (strArgument + (metavar "BODY" <> help "Body of the task"))) + "Buy something") + + <> command "sell" (toParserInfo (AddSell <$> some (strArgument + (metavar "BODY" <> help "Body of the task"))) + "Sell something") + + <> command "pay" (toParserInfo (AddPay <$> some (strArgument + (metavar "BODY" <> help "Body of the task"))) + "Pay for something") + + <> command "ship" (toParserInfo (AddShip <$> some (strArgument + (metavar "BODY" <> help "Body of the task"))) + "Ship an item to someone") + ) + + <|> hsubparser + ( metavar (T.unpack $ snd list_sec) + <> commandGroup (T.unpack $ fst list_sec) + + <> command "head" (toParserInfo (pure ListHead) + ("List " <> numTasks <> " most important open tasks by priority desc")) + + <> 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 "modified" (toParserInfo (pure ListModified) + "List all tasks by modified UTC desc") + + <> command "modifiedonly" (toParserInfo (pure ListModifiedOnly) + "List tasks where modified UTC != creation UTC by modified UTC desc") + + -- All tasks due to no later than + -- <> command "yesterday" + -- <> command "today" + -- <> command "tomorrow" + + -- <> command "monday" + -- <> command "tuesday" + -- <> command "wednesday" + -- <> command "thursday" + -- <> command "friday" + -- <> command "saturday" + -- <> command "sunday" + + -- <> command "month" -- … last day of the month + -- <> command "quarter" -- … last day of the quarter + -- <> command "year" -- … last day of the year + + <> command "overdue" (toParserInfo (pure ListOverdue) + "List all overdue tasks by priority desc") + + <> command "repeating" (toParserInfo (pure ListRepeating) + "List all repeating tasks by priority desc") + + <> command "recurring" (toParserInfo (pure ListRecurring) + "List all recurring tasks by priority desc") + + <> command "new" + (toParserInfo + (ListNewFiltered <$> optional (some + (strArgument $ metavar "FILTER_EXP" <> help "Filter expressions"))) + "List newest tasks by creation UTC desc (Open and Closed)") + + <> command "old" (toParserInfo (pure ListOld) + ("List " <> numTasks + <> " oldest open tasks by creation UTC asc")) + + -- <> command "asleep" (toParserInfo (pure ListAwake) + -- "List all sleeping tasks by priority") + + -- <> command "awake" (toParserInfo (pure ListAwake) + -- "List all awake tasks by priority") + + <> command "ready" (toParserInfo (pure ListReady) + ( "List " <> numTasks <> " most important ready tasks by priority desc")) + + <> command "waiting" (toParserInfo (pure ListWaiting) + "List all waiting tasks by priority") + + -- <> command "scheduled" + -- "List tasks which have an earliest day to work on" + + + <> command "done" (toParserInfo (pure ListDone) + ("List " <> numTasks + <> " done tasks by closing UTC desc")) + + <> command "obsolete" (toParserInfo (pure ListObsolete) + "List all obsolete tasks by closing UTC") + + <> command "deletable" (toParserInfo (pure ListDeletable) + "List all deletable tasks by closing UTC") + + -- <> command "expired" + -- "List tasks which are obsolete, \ + -- \because they crossed their expiration date" + + -- <> command "tagged" (toParserInfo (pure $ ListTagged) + -- "List all tasks with a tag") + + <> command "notag" (toParserInfo (pure ListNoTag) + "List tasks without any tags") + + <> command "withtag" + (toParserInfo + (ListWithTag <$> some + (strArgument $ metavar "TAGS" <> help "The tags")) + "List tasks which have all of the specified tags") + + <> command "get" + (toParserInfo + (RunFilter <$> some + (strArgument $ metavar "FILTER_EXP" <> help "Filter expressions")) + "Get all tasks filtered by the specified expressions \ + \by priority") + + -- TODO: Replace with tasks and tags commands + <> command "query" (toParserInfo (QueryTasks <$> strArgument + (metavar "QUERY" <> help "The SQL query after the \"WHERE\" clause")) + "Run \"SELECT * FROM tasks WHERE QUERY\" on the database") + + -- <> command "metadata" (toParserInfo (pure $ ListNoTag) + -- "List all tasks with metadata") + + -- <> command "prioritized" (toParserInfo (pure $ ListNoTag) + -- "List all tasks with an adjusted priority") + + -- <> command "tasks" (toParserInfo (QueryTasks <$> strArgument + -- (metavar "QUERY" <> help "The SQL query after the \"where\" clause")) + -- "Run \"SELECT * FROM tasks WHERE QUERY\" on the database") + + -- <> command "tags" (toParserInfo (QueryTasks <$> strArgument + -- (metavar "QUERY" <> help "The SQL query after the \"where\" clause")) + -- "Run \"SELECT * FROM tasks WHERE QUERY\" on the database") + + -- <> command "newest" "Show the newest task" + -- <> command "oldest" "Show the oldest task" + -- <> command "repeating" -- Open repeating tasks (soonest first) + -- <> command "unblocked" -- Tasks that are not blocked (by priority) + ) + + <|> hsubparser + ( metavar (T.unpack $ snd vis_sec) + <> commandGroup (T.unpack $ fst vis_sec) + -- <> command "kanban" -- "List tasks columnized by state" + -- <> command "burndown" -- "Burndown chart by week" + -- <> command "calendar" -- "Calendar view of all open tasks" + -- <> command "history" -- "History of tasks" + -- <> command "stats" -- "Statistics of all tasks" + -- <> command "ulids" -- "List all ULIDs" + + <> command "tags" (toParserInfo (pure Tags) + "List all used tags and their progress") + + <> command "projects" (toParserInfo (pure Projects) + "List all active tags (a.k.a projects) and their progress") + + <> command "stats" (toParserInfo (pure Stats) + "Show statistics about tasks") + + ) + + <|> hsubparser + ( metavar (T.unpack $ snd i_o_sec) + <> commandGroup (T.unpack $ fst i_o_sec) + + <> command "import" (toParserInfo (ImportFile <$> strArgument + (metavar "FILEPATH" <> help "Path to import file")) + "Import a .json or .eml file containing one task") + + <> command "importjson" (toParserInfo (pure ImportJson) + "Import one JSON object 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 " + <> "(import, open in editor, delete the original file)")) + + <> command "csv" (toParserInfo (pure Csv) + "Show tasks in CSV format") + + <> command "runsql" (toParserInfo (RunSql <$> strArgument + (metavar "QUERY" <> help "The SQL query")) + "Run any SQL query and show result as CSV") + + <> command "json" (toParserInfo (pure Json) + "Show tasks in JSON format") + + <> command "ndjson" (toParserInfo (pure Ndjson) + "Show tasks in NDJSON format") + + <> command "sql" (toParserInfo (pure Sql) + "Show SQL commands to create and populate database") + + <> command "backup" (toParserInfo (pure Backup) + "Create a backup of the tasks database at ~/tasklite/backups") + ) + + <|> hsubparser + ( metavar (T.unpack $ snd advanced_sec) + <> commandGroup (T.unpack $ fst advanced_sec) + + <> command "count" + (toParserInfo + (CountFiltered <$> optional ( some + (strArgument $ metavar "FILTER_EXP" <> help "Filter expressions"))) + "Output total number of tasks filtered by the specified expressions") + + <> command "config" (toParserInfo (pure PrintConfig) + "Print current configuration of TaskLite") + + <> command "server" (toParserInfo (pure StartServer) + "Start an API server with several endpoints \ + \for data access and management \ + \(including a GraphQL endpoint powered by AirGQL)") + + -- <> command "verify" (toParserInfo (pure Verify) + -- "Verify the integrity of the database") + + <> command "version" (toParserInfo (pure Version) "Display version") + + <> command "help" (toParserInfo (pure Help) "Display current help page") + ) + + <|> hsubparser + ( metavar (T.unpack $ snd unset_sec) + <> commandGroup (T.unpack $ fst unset_sec) + + <> command "unclose" (toParserInfo (UnCloseTasks + <$> some (strArgument idsVar)) + "Erase closed timestamp and erase Done / Obsolete / Deletable state") + + <> command "undue" (toParserInfo (UnDueTasks + <$> some (strArgument idsVar)) + "Erase due timestamp of specified tasks") + + <> command "unwait" (toParserInfo (UnWaitTasks + <$> some (strArgument idsVar)) + "Erase wait timestamp of specified tasks") + + <> command "unwake" (toParserInfo (UnWakeTasks + <$> some (strArgument idsVar)) + "Erase awake timestamp of specified tasks") + + <> command "unready" (toParserInfo (UnReadyTasks + <$> some (strArgument idsVar)) + "Erase ready timestamp of specified tasks") + + <> command "unreview" (toParserInfo (UnReviewTasks + <$> some (strArgument idsVar)) + "Erase review timestamp of specified tasks") + + <> command "unrepeat" (toParserInfo (UnRepeatTasks + <$> some (strArgument idsVar)) + "Erase repetition duration of specified tasks") + + <> command "unrecur" (toParserInfo (UnRecurTasks + <$> some (strArgument idsVar)) + "Erase recurrence duration of specified tasks") + + <> command "untag" (toParserInfo (UnTagTasks + <$> some (strArgument idsVar)) + "Erase all tags") + + <> command "unnote" (toParserInfo (UnNoteTasks + <$> some (strArgument idsVar)) + "Erase all notes") + + <> command "unprio" (toParserInfo (UnPrioTasks + <$> some (strArgument idsVar)) + "Erase manual priority adjustment") + + <> command "unmeta" (toParserInfo (UnMetaTasks + <$> some (strArgument idsVar)) + "Erase metadata") + ) + + <|> hsubparser (internal <> foldMap getCommand nameToAliasList) + + <|> hsubparser + ( metavar (T.unpack $ snd utils_sec) + <> commandGroup (T.unpack $ fst utils_sec) + + <> command "ulid2utc" (toParserInfo + (UlidToUtc <$> strArgument (metavar "ULID" <> help "The ULID")) + "Extract UTC timestamp from ULID") + + -- <> command "utc-yesterday" + -- <> command "utc-today" + -- <> command "utc-tomorrow" + + -- <> command "utc-monday" + -- <> command "utc-tuesday" + -- <> command "utc-wednesday" + -- <> command "utc-thursday" + -- <> command "utc-friday" + -- <> command "utc-saturday" + -- <> command "utc-sunday" + + -- <> command "utc-month" -- … last day of the month + -- <> command "utc-quarter" -- … last day of the quarter + -- <> command "utc-year" -- … last day of the year + ) + + -- Catch-all parser for any external "tasklite-???" command + -- Do not show in help + <|> ExternalCommand + <$> strArgument P.mempty + <*> optional (some (strArgument P.mempty)) + ) + +{- FOURMOLU_ENABLE -} + + +commandParserInfo :: Config -> ParserInfo Command +commandParserInfo conf = + let + versionDesc = + "Version " + <> versionSlug + <> ", developed by " + <> "\n" + + prettyVersion = + annotate (color Black) (pretty $ showVersion version) + + header = + annotate (bold <> color Blue) "TaskLite" + <+> prettyVersion + <> hardline + <> hardline + <> annotate + (color Blue) + "Task-list manager powered by Haskell and SQLite" + + examples = do + let + mkBold = annotate bold . pretty . T.justifyRight 26 ' ' + hiLite = enclose "`" "`" . annotate (color Cyan) + + "" + <> hardline + <> indent + 2 + ( (mkBold "Add an alias:" <+> hiLite "alias tl tasklite") + <> hardline + <> ( mkBold "Add a task with a tag:" + <+> hiLite "tl add Buy milk +groceries" + ) + <> hardline + <> ( mkBold "… or with the shortcut:" + <+> hiLite "tl buy milk +groceries" + ) + <> hardline + <> ( mkBold "List most important tasks:" + <+> hiLite "tl" + <+> parens ("same as" <+> hiLite "tl ready") + ) + <> hardline + <> (mkBold "Complete it:" <+> hiLite "tl do ") + ) + in + info + (helper <*> commandParser conf) + ( noIntersperse + <> briefDesc + <> headerDoc (Just header) + <> progDescDoc (Just examples) + <> footerDoc (Just $ fromString $ T.unpack versionDesc) + ) + + +groupBySpace :: Text -> [Doc ann] +groupBySpace = + fmap pretty + . T.groupBy + ( \a b -> + isSpace a && isSpace b || not (isSpace a) && not (isSpace b) + ) + + +replaceDoc :: Doc ann -> Doc ann -> [Doc ann] -> [Doc ann] +replaceDoc oldDoc newDoc = + fmap $ \doc -> + if (show oldDoc :: Text) == (show doc :: Text) + then newDoc + else doc + + +{-| +Because optparse-applicative does not support styling group headers, +this function is necessary to splice new Docs into the old Docs +TODO: Remove after https://github.com/pcapriotti/optparse-applicative/issues/485 +-} +spliceDocsIntoText :: [(Text, Doc AnsiStyle)] -> Text -> [Doc AnsiStyle] +spliceDocsIntoText replacements renderedDoc = do + let + docElems = groupBySpace renderedDoc + replaceDocs (txt, doc) = replaceDoc (pretty txt) doc + + foldr replaceDocs docElems replacements + + +helpReplacements :: [(Text, Doc AnsiStyle)] +helpReplacements = + [ basic_sec + , shortcut_sec + , list_sec + , vis_sec + , i_o_sec + , advanced_sec + , alias_sec + , utils_sec + , unset_sec + ] + <&> (\(a, b) -> (a, annotate (colorDull Yellow) (pretty b <> ":"))) + + +getHelpText :: String -> Config -> Doc AnsiStyle +getHelpText progName conf = + parserFailure + defaultPrefs + (commandParserInfo conf) + (ShowHelpText P.Nothing) + [] + & P.flip renderFailure progName + & P.fst + & T.pack + & spliceDocsIntoText helpReplacements + & hcat + + +handleExternalCommand :: Config -> Text -> Maybe [Text] -> IO (Doc AnsiStyle) +handleExternalCommand conf cmd argsMb = do + let + args = + argsMb & P.fromMaybe [] + + runCmd = do + output <- + readProcess + ("tasklite-" <> T.unpack cmd) + (args <&> T.unpack) + "" + pure $ pretty output + + extendHelp :: ParserHelp -> Doc AnsiStyle + extendHelp theHelp = + theHelp + & show + & spliceDocsIntoText helpReplacements + & hcat + + handleException exception = do + hPutDoc P.stderr $ + if not $ exception & show & T.isInfixOf "does not exist" + then pretty (show exception :: Text) + else do + let + theHelp = + parserHelp defaultPrefs $ + (helper <*> commandParser conf) + newHeader = + Chunk + ( Just $ + annotate (color Red) $ + "ERROR: Command \"" + <> pretty cmd + <> "\" does not exist" + ) + <<+>> helpHeader theHelp + + extendHelp theHelp{helpHeader = newHeader} + <+> hardline + <+> hardline + + P.exitFailure + + 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 + + case cliCommandRes of + CompletionInvoked _ -> + P.die "Completion not implemented yet" + -- + Failure failure -> do + failure + & P.flip renderFailure progName + & P.fst + & T.pack + & spliceDocsIntoText helpReplacements + & hcat + & hPutDoc P.stderr + P.exitFailure + -- + Success cliCommand -> do + 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 + QueryTasks query -> queryTasks conf now connection query + RunSql query -> runSql conf query + RunFilter expressions -> runFilter conf now connection expressions + Tags -> listTags conf connection + Projects -> listProjects conf connection + Stats -> getStats conf connection + ImportFile filePath -> importFile conf connection filePath + ImportJson -> importJson conf connection + ImportEml -> importEml conf connection + IngestFile filePath -> ingestFile conf connection filePath + Csv -> dumpCsv conf + Json -> dumpJson conf + Ndjson -> dumpNdjson conf + Sql -> dumpSql conf + Backup -> backupDatabase conf + AddTask bodyWords -> addTaskC bodyWords + AddWrite bodyWords -> addTaskC $ ["Write"] <> bodyWords <> ["+write"] + AddRead bodyWords -> addTaskC $ ["Read"] <> bodyWords <> ["+read"] + AddIdea bodyWords -> addTaskC $ bodyWords <> ["+idea"] + AddWatch bodyWords -> addTaskC $ ["Watch"] <> bodyWords <> ["+watch"] + AddListen bodyWords -> addTaskC $ ["Listen"] <> bodyWords <> ["+listen"] + AddBuy bodyWords -> addTaskC $ ["Buy"] <> bodyWords <> ["+buy"] + AddSell bodyWords -> addTaskC $ ["Sell"] <> bodyWords <> ["+sell"] + AddPay bodyWords -> addTaskC $ ["Pay"] <> bodyWords <> ["+pay"] + AddShip bodyWords -> addTaskC $ ["Ship"] <> bodyWords <> ["+ship"] + LogTask bodyWords -> logTask conf connection bodyWords + ReadyOn datetime ids -> setReadyUtc conf connection datetime ids + WaitTasks ids -> waitTasks conf connection ids + WaitFor duration ids -> waitFor conf connection duration ids + ReviewTasks ids -> + let days3 = Iso.DurationDate (Iso.DurDateDay (Iso.DurDay 3) Nothing) + in reviewTasksIn conf connection days3 ids + 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 + EditTask id -> editTask conf connection id + TrashTasks ids -> trashTasks conf connection ids + DeleteTasks ids -> deleteTasks conf connection ids + RepeatTasks duration ids -> repeatTasks conf connection duration ids + RecurTasks duration ids -> recurTasks conf connection duration ids + BoostTasks ids -> adjustPriority conf 1 ids + HushTasks ids -> adjustPriority conf (-1) ids + Start ids -> startTasks conf connection ids + Stop ids -> stopTasks conf connection ids + 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 + AddTag tagText ids -> addTag conf connection tagText ids + DeleteTag tagText ids -> deleteTag conf connection tagText ids + AddNote noteText ids -> addNote conf connection noteText ids + DeleteNote id -> deleteNote conf connection id + SetDueUtc datetime ids -> setDueUtc conf connection datetime ids + Duplicate ids -> duplicateTasks conf connection ids + CountFiltered taskFilter -> countTasks conf connection taskFilter + {- Unset -} + UnCloseTasks ids -> uncloseTasks conf connection ids + UnDueTasks ids -> undueTasks conf connection ids + UnWaitTasks ids -> unwaitTasks conf connection ids + UnWakeTasks ids -> unwakeTasks conf connection ids + UnReadyTasks ids -> unreadyTasks conf connection ids + UnReviewTasks ids -> unreviewTasks conf connection ids + UnRepeatTasks ids -> unrepeatTasks conf connection ids + UnRecurTasks ids -> unrecurTasks conf connection ids + UnTagTasks ids -> untagTasks conf connection ids + UnNoteTasks ids -> unnoteTasks conf connection ids + UnPrioTasks ids -> unprioTasks conf connection ids + UnMetaTasks ids -> unmetaTasks conf connection ids + Version -> pure $ pretty versionSlug <> hardline + Help -> pure $ getHelpText progName conf + PrintConfig -> pure $ pretty conf + StartServer -> startServer AirGQL.defaultConfig conf + Alias alias _ -> pure $ aliasWarning alias + UlidToUtc ulid -> pure $ pretty $ ulid2utc ulid + ExternalCommand cmd argsMb -> handleExternalCommand conf cmd argsMb + + +printOutput :: String -> Config -> IO () +printOutput appName config = do + let dataPath = config.dataDir + + configNormDataDir <- + if null dataPath + then do + xdgDataDir <- getXdgDirectory XdgData appName + pure $ config{dataDir = xdgDataDir} + else case T.stripPrefix "~/" $ T.pack dataPath of + Nothing -> pure config + Just rest -> do + homeDir <- getHomeDirectory + pure $ config{dataDir = homeDir T.unpack rest} + + let hooksPath = configNormDataDir & hooks & directory + + configNormHookDir <- + if null hooksPath + then + pure $ + configNormDataDir + { hooks = + (configNormDataDir & hooks) + { directory = dataDir configNormDataDir "hooks" + } + } + else case T.stripPrefix "~/" $ T.pack hooksPath of + Nothing -> pure configNormDataDir + Just rest -> do + homeDir <- getHomeDirectory + pure $ + configNormDataDir + { hooks = + (configNormDataDir & hooks) + { directory = homeDir T.unpack rest + } + } + + let hooksPathNorm = configNormHookDir & hooks & directory + + createDirectoryIfMissing True hooksPathNorm + + hookFiles <- listDirectory hooksPathNorm + + hookFilesPerm :: [(FilePath, Permissions)] <- + hookFiles + & filter + ( \name -> + ("pre-" `isPrefixOf` name) || ("post-" `isPrefixOf` name) + ) + <&> (hooksPathNorm ) + & P.mapM + ( \path -> do + perm <- getPermissions path + pure (path, perm) + ) + + hookFilesPermContent <- + hookFilesPerm + & filter (\(_, perm) -> executable perm) + & P.mapM + ( \(filePath, perm) -> do + fileContent <- readFile filePath + pure (filePath, perm, fileContent) + ) + + let configNorm = addHookFilesToConfig configNormHookDir hookFilesPermContent + + preLaunchResult <- executeHooks "" (configNorm.hooks & launch & pre) + putDoc preLaunchResult + + connection <- setupConnection configNorm + + -- For debugging SQLite interactions + -- SQLite.setTrace connection $ Just P.putStrLn + + migrationsStatus <- runMigrations configNorm connection + nowElapsed <- timeCurrentP + + let + now = timeFromElapsedP nowElapsed :: DateTime + + progName <- getProgName + args <- getArgs + postLaunchResult <- + executeHooks + ( TL.toStrict $ + TL.decodeUtf8 $ + Aeson.encode $ + object ["arguments" .= args] + ) + (configNorm.hooks & launch & post) + putDoc postLaunchResult + + doc <- executeCLiCommand configNorm now connection progName args + + -- TODO: Use withConnection instead + SQLite.close connection + + -- TODO: Remove color when piping into other command + putDoc $ migrationsStatus <> doc <> hardline + + +exampleConfig :: Text +exampleConfig = + $( makeRelativeToProject "example-config.yaml" + >>= embedStringFile + ) diff --git a/source/Config.hs b/source/Config.hs new file mode 100644 --- /dev/null +++ b/source/Config.hs @@ -0,0 +1,358 @@ +{-| +The default config primarily defines the styling and formatting +-} +module Config where + +import Protolude as P ( + Applicative (pure), + Char, + Eq ((==)), + FilePath, + Foldable (foldl), + Functor (fmap), + Generic, + Int, + Maybe (..), + Semigroup ((<>)), + Show, + Text, + decodeUtf8, + fromMaybe, + lines, + show, + unlines, + ($), + (&), + (.), + ) + +import Data.Aeson ( + FromJSON (parseJSON), + ToJSON (toJSON), + Value (String), + withObject, + withText, + (.!=), + (.:?), + ) +import Data.Hourglass (TimeFormat (toFormat), TimeFormatString) +import Data.Text as T ( + dropEnd, + isInfixOf, + pack, + replace, + split, + strip, + stripPrefix, + ) +import Data.Yaml (encode) +import Prettyprinter.Internal (Pretty (pretty)) +import Prettyprinter.Render.Terminal ( + AnsiStyle, + Color (..), + color, + colorDull, + ) +import Prettyprinter.Render.Terminal.Internal (ansiForeground) +import System.FilePath (takeBaseName) + + +data Hook = Hook + { filePath :: Maybe FilePath + , interpreter :: Text + , body :: Text + } + deriving (Generic, Show) + + +instance ToJSON Hook +instance FromJSON Hook + + +emptyHook :: Hook +emptyHook = + Hook + { filePath = Nothing + , interpreter = "" + , body = "" + } + + +data HookSet = HookSet + { pre :: [Hook] + , post :: [Hook] + } + deriving (Generic, Show) + + +instance ToJSON HookSet + + +-- | Necessary to make fields optional without using a Maybe type +instance FromJSON HookSet where + parseJSON = withObject "hookSet" $ \o -> do + pre <- o .:? "pre" .!= pre emptyHookSet + post <- o .:? "post" .!= post emptyHookSet + + pure $ HookSet{..} + + +emptyHookSet :: HookSet +emptyHookSet = + HookSet + { pre = [] + , post = [] + } + + +data HooksConfig = HooksConfig + { directory :: FilePath + , launch :: HookSet + , add :: HookSet + , modify :: HookSet + , exit :: HookSet + -- TODO: , delete :: HookSet + } + deriving (Generic, Show) + + +instance ToJSON HooksConfig + + +-- | Necessary to make fields optional without using a Maybe type +instance FromJSON HooksConfig where + parseJSON = withObject "hooksConfig" $ \o -> do + directory <- o .:? "directory" .!= directory defaultHooksConfig + launch <- o .:? "launch" .!= launch defaultHooksConfig + add <- o .:? "add" .!= add defaultHooksConfig + modify <- o .:? "modify" .!= modify defaultHooksConfig + exit <- o .:? "exit" .!= exit defaultHooksConfig + + pure $ HooksConfig{..} + + +defaultHooksConfig :: HooksConfig +defaultHooksConfig = + HooksConfig + { directory = "" + , launch = emptyHookSet + , add = emptyHookSet + , modify = emptyHookSet + , exit = emptyHookSet + } + + +addHookFilesToConfig :: Config -> [(FilePath, b, Text)] -> Config +addHookFilesToConfig = + let + buildHook :: FilePath -> Text -> Hook + buildHook filePath content = + case lines content of + firstLine : rest -> + Hook + { filePath = Just filePath + , interpreter = + firstLine + & T.replace "#!" "" + & T.strip + , body = + rest + & unlines + & T.strip + } + _ -> emptyHook + + addToHookSet :: Hook -> Text -> HookSet -> HookSet + addToHookSet hook stage hookSet = + case stage of + "pre" -> hookSet{pre = hookSet.pre <> [hook]} + "post" -> hookSet{post = hookSet.post <> [hook]} + _ -> hookSet + + addToHooksConfig :: Text -> Text -> Hook -> HooksConfig -> HooksConfig + addToHooksConfig event stage hook hConfig = + case event of + "launch" -> + hConfig + { launch = addToHookSet hook stage (hConfig & launch) + } + "add" -> + hConfig + { add = addToHookSet hook stage (hConfig & add) + } + "modify" -> + hConfig + { modify = addToHookSet hook stage (hConfig & modify) + } + "exit" -> + hConfig + { 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 + + +data Config = Config + { tableName :: Text + , idStyle :: AnsiStyle + , priorityStyle :: AnsiStyle + , dateStyle :: AnsiStyle + , bodyStyle :: AnsiStyle + , bodyClosedStyle :: AnsiStyle + , closedStyle :: AnsiStyle + , dueStyle :: AnsiStyle + , overdueStyle :: AnsiStyle + , tagStyle :: AnsiStyle + , utcFormat :: TimeFormatString + , utcFormatShort :: TimeFormatString + , dataDir :: FilePath + , dbName :: FilePath + , dateWidth :: Int + , bodyWidth :: Int + , prioWidth :: Int + , headCount :: Int + , maxWidth :: Int + , progressBarWidth :: Int + , hooks :: HooksConfig + } + deriving (Generic, Show) + + +-- | Necessary to make fields optional without using a Maybe type +{- FOURMOLU_DISABLE -} +instance FromJSON Config where + parseJSON = withObject "config" $ \o -> do + idStyle <- o .:? "idStyle" .!= defaultConfig.idStyle + priorityStyle <- o .:? "priorityStyle".!= defaultConfig.priorityStyle + tableName <- o .:? "tableName" .!= defaultConfig.tableName + dateStyle <- o .:? "dateStyle" .!= defaultConfig.dateStyle + bodyStyle <- o .:? "bodyStyle" .!= defaultConfig.bodyStyle + bodyClosedStyle <- o .:? "bodyClosedStyle".!= defaultConfig.bodyClosedStyle + closedStyle <- o .:? "closedStyle" .!= defaultConfig.closedStyle + dueStyle <- o .:? "dueStyle" .!= defaultConfig.dueStyle + overdueStyle <- o .:? "overdueStyle" .!= defaultConfig.overdueStyle + tagStyle <- o .:? "tagStyle" .!= defaultConfig.tagStyle + utcFormat <- o .:? "utcFormat" .!= defaultConfig.utcFormat + utcFormatShort <- o .:? "utcFormatShort" .!= defaultConfig.utcFormatShort + dataDir <- o .:? "dataDir" .!= defaultConfig.dataDir + 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 + progressBarWidth <- o .:? "progressBarWidth" + .!= defaultConfig.progressBarWidth + hooks <- o .:? "hooks" .!= defaultConfig.hooks + + pure $ Config{..} + +{- FOURMOLU_ENABLE -} + + +instance ToJSON Config + + +instance Pretty Config where + pretty = + pretty + . dropEnd 1 -- Drop trailing newline to maybe add it later + . decodeUtf8 + . Data.Yaml.encode + + +parseColor :: Text -> Maybe Color +parseColor colorTxt = + let + colorOnly = fromMaybe colorTxt $ stripPrefix "dull " colorTxt + colorToType = \case + "black" -> Just Black + "red" -> Just Red + "green" -> Just Green + "yellow" -> Just Yellow + "blue" -> Just Blue + "magenta" -> Just Magenta + "cyan" -> Just Cyan + "white" -> Just White + _ -> Nothing + in + colorToType colorOnly + + +parseAnsiStyle :: Text -> Maybe AnsiStyle +parseAnsiStyle colorTxt = + let + func = + if "dull" `T.isInfixOf` colorTxt + then colorDull + else color + colorMaybe = parseColor colorTxt + in + fmap func colorMaybe + + +instance FromJSON AnsiStyle where + parseJSON = withText "AnsiStyle" $ \value -> do + pure $ fromMaybe (color Black) $ parseAnsiStyle value + + +instance ToJSON AnsiStyle where + toJSON style = String $ show $ ansiForeground style + + +instance FromJSON TimeFormatString where + parseJSON = withText "TimeFormatString" $ \_ -> do + pure (toFormat ("YYYY-MM-DD H:MI:S" :: [Char])) + + +instance ToJSON TimeFormatString where + toJSON = pure "YYYY-MM-DD H:MI:S" + + +-- instance Pretty AnsiStyle where +-- pretty = pretty . (\_ -> ". " :: Text) + +defaultConfig :: Config +defaultConfig = + Config + { tableName = "tasks" + , idStyle = color Green + , priorityStyle = color Magenta + , dateStyle = color Black + , bodyStyle = color White + , bodyClosedStyle = color Black + , closedStyle = colorDull Black + , dueStyle = color Yellow + , overdueStyle = color Red + , tagStyle = color Blue + , utcFormat = toFormat ("YYYY-MM-DD H:MI:S" :: [Char]) + , utcFormatShort = toFormat ("YYYY-MM-DD H:MI" :: [Char]) + , dataDir = "" + , dbName = "main.db" + , dateWidth = 10 + , bodyWidth = 10 + , prioWidth = 4 + , headCount = 20 + , maxWidth = 120 + , progressBarWidth = 24 + , hooks = + HooksConfig + { directory = "" + , launch = emptyHookSet + , add = emptyHookSet + , modify = emptyHookSet + , exit = emptyHookSet + } + } diff --git a/source/FullTask.hs b/source/FullTask.hs new file mode 100644 --- /dev/null +++ b/source/FullTask.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE QuasiQuotes #-} + +{-| +Data type to represent tasks from the `tasks_view` +-} +module FullTask where + +import Protolude ( + Applicative ((<*>)), + Eq ((==)), + Float, + Generic, + Hashable, + Maybe (Just, Nothing), + Show, + decodeUtf8, + encodeUtf8, + show, + toStrict, + ($), + (.), + (<$>), + (<&>), + (<>), + ) + +import Data.Aeson as Aeson (ToJSON, Value (Object)) +import Data.Aeson.Text as Aeson (encodeToLazyText) +import Data.Csv as Csv ( + DefaultOrdered, + ToField (..), + ToNamedRecord, + ToRecord, + ) +import Data.Text as T (Text, dropEnd, intercalate, split, splitOn) +import Data.Yaml as Yaml (encode) +import Database.SQLite.Simple ( + FromRow (..), + Query, + ResultError (ConversionFailed), + SQLData (SQLNull, SQLText), + field, + ) +import Database.SQLite.Simple.FromField (FromField (..), fieldData, returnError) +import Database.SQLite.Simple.FromRow (fieldWith) +import Database.SQLite.Simple.Internal (Field (Field)) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.QQ (sql) +import GHC.Exception (errorCallException) +import Prettyprinter (Pretty (pretty)) + +import Note (Note (..)) +import Task ( + Task ( + awake_utc, + closed_utc, + due_utc, + modified_utc, + ready_utc, + review_utc, + state, + ulid, + waiting_utc + ), + TaskState, + zeroTask, + ) + + +-- | Final user-facing format of tasks +data FullTask = FullTask + { ulid :: Text -- TODO: Use Ulid type + , body :: Text + , modified_utc :: Text + , awake_utc :: Maybe Text + , ready_utc :: Maybe Text + , waiting_utc :: Maybe Text + , review_utc :: Maybe Text + , due_utc :: Maybe Text + , closed_utc :: Maybe Text + , state :: Maybe TaskState + , group_ulid :: Maybe Text + , repetition_duration :: Maybe Text + , recurrence_duration :: Maybe Text + , tags :: Maybe [Text] + , notes :: Maybe [Note] + , priority :: Maybe Float + , user :: Text + , metadata :: Maybe Aeson.Value + } + deriving (Generic, Show, Eq) + + +-- For conversion from SQLite with SQLite.Simple +instance FromRow FullTask where + fromRow = + FullTask + <$> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + -- Tags + <*> fieldWith + ( \value -> case fieldData value of + SQLText txt -> + -- Parse tags as a comma-separated list + -- TODO: Parse tags as a JSON array + Ok (Just (T.splitOn "," txt)) + SQLNull -> Ok Nothing + val -> + Errors + [ errorCallException $ + "Expected a string, but got: " <> show val + ] + ) + -- Notes + <*> fieldWith + ( \value -> case fieldData value of + SQLText _txt -> + -- TODO: Parse notes as a JSON array + -- Must return a `Just` to signal that notes exist + Ok (Just []) + SQLNull -> Ok Nothing + val -> + Errors + [ errorCallException $ + "Expected a string, but got: " <> show val + ] + ) + <*> field + <*> field + <*> ( field <&> \case + Just (Object obj) -> Just $ Object obj + _ -> Nothing + ) + + +instance FromField [Text] where + fromField (Field (SQLText txt) _) = Ok $ split (== ',') txt + fromField f = returnError ConversionFailed f "expecting SQLText column type" + + +instance FromField [Note] where + fromField (Field (SQLText txt) _) = + let notes = split (== ',') txt + in Ok $ notes <&> Note "" + fromField f = returnError ConversionFailed f "expecting SQLText column type" + + +instance Csv.ToField [Text] where + toField = encodeUtf8 . T.intercalate "," + + +instance Csv.ToField Value where + toField = encodeUtf8 . toStrict . Aeson.encodeToLazyText + + +-- For conversion to CSV +instance ToRecord FullTask +instance ToNamedRecord FullTask +instance DefaultOrdered FullTask + + +instance ToJSON FullTask + + +instance Hashable FullTask + + +instance Pretty FullTask where + pretty = + pretty + . T.dropEnd 1 -- Drop trailing newline to maybe add it later + . decodeUtf8 + . Yaml.encode + + +emptyFullTask :: FullTask +emptyFullTask = + FullTask + { ulid = "" + , body = "" + , modified_utc = "" + , awake_utc = Nothing + , ready_utc = Nothing + , waiting_utc = Nothing + , review_utc = Nothing + , due_utc = Nothing + , closed_utc = Nothing + , state = Nothing + , group_ulid = Nothing + , repetition_duration = Nothing + , recurrence_duration = Nothing + , tags = Nothing + , notes = Nothing + , priority = Nothing + , user = "" + , metadata = Nothing + } + + +selectQuery :: Query +selectQuery = + [sql| + SELECT + tasks_view.ulid AS ulid, + body, + modified_utc, + awake_utc, + ready_utc, + waiting_utc, + review_utc, + due_utc, + closed_utc, + state, + group_ulid, + repetition_duration, + recurrence_duration, + tags, + notes, + priority, + user, + metadata + |] + + +cpTimesAndState :: FullTask -> Task +cpTimesAndState (FullTask{..}) = + zeroTask + { Task.ulid + , Task.modified_utc + , Task.awake_utc + , Task.ready_utc + , Task.waiting_utc + , Task.review_utc + , Task.due_utc + , Task.closed_utc + , Task.state + } diff --git a/source/ImportExport.hs b/source/ImportExport.hs new file mode 100644 --- /dev/null +++ b/source/ImportExport.hs @@ -0,0 +1,792 @@ +{-| +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 "" 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 diff --git a/source/Lib.hs b/source/Lib.hs new file mode 100644 --- /dev/null +++ b/source/Lib.hs @@ -0,0 +1,2966 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use maybe" #-} + +{-| +Functions to create, update, and delete tasks / tags / notes +-} +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) + <++> pretty share + + pure $ + annotate (bold <> underlined) (fill widthKey "State") + <++> annotate (bold <> underlined) (fill widthValue "Value") + <++> annotate (bold <> underlined) "Share" + <> line + <> vsep + [ formatLine "Any" numOfTasksTotal + , formatLine "Open" numOfTasksOpen + , formatLine "Closed" numOfTasksClosed + , formatLine "└─ Done" numOfTasksDone + , formatLine "└─ Obsolete" numOfTasksObsolete + , formatLine "└─ Deletable" numOfTasksDeletable + ] diff --git a/source/Migrations.hs b/source/Migrations.hs new file mode 100644 --- /dev/null +++ b/source/Migrations.hs @@ -0,0 +1,593 @@ +{-# LANGUAGE QuasiQuotes #-} + +{-| +Migrations of SQLite database for new versions +-} +module Migrations where + +import Protolude ( + Applicative (pure), + Bool (False), + Either (..), + Eq ((==)), + Foldable (elem), + Functor (fmap), + IO, + Int, + Ord ((>)), + Read, + Semigroup ((<>)), + Show, + Text, + Traversable (mapM, sequence), + maybeToEither, + show, + try, + ($), + (&), + (&&), + (<$>), + (<&>), + (||), + ) +import Protolude qualified as P + +import Config (Config) +import Database.SQLite.Simple ( + Connection, + FromRow (..), + Query (Query), + SQLError, + execute_, + field, + query_, + withTransaction, + ) +import Database.SQLite.Simple.QQ (sql) +import Prettyprinter (Doc, Pretty (pretty), hardline) + + +newtype UserVersion = UserVersion Int + deriving (Eq, Ord, Read, Show) + + +instance FromRow UserVersion where + fromRow = UserVersion <$> field + + +-- | List of queries for one migration +type QuerySet = [Query] + + +data MigrateDirection = MigrateUp | MigrateDown +data Migration = Migration + { id :: UserVersion + , querySet :: QuerySet + } + deriving (Show) + + +createSetModifiedUtcTrigger :: Query +createSetModifiedUtcTrigger = + [sql| + CREATE TRIGGER set_modified_utc_after_update + AFTER UPDATE ON tasks + WHEN new.modified_utc IS old.modified_utc -- Must be `IS` to handle `NULL` + BEGIN + UPDATE tasks + SET modified_utc = datetime('now') + WHERE ulid == new.ulid; + END + |] + + +createSetClosedUtcTrigger :: Query +createSetClosedUtcTrigger = + [sql| + CREATE TRIGGER set_closed_utc_after_update + AFTER UPDATE ON tasks + WHEN + old.state IS NOT new.state -- Must be `IS NOT` to handle `NULL` + AND ( + new.state == 'Done' OR + new.state == 'Obsolete' OR + new.state == 'Deletable' + ) + BEGIN + UPDATE tasks + SET closed_utc = datetime('now') + WHERE ulid == new.ulid; + END + |] + + +_0_ :: MigrateDirection -> Migration +_0_ = + let + base = + Migration + { id = UserVersion 0 + , querySet = [] + } + in + \case + MigrateUp -> + base + { Migrations.querySet = + [ [sql| + CREATE TABLE tasks ( + ulid TEXT NOT NULL PRIMARY KEY, + body TEXT NOT NULL, + state TEXT check(state IN ('Done','Obsolete','Deletable')) + NOT NULL DEFAULT 'Done', + due_utc TEXT, + closed_utc TEXT, + modified_utc TEXT NOT NULL, + priority_adjustment REAL, + metadata TEXT + ) + |] + , createSetModifiedUtcTrigger + , createSetClosedUtcTrigger + , [sql| + CREATE TABLE task_to_note ( + ulid TEXT NOT NULL PRIMARY KEY, + task_ulid TEXT NOT NULL, + note TEXT NOT NULL, + FOREIGN KEY(task_ulid) REFERENCES tasks(ulid) + ) + |] + , [sql| + CREATE TABLE task_to_tag ( + ulid TEXT NOT NULL PRIMARY KEY, + task_ulid TEXT NOT NULL, + tag TEXT NOT NULL, + FOREIGN KEY(task_ulid) REFERENCES tasks(ulid), + CONSTRAINT no_duplicate_tags UNIQUE (task_ulid, tag) + ) + |] + ] + } + MigrateDown -> base{Migrations.querySet = []} + + +-- | Add field "user" +_1_ :: MigrateDirection -> Migration +_1_ = + let + base = + Migration + { id = UserVersion 1 + , querySet = [] + } + in + \case + MigrateUp -> + base + { Migrations.querySet = + [ "ALTER TABLE tasks\n\ + \ADD COLUMN user TEXT" + ] + } + -- TODO: Fix the invalid create table statement + MigrateDown -> + base + { Migrations.querySet = + [ "CREATE TABLE tasks_temp" + , [sql| + INSERT INTO tasks_temp + SELECT + ulid, + body, + state, + due_utc, + closed_utc, + modified_utc, + priority_adjustment, + metadata + FROM tasks + |] + , "DROP TABLE tasks" + , "ALTER TABLE tasks_temp\n\ + \RENAME TO tasks" + ] + } + + +-- | Make state optional and add state "Deleted", add field "sleep_utc" +_2_ :: MigrateDirection -> Migration +_2_ = + let + base = + Migration + { id = UserVersion 2 + , querySet = [] + } + createTempTableQueryUp = + [sql| + CREATE TABLE tasks_temp ( + ulid TEXT NOT NULL PRIMARY KEY, + body TEXT NOT NULL, + state TEXT check(state IN (NULL, 'Done', 'Obsolete', 'Deleted')), + due_utc TEXT, + sleep_utc TEXT, + closed_utc TEXT, + modified_utc TEXT NOT NULL, + priority_adjustment REAL, + metadata TEXT, + user TEXT + ) + |] + + -- TODO: Finish query + createTempTableQueryDown = Query "CREATE TABLE tasks_temp" + in + \case + MigrateUp -> + base + { Migrations.querySet = + [ createTempTableQueryUp + , [sql| + INSERT INTO tasks_temp + SELECT + ulid, + body, + nullif(nullif(state, 'Open'), 'Waiting') AS state, + due_utc, + NULL, + closed_utc, + modified_utc, + priority_adjustment, + metadata, + user + FROM tasks + |] + , "DROP TABLE tasks" + , "ALTER TABLE tasks_temp\n\ + \RENAME TO tasks" + ] + } + MigrateDown -> + base + { Migrations.querySet = + [ createTempTableQueryDown + , [sql| + INSERT INTO tasks_temp + SELECT + ulid, + body, + state, + due_utc, + closed_utc, + modified_utc, + priority_adjustment, + metadata, + user + FROM tasks + |] + , "DROP TABLE tasks" + , "ALTER TABLE tasks_temp RENAME TO tasks" + ] + } + + +{-| Add fields awake_utc, ready_utc, waiting_utc, review_utc, closed_utc, +group_ulid, repetition_duration, recurrence_duration, +-} +_3_ :: MigrateDirection -> Migration +_3_ = + let + base = + Migration + { id = UserVersion 3 + , querySet = [] + } + createTempTableQueryUp = + [sql| + CREATE TABLE tasks_temp ( + ulid TEXT NOT NULL PRIMARY KEY, + body TEXT NOT NULL, + modified_utc TEXT NOT NULL, + awake_utc TEXT, + ready_utc TEXT, + waiting_utc TEXT, + review_utc TEXT, + due_utc TEXT, + closed_utc TEXT, + state TEXT check(state IN (NULL, 'Done', 'Obsolete', 'Deletable')), + group_ulid TEXT, + repetition_duration TEXT, + recurrence_duration TEXT, + priority_adjustment REAL, + user TEXT, + metadata TEXT + ) + |] + + -- TODO: Finish query + createTempTableQueryDown = Query "CREATE TABLE tasks_temp" + in + \case + MigrateUp -> + base + { Migrations.querySet = + [ createTempTableQueryUp + , [sql| + INSERT INTO tasks_temp + SELECT + ulid, + body, + modified_utc, + sleep_utc, + NULL, + NULL, + NULL, + due_utc, + closed_utc, + state, + NULL, + NULL, + NULL, + priority_adjustment, + user, + metadata + FROM tasks + |] + , "DROP TABLE tasks" + , "ALTER TABLE tasks_temp RENAME TO tasks" + , createSetModifiedUtcTrigger + , createSetClosedUtcTrigger + ] + } + MigrateDown -> + base + { Migrations.querySet = + [ createTempTableQueryDown + , [sql| + INSERT INTO tasks_temp + SELECT + ulid, + body, + state, + due_utc, + closed_utc, + modified_utc, + priority_adjustment, + metadata, + user + FROM tasks + |] + , "DROP TABLE tasks" + , "ALTER TABLE tasks_temp RENAME TO tasks" + ] + } + + +_4_ :: MigrateDirection -> Migration +_4_ = + let + base = + Migration + { id = UserVersion 4 + , querySet = [] + } + in + \case + MigrateUp -> + base + { Migrations.querySet = + [ [sql| + CREATE VIEW tasks_view AS + SELECT + tasks.ulid AS ulid, + tasks.body AS body, + tasks.modified_utc AS modified_utc, + tasks.awake_utc AS awake_utc, + tasks.ready_utc AS ready_utc, + tasks.waiting_utc AS waiting_utc, + tasks.review_utc AS review_utc, + tasks.due_utc AS due_utc, + tasks.closed_utc AS closed_utc, + tasks.state AS state, + tasks.group_ulid AS group_ulid, + tasks.repetition_duration AS repetition_duration, + tasks.recurrence_duration AS recurrence_duration, + group_concat(DISTINCT task_to_tag.tag) AS tags, + group_concat(DISTINCT task_to_note.note) AS notes, + ifnull(tasks.priority_adjustment, 0.0) + + CASE + WHEN awake_utc IS NULL THEN 0.0 + WHEN awake_utc >= datetime('now') THEN -5.0 + WHEN awake_utc >= datetime('now', '-1 days') THEN 1.0 + WHEN awake_utc >= datetime('now', '-2 days') THEN 2.0 + WHEN awake_utc >= datetime('now', '-5 days') THEN 5.0 + WHEN awake_utc < datetime('now', '-5 days') THEN 9.0 + END + + CASE + WHEN waiting_utc IS NULL THEN 0.0 + WHEN waiting_utc >= datetime('now') THEN 0.0 + WHEN waiting_utc < datetime('now') THEN -10.0 + END + + CASE + WHEN review_utc IS NULL THEN 0.0 + WHEN review_utc >= datetime('now') THEN 0.0 + WHEN review_utc < datetime('now') THEN 20.0 + END + + CASE + WHEN due_utc IS NULL THEN 0.0 + WHEN due_utc >= datetime('now', '+24 days') THEN 0.0 + WHEN due_utc >= datetime('now', '+6 days') THEN 3.0 + WHEN due_utc >= datetime('now') THEN 6.0 + WHEN due_utc >= datetime('now', '-6 days') THEN 9.0 + WHEN due_utc >= datetime('now', '-24 days') THEN 12.0 + WHEN due_utc < datetime('now', '-24 days') THEN 15.0 + END + + CASE + WHEN state IS NULL THEN 0.0 + WHEN state == 'Done' THEN 0.0 + WHEN state == 'Obsolete' THEN -1.0 + WHEN state == 'Deletable' THEN -10.0 + END + + CASE count(task_to_note.note) + WHEN 0 THEN 0.0 + ELSE 1.0 + END + + CASE count(task_to_tag.tag) + WHEN 0 THEN 0.0 + ELSE 2.0 + END + AS priority, + tasks.user AS user, + tasks.metadata AS metadata + FROM + tasks + LEFT JOIN task_to_tag ON tasks.ulid == task_to_tag.task_ulid + LEFT JOIN task_to_note ON tasks.ulid == task_to_note.task_ulid + GROUP BY tasks.ulid + |] + , [sql| + CREATE VIEW tags AS + SELECT + task_to_tag_1.tag, + (count(task_to_tag_1.tag) - ifnull(closed_count, 0)) + AS "open", + ifnull(closed_count, 0) AS closed, + round( + cast(ifnull(closed_count, 0) AS REAL) / + count(task_to_tag_1.tag), + 6 + ) AS progress + FROM + task_to_tag AS task_to_tag_1 + LEFT JOIN ( + SELECT tag, count(tasks.ulid) AS closed_count + FROM tasks + LEFT JOIN task_to_tag + ON tasks.ulid IS task_to_tag.task_ulid + WHERE closed_utc IS NOT NULL + GROUP BY tag + ) AS task_to_tag_2 + ON task_to_tag_1.tag IS task_to_tag_2.tag + GROUP BY task_to_tag_1.tag + ORDER BY task_to_tag_1.tag ASC + |] + ] + } + MigrateDown -> base{Migrations.querySet = []} + + +hasDuplicates :: (Eq a) => [a] -> Bool +hasDuplicates [] = False +hasDuplicates (x : xs) = + x `elem` xs || hasDuplicates xs + + +wrapQuery :: UserVersion -> QuerySet -> QuerySet +wrapQuery (UserVersion userVersion) querySet = + ["PRAGMA foreign_keys = OFF"] + <> querySet + <> [ "PRAGMA foreign_key_check" + , "PRAGMA user_version = " <> Query (show userVersion) + ] + + +wrapMigration :: Migration -> Migration +wrapMigration migration = + migration + { querySet = + wrapQuery (Migrations.id migration) (Migrations.querySet migration) + } + + +lintQuery :: Query -> Either Text Query +lintQuery = Right + + +-- TODO: Reactivate after +-- https://github.com/JakeWheat/simple-sql-parser/issues/20 is fixed +-- let +-- queryStr = T.unpack $ fromQuery sqlQuery +-- result = parseStatements ansi2011 "migration" Nothing queryStr +-- in case result of +-- Left error -> Left (show error) +-- Right _ -> Right sqlQuery + +lintMigration :: Migration -> Either Text Migration +lintMigration migration = + migration + & Migrations.querySet + & mapM lintQuery + <&> P.const migration + + +runMigration :: Connection -> [Query] -> IO (Either SQLError [()]) +runMigration connection querySet = do + withTransaction connection $ do + try $ mapM (execute_ connection) querySet + + +-- Following doesn't work due to +-- https://github.com/nurpax/sqlite-simple/issues/44 +-- try $ execute_ connection $ P.fold $ querySet <&> (<> ";\n") + +runMigrations :: Config -> Connection -> IO (Doc ann) +runMigrations _ connection = do + currentVersionList <- + query_ + connection + "PRAGMA user_version" + :: IO [UserVersion] + + let + migrations = [_0_, _1_, _2_, _3_, _4_] + + migrationsUp = fmap ($ MigrateUp) migrations + (UserVersion userVersionMax) = + migrationsUp + <&> Migrations.id + & P.maximum + + migrationsUpLinted :: Either Text [Migration] + migrationsUpLinted = do + currentVersion <- + maybeToEither + "`PRAGMA user_version` does not return current version" + (P.head currentVersionList) + + -- Check if duplicate user versions are defined + _ <- + if migrationsUp <&> Migrations.id & hasDuplicates + then Left "Your migrations contain duplicate user versions" + else Right [] + + -- Get new migrations, lint and wrap them + migrationsUp + & P.filter + ( \m -> + Migrations.id m > currentVersion + || (Migrations.id m == UserVersion 0) + && (currentVersion == UserVersion 0) + ) + <&> lintMigration + & mapM (fmap wrapMigration) + + case migrationsUpLinted of + Left error -> pure $ pretty error + Right [] -> pure "" + Right migsUpLinted -> do + result <- + migsUpLinted + <&> Migrations.querySet + & mapM (runMigration connection) + + case sequence result of + Left error -> pure $ pretty (show error :: Text) + Right _ -> do + execute_ connection $ + Query $ + "PRAGMA user_version = " <> show userVersionMax + pure $ + ( "Migration succeeded. New user-version: " + <> pretty userVersionMax + ) + <> hardline diff --git a/source/Note.hs b/source/Note.hs new file mode 100644 --- /dev/null +++ b/source/Note.hs @@ -0,0 +1,82 @@ +module Note where + +import Data.Aeson ( + FromJSON (parseJSON), + ToJSON, + withObject, + (.:), + (.:?), + ) +import Data.Csv qualified as Csv +import Data.Text as T (Text, intercalate, toLower) +import Data.ULID (ulidFromInteger) +import Database.SQLite.Simple (FromRow, ToRow, field, fromRow, toRow) +import Database.SQLite.Simple.ToField (toField) +import Protolude ( + Alternative ((<|>)), + Applicative (pure), + Eq, + Functor (fmap), + Generic, + Hashable (hash), + Integral (toInteger), + Num (abs), + Semigroup ((<>)), + Show, + encodeUtf8, + fromMaybe, + hush, + show, + ($), + (.), + (<$>), + (<&>), + (<*>), + ) + + +data Note = Note + { ulid :: Text + , body :: Text + } + deriving (Generic, Show, Eq) + + +instance ToRow Note where + toRow Note{ulid = ulid, body = body} = + [ toField ulid + , toField body + ] + + +instance FromRow Note where + fromRow = Note <$> field <*> field + + +instance ToJSON Note + + +instance FromJSON Note where + parseJSON = withObject "note" $ \o -> do + o_ulid <- o .:? "ulid" + + let + ulidGenerated = (ulidFromInteger . abs . toInteger . hash) o + ulid = + T.toLower $ + fromMaybe "" $ + o_ulid <|> hush (ulidGenerated <&> show) + + body <- o .: "body" + + pure Note{..} + + +instance Hashable Note + + +instance Csv.ToField [Note] where + toField = + encodeUtf8 + . T.intercalate "," + . fmap (\Note{ulid = ulid, body = body} -> ulid <> ": " <> body) diff --git a/source/Server.hs b/source/Server.hs new file mode 100644 --- /dev/null +++ b/source/Server.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE DataKinds #-} + +module Server where + +import Protolude ( + Applicative (pure), + Eq ((==)), + IO, + Int, + Maybe (Just, Nothing), + Proxy (Proxy), + Semigroup ((<>)), + Text, + const, + putText, + show, + ($), + (&), + (||), + ) +import Protolude qualified as P + +import Data.Aeson (Object) +import Data.Text qualified as T +import Network.Wai (Application, Middleware) +import Network.Wai.Application.Static (defaultWebAppSettings) +import Network.Wai.Handler.Warp ( + defaultSettings, + runSettings, + setOnException, + setPort, + ) +import Network.Wai.Middleware.Cors ( + cors, + corsMethods, + corsRequestHeaders, + simpleCorsResourcePolicy, + simpleMethods, + ) +import Network.Wai.Parse ( + defaultParseRequestBodyOptions, + setMaxRequestFilesSize, + setMaxRequestNumFiles, + ) +import Prettyprinter (Doc) +import Prettyprinter.Render.Terminal (AnsiStyle) +import Servant ( + Context (EmptyContext, (:.)), + NoContent, + err303, + serveDirectoryWith, + ) +import Servant.API ( + Get, + JSON, + PlainText, + Post, + Raw, + ReqBody, + (:<|>) ((:<|>)), + (:>), + ) +import Servant.HTML.Blaze (HTML) +import Servant.Multipart ( + MultipartOptions (generalOptions), + Tmp, + defaultMultipartOptions, + ) +import Servant.Server (Server) +import Servant.Server qualified as Servant +import WaiAppStatic.Types ( + LookupResult (LRFile, LRFolder, LRNotFound), + StaticSettings (ssLookupFile), + unsafeToPiece, + ) + +import AirGQL.Config qualified as AirGQL (Config (maxDbSize), defaultConfig) +import AirGQL.ExternalAppContext ( + ExternalAppContext ( + ExternalAppContext, + baseUrl, + sqlite, + sqliteLib + ), + ) +import AirGQL.Lib (SQLPost) +import AirGQL.Servant.Database ( + apiDatabaseSchemaGetHandler, + apiDatabaseVacuumPostHandler, + ) +import AirGQL.Servant.GraphQL ( + gqlQueryPostHandler, + playgroundDefaultQueryHandler, + readOnlyGqlPostHandler, + ) +import AirGQL.Servant.SqlQuery (sqlQueryPostHandler) +import AirGQL.Types.SchemaConf (SchemaConf (pragmaConf), defaultSchemaConf) +import AirGQL.Types.SqlQueryPostResult (SqlQueryPostResult) +import AirGQL.Types.Types (GQLPost) +import Config as TaskLite (Config) +import Lib (getDbPath) + + +{- FOURMOLU_DISABLE -} +-- ATTENTION: Order of handlers matters! +type PlatformAPI = + -- sqlQueryPostHandler + "sql" + :> ReqBody '[JSON] SQLPost + :> Post '[JSON] SqlQueryPostResult + + -- Redirect to GraphiQL playground + -- redirectToPlayground + :<|> "graphql" :> Get '[HTML] NoContent + + -- gqlQueryPostHandler + :<|> "graphql" + :> ReqBody '[JSON] GQLPost + :> Post '[JSON] Object + + -- readOnlyGqlPostHandler + :<|> "readonly" :> "graphql" + :> ReqBody '[JSON] GQLPost + :> Post '[JSON] Object + + -- playgroundDefaultQueryHandler + :<|> "playground" :> "default-query" + :> Get '[PlainText] Text + + -- apiDatabaseSchemaGetHandler + :<|> "schema" + :> Get '[PlainText] Text + + -- apiDatabaseVacuumPostHandler + :<|> "vacuum" + :> Post '[JSON] Object + +{- FOURMOLU_ENABLE -} + + +platformAPI :: Proxy (PlatformAPI :<|> Raw) +platformAPI = Proxy + + +redirectToPlayground :: Servant.Handler a +redirectToPlayground = + P.throwError + err303 + { Servant.errHeaders = + [("Location", P.encodeUtf8 "/graphiql")] + } + + +platformServer :: ExternalAppContext -> Text -> Server PlatformAPI +platformServer ctx dbPath = do + sqlQueryPostHandler defaultSchemaConf.pragmaConf dbPath + :<|> redirectToPlayground + :<|> gqlQueryPostHandler defaultSchemaConf dbPath + :<|> readOnlyGqlPostHandler dbPath + :<|> playgroundDefaultQueryHandler dbPath + :<|> apiDatabaseSchemaGetHandler ctx dbPath + :<|> apiDatabaseVacuumPostHandler dbPath + + +platformApp :: ExternalAppContext -> Text -> Application +platformApp ctx dbPath = do + let + maxFileSizeInByte :: Int = AirGQL.defaultConfig.maxDbSize + + multipartOpts :: MultipartOptions Tmp + multipartOpts = + (defaultMultipartOptions (Proxy :: Proxy Tmp)) + { generalOptions = + setMaxRequestNumFiles 1 $ + setMaxRequestFilesSize + (P.fromIntegral maxFileSizeInByte) + defaultParseRequestBodyOptions + } + + context :: Context '[MultipartOptions Tmp] + context = + multipartOpts :. EmptyContext + + webappServerSettings :: Text -> StaticSettings + webappServerSettings root = + let + webAppSettings = defaultWebAppSettings $ T.unpack root + + lookup pieces = do + lookupResult <- ssLookupFile webAppSettings pieces + case lookupResult of + LRFile file -> pure $ LRFile file + LRFolder folder -> pure $ LRFolder folder + LRNotFound -> + ssLookupFile + webAppSettings + [unsafeToPiece "index.html"] + in + webAppSettings{ssLookupFile = lookup} + + Servant.serveWithContext platformAPI context $ + platformServer ctx dbPath + :<|> serveDirectoryWith (webappServerSettings "tasklite-app/build") + + +corsMiddleware :: Middleware +corsMiddleware = + let + policy = + simpleCorsResourcePolicy + { corsRequestHeaders = ["Content-Type", "Authorization"] + , corsMethods = "PUT" : simpleMethods + } + in + cors (const $ Just policy) + + +-- | Uses AirGQL to provide a GraphQL endpoint at /graphql +startServer :: AirGQL.Config -> TaskLite.Config -> IO (Doc AnsiStyle) +startServer _airgqlConf taskliteConf = do + let + port :: Int = 7458 + + runWarp = + runSettings $ + defaultSettings + & setPort port + & setOnException + ( \_ exception -> do + let exceptionText :: Text = show exception + if (exceptionText == "Thread killed by timeout manager") + || ( exceptionText + == "Warp: Client closed connection prematurely" + ) + then pure () + else do + putText exceptionText + ) + + ctx = + ExternalAppContext + { sqlite = "" + , sqliteLib = Nothing + , baseUrl = "" + } + + putText $ + "\n\n" + <> "Starting GraphQL server at http://localhost:" + <> show port + <> "/graphql" + + dbPath <- P.liftIO $ getDbPath taskliteConf + + runWarp $ corsMiddleware $ platformApp ctx (T.pack dbPath) + + pure P.mempty diff --git a/source/SqlUtils.hs b/source/SqlUtils.hs new file mode 100644 --- /dev/null +++ b/source/SqlUtils.hs @@ -0,0 +1,335 @@ +{-| +Utils to simplify creation of SQL queries +-} +module SqlUtils where + +import Protolude as P ( + Applicative (pure), + Bool (False), + Either (..), + Eq ((==)), + Float, + Foldable (fold), + Functor (fmap), + IO, + Integer, + Maybe (..), + Semigroup ((<>)), + Show, + Text, + show, + take, + try, + unlines, + unwords, + words, + ($), + (&), + ) + +import Data.Text qualified as T +import Database.SQLite.Simple as Sql ( + Connection, + Query (..), + SQLError (sqlErrorDetails), + execute_, + ) +import Language.SQL.SimpleSQL.Syntax ( + Alias (..), + Direction (Asc, Desc), + GroupingExpr (SimpleGroup), + JoinCondition (JoinOn), + JoinType (JLeft), + Name (..), + NullsOrder (NullsOrderDefault), + ScalarExpr (App, BinOp, Cast, Iden, NumLit, PostfixOp), + SortSpec (..), + TableRef (TRAlias, TRJoin, TRSimple), + TypeName (TypeName), + ) +import Prettyprinter (Doc, pretty) + + +id :: Name -> ScalarExpr +id columnName = + Iden [columnName] + + +ids :: [Name] -> ScalarExpr +ids = Iden + + +tableCol :: Name -> Name -> ScalarExpr +tableCol table column = + Iden [table, column] + + +col :: Name -> ScalarExpr +col column = + Iden [column] + + +count :: ScalarExpr -> ScalarExpr +count column = + App + [Name Nothing "count"] + [column] + + +ifNull :: Name -> Text -> ScalarExpr +ifNull ifValue thenValue = + App + [Name Nothing "ifnull"] + [ Iden [ifValue] + , NumLit $ T.unpack thenValue + ] + + +dot :: Name -> Name -> ScalarExpr +dot item subItem = + ids [item, subItem] + + +is :: ScalarExpr -> ScalarExpr -> ScalarExpr +is exprA = + BinOp exprA [Name Nothing "is"] + + +isNotNull :: Name -> ScalarExpr +isNotNull columnName = + PostfixOp + [Name Nothing "is not null"] + (Iden [columnName]) + + +as :: ScalarExpr -> Name -> (ScalarExpr, Maybe Name) +as column aliasName@(Name _ theAlias) = + ( column + , if theAlias == "" + then Nothing + else Just aliasName + ) + + +-- as column otherAlias = (column, Just otherAlias) + +groupBy :: ScalarExpr -> GroupingExpr +groupBy = SimpleGroup + + +orderByAsc :: ScalarExpr -> SortSpec +orderByAsc column = + SortSpec column Asc NullsOrderDefault + + +orderByDesc :: ScalarExpr -> SortSpec +orderByDesc column = + SortSpec column Desc NullsOrderDefault + + +leftJoinOn :: Name -> Name -> ScalarExpr -> TableRef +leftJoinOn tableA tableB joinOnExpr = + TRJoin + (TRSimple [tableA]) + False + JLeft + (TRSimple [tableB]) + (Just (JoinOn joinOnExpr)) + + +leftTRJoinOn :: TableRef -> TableRef -> ScalarExpr -> TableRef +leftTRJoinOn tableA tableB joinOnExpr = + TRJoin + tableA + False + JLeft + tableB + (Just (JoinOn joinOnExpr)) + + +castTo :: ScalarExpr -> Text -> ScalarExpr +castTo scalarExpr castType = + Cast + scalarExpr + (TypeName [Name Nothing $ T.unpack castType]) + + +add :: ScalarExpr -> ScalarExpr -> ScalarExpr +add valueA = + BinOp valueA [Name Nothing "+"] + + +sub :: ScalarExpr -> ScalarExpr -> ScalarExpr +sub valueA = + BinOp valueA [Name Nothing "-"] + + +div :: ScalarExpr -> ScalarExpr -> ScalarExpr +div valueA = + BinOp valueA [Name Nothing "/"] + + +roundTo :: Integer -> ScalarExpr -> ScalarExpr +roundTo numOfDigits column = + App + [Name Nothing "round"] + [ column + , NumLit $ show numOfDigits + ] + + +alias :: Name -> Alias +alias aliasName = + Alias aliasName Nothing + + +fromAs :: Name -> Name -> TableRef +fromAs tableName aliasName = + TRAlias + (TRSimple [tableName]) + (alias aliasName) + + +-- | Escape double quotes in SQL strings +escDoubleQuotes :: Text -> Text +escDoubleQuotes = + T.replace "\"" "\"\"" + + +-- | Quote a keyword in an SQL query +quoteKeyword :: Text -> Text +quoteKeyword keyword = + keyword + & escDoubleQuotes + & (\word -> "\"" <> word <> "\"") + + +-- | Escape single quotes in SQL strings +escSingleQuotes :: Text -> Text +escSingleQuotes = + T.replace "'" "''" + + +-- | Quote literal text in an SQL query +quoteText :: Text -> Text +quoteText keyword = + keyword + & escSingleQuotes + & (\word -> "'" <> word <> "'") + + +getValue :: (Show a) => a -> Text +getValue value = + "'" <> show value <> "'" + + +getTable :: Text -> [Text] -> Query +getTable tableName columns = + Query $ + T.unlines + [ "CREATE TABLE \"" <> tableName <> "\" (" + , T.intercalate ",\n" columns + , ")" + ] + + +getColumns :: Text -> [Text] -> Query +getColumns tableName columns = + Query $ + unlines + [ "SELECT" + , " " <> T.intercalate ",\n " columns <> "\n" + , "FROM \"" <> tableName <> "\"" + ] + + +getSelect :: [Text] -> Text -> Text -> Query +getSelect selectLines fromStatement groupByColumn = + Query $ + T.unlines + [ "SELECT" + , T.intercalate ",\n" selectLines + , "FROM" + , fromStatement + , "GROUP BY " <> groupByColumn + ] + + +getView :: Text -> Query -> Query +getView viewName selectQuery = + Query $ + T.unlines + [ "CREATE VIEW \"" <> viewName <> "\" AS" + , fromQuery selectQuery + ] + + +createWithQuery :: Connection -> Query -> IO (Doc ann) +createWithQuery connection theQuery = do + result <- try $ execute_ connection theQuery + + let + output = case result :: Either SQLError () of + Left errorMessage -> + if "already exists" `T.isSuffixOf` sqlErrorDetails errorMessage + then "" + else T.pack $ show errorMessage <> "\n" + Right _ -> + "🆕 " <> unwords (P.take 3 $ words $ show theQuery) <> "… \n" + + pure $ pretty output + + +createTableWithQuery :: Connection -> Text -> Query -> IO (Doc ann) +createTableWithQuery connection aTableName theQuery = do + result <- try $ execute_ connection theQuery + + let + output = case result :: Either SQLError () of + Left errorMessage -> + if "already exists" `T.isSuffixOf` sqlErrorDetails errorMessage + then "" + else T.pack $ show errorMessage <> "\n" + Right _ -> "🆕 Create table \"" <> aTableName <> "\"\n" + + pure $ pretty output + + +replaceTableWithQuery :: Connection -> Text -> Query -> IO (Doc ann) +replaceTableWithQuery connection aTableName theQuery = do + execute_ connection $ + Query $ + "DROP TABLE IF EXISTS \"" <> aTableName <> "\"" + result <- try $ execute_ connection theQuery + + let + output = case result :: Either SQLError () of + Left errorMessage -> T.pack $ show errorMessage <> "\n" + Right _ -> "🆕 Replace table \"" <> aTableName <> "\"\n" + + pure $ pretty output + + +getCase :: Maybe Text -> [(Text, Float)] -> Text +getCase fieldNameMaybe valueMap = + "CASE " + <> case fieldNameMaybe of + Nothing -> "" + Just fName -> "\"" <> fName <> "\"" + <> P.fold + ( fmap + (\(key, val) -> " WHEN " <> key <> " THEN " <> show val <> "\n") + valueMap + ) + <> " END " + + +createTriggerAfterUpdate :: Text -> Text -> Text -> Text -> Query +createTriggerAfterUpdate name tableName whenBlock body = + Query $ + ("CREATE TRIGGER \"" <> name <> "_after_update\"\n") + <> ("AFTER UPDATE ON \"" <> tableName <> "\"\n") + <> ("WHEN " <> whenBlock) + <> "\nBEGIN\n" + <> (" " <> body <> ";\n") + <> "END\n" diff --git a/source/Task.hs b/source/Task.hs new file mode 100644 --- /dev/null +++ b/source/Task.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use uncurry" #-} + +{-| +Datatype to represent a task as stored in the `tasks` table +-} +module Task where + +import Protolude ( + Applicative ((<*>)), + Either (Left, Right), + Enum (toEnum), + Eq ((==)), + Float, + Functor (fmap), + Generic, + Hashable, + Maybe (..), + Ord ((<), (>)), + Read, + Semigroup ((<>)), + Show, + decodeUtf8, + fst, + otherwise, + pure, + show, + snd, + ($), + (&), + (&&), + (.), + (<$>), + (<&>), + ) +import Protolude qualified as P + +import Data.Aeson as Aeson ( + FromJSON, + ToJSON, + Value (Object), + eitherDecodeStrictText, + encode, + ) +import Data.Aeson.Key as Key (fromText) +import Data.Aeson.KeyMap as KeyMap (fromList, insert) +import Data.ByteString.Lazy qualified as BSL +import Data.Csv qualified as Csv +import Data.Generics (Data) +import Data.Hourglass (DateTime, timePrint) +import Data.Text (Text, pack) +import Data.Text qualified as T +import Data.Yaml as Yaml (encode) +import Database.SQLite.Simple as Sql ( + FromRow (..), + ResultError (ConversionFailed), + SQLData (SQLText), + ToRow (toRow), + field, + ) +import Database.SQLite.Simple.FromField as Sql.FromField ( + FromField (..), + returnError, + ) +import Database.SQLite.Simple.Internal (Field (Field)) +import Database.SQLite.Simple.Ok (Ok (Ok)) +import Database.SQLite.Simple.ToField as Sql.ToField (ToField (..), toField) +import Generic.Random (genericArbitrary, genericArbitraryU, (%)) +import Prettyprinter (Pretty (pretty)) +import Test.QuickCheck (Arbitrary (arbitrary)) +import Test.QuickCheck.Instances.Text () + +import Config (defaultConfig, utcFormat) +import Database.SQLite.Simple (Connection, Only (Only), query) +import Database.SQLite.Simple.QQ (sql) + + +data TaskState + = Done + | Obsolete + | Deletable + deriving (Eq, Enum, Generic, Ord, Read, Show, Data) + + +instance Arbitrary TaskState where + arbitrary = genericArbitrary (4 % 2 % 1 % ()) + + +instance Sql.FromField.FromField TaskState where + fromField f@(Field (SQLText txt) _) = + case textToTaskState txt of + Just val -> Ok val + Nothing -> + returnError ConversionFailed f $ + T.unpack $ + "expecting a valid TaskState and not \"" <> txt <> "\"" + fromField f = + returnError ConversionFailed f "expecting SQLText column type" + + +instance Sql.ToField.ToField TaskState where + toField = SQLText . show + + +instance FromJSON TaskState +instance ToJSON TaskState + + +instance Csv.ToRecord TaskState +instance Csv.ToNamedRecord TaskState + + +instance Csv.ToField TaskState where + toField = show + + +instance Hashable TaskState + + +stateDefault :: TaskState +stateDefault = toEnum 0 + + +stateOptions :: Text +stateOptions = + T.intercalate "," $ + fmap (("'" <>) . (<> "'") . show) [stateDefault ..] + + +textToTaskState :: Text -> Maybe TaskState +textToTaskState txt = + let + func t + | t `P.elem` ["done", "completed", "finished", "fixed"] = Just Done + | t `P.elem` ["obsolete"] = Just Obsolete + | t + `P.elem` [ "deletable" + , "deleted" + , "removable" + , "removed" + ] = + Just Deletable + | otherwise = Nothing + txtLower = T.toLower txt + in + func txtLower + + +data DerivedState + = IsOpen + | IsClosed + | IsAsleep + | IsAwake + | IsReady + | IsWaiting + | IsReview + | IsDone + | IsObsolete + | IsDeletable + | IsBlocked + deriving (Eq, Generic, Show) + + +instance Arbitrary DerivedState where + arbitrary = genericArbitraryU + + +{-| A tuple of (Primary State, Secondary State) + | Check out tasklite.org/concepts for a + | detailed explanation of the different states + | and how they relate to each other +-} +type StateHierarchy = (DerivedState, DerivedState) + + +instance {-# OVERLAPS #-} Pretty StateHierarchy where + pretty stateH = + ( if fst stateH == snd stateH + then show $ fst stateH + else + [fst stateH, snd stateH] + <&> show + & T.intercalate " and " + ) + & T.replace "Is" "" + & pretty + + +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 + + +derivedStateToQuery :: DerivedState -> Text +derivedStateToQuery = \case + IsOpen -> "closed_utc is null" + IsClosed -> "closed_utc is not null" + IsAsleep -> + "awake_utc > datetime('now') and \ + \(ready_utc is null or ready_utc > datetime('now')) \ + \and closed_utc is null" + IsAwake -> + "awake_utc < datetime('now') and \ + \(ready_utc is null or ready_utc > datetime('now')) \ + \and closed_utc is null" + IsReady -> + "(awake_utc is null or awake_utc < datetime('now')) \ + \and ready_utc < datetime('now') \ + \and closed_utc is null" + IsWaiting -> + "waiting_utc is not null and \ + \(review_utc is null or review_utc > datetime('now')) \ + \and closed_utc is null" + IsReview -> + "waiting_utc is not null and \ + \(review_utc is null or review_utc < datetime('now')) \ + \and closed_utc is null" + IsDone -> "closed_utc is not null and state is 'Done'" + IsObsolete -> "closed_utc is not null and state is 'Obsolete'" + IsDeletable -> "closed_utc is not null and state is 'Deletable'" + IsBlocked -> "" -- TODO + + +getStateHierarchy :: DateTime -> Task -> StateHierarchy +getStateHierarchy now task = do + let + nowTxt = pack $ timePrint (utcFormat defaultConfig) now + + case Task.state task of + Just Done -> (IsClosed, IsDone) + Just Obsolete -> (IsClosed, IsObsolete) + Just Deletable -> (IsClosed, IsDeletable) + Nothing -> case closed_utc task of + Just _ -> (IsClosed, IsClosed) + Nothing -> case review_utc task of + Just val -> + if val > nowTxt + then (IsOpen, IsWaiting) + else (IsOpen, IsReview) + Nothing -> case waiting_utc task of + Just _ -> (IsOpen, IsWaiting) + Nothing -> case (ready_utc task, awake_utc task) of + (Just readyUtc, Just awakeUtc) -> + if readyUtc < nowTxt && awakeUtc < nowTxt + then (IsOpen, IsReady) + else + if readyUtc > nowTxt && awakeUtc < nowTxt + then (IsOpen, IsAwake) + else (IsOpen, IsAsleep) + (Just readyUtc, Nothing) | readyUtc < nowTxt -> (IsOpen, IsReady) + (Nothing, Just awakeUtc) | awakeUtc < nowTxt -> (IsOpen, IsAwake) + (Nothing, Just awakeUtc) | awakeUtc > nowTxt -> (IsOpen, IsAsleep) + _ -> (IsOpen, IsOpen) + + +newtype Ulid = Ulid Text + + +data Task = Task + { ulid :: Text -- TODO: Use Ulid type + , body :: Text + , modified_utc :: Text + , awake_utc :: Maybe Text + , ready_utc :: Maybe Text + , waiting_utc :: Maybe Text + , review_utc :: Maybe Text + , due_utc :: Maybe Text + , closed_utc :: Maybe Text + , state :: Maybe TaskState + , group_ulid :: Maybe Text + , repetition_duration :: Maybe Text + , recurrence_duration :: Maybe Text + , priority_adjustment :: Maybe Float + , user :: Text + , metadata :: Maybe Aeson.Value + } + deriving (Generic, Data, Show, Eq) + + +-- For conversion from SQLite with SQLite.Simple +instance FromRow Task where + fromRow = + Task + <$> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> ( field <&> \case + Just (Object obj) -> Just $ Object obj + _ -> Nothing + ) + + +instance ToRow Task where + toRow task = + [ Sql.ToField.toField task.ulid + , Sql.ToField.toField task.body + , Sql.ToField.toField task.modified_utc + , Sql.ToField.toField task.awake_utc + , Sql.ToField.toField task.ready_utc + , Sql.ToField.toField task.waiting_utc + , Sql.ToField.toField task.review_utc + , Sql.ToField.toField task.due_utc + , Sql.ToField.toField task.closed_utc + , Sql.ToField.toField task.state + , Sql.ToField.toField task.group_ulid + , Sql.ToField.toField task.repetition_duration + , 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) + ] + + +instance Hashable Task + + +instance Sql.FromField.FromField Value where + fromField aField@(Field (SQLText txt) _) = + case eitherDecodeStrictText txt of + Left error -> returnError ConversionFailed aField error + Right value -> Ok value + fromField f = returnError ConversionFailed f "expecting SQLText column type" + + +-- For conversion to JSON +instance ToJSON Task + + +instance Pretty Task where + pretty = + pretty + . T.dropEnd 1 -- Drop trailing newline to maybe add it later + . decodeUtf8 + . Yaml.encode + + +instance Arbitrary Task where + arbitrary = genericArbitraryU + + +zeroTask :: Task +zeroTask = + Task + { ulid = "" + , body = "" + , modified_utc = "" + , awake_utc = Nothing + , ready_utc = Nothing + , waiting_utc = Nothing + , review_utc = Nothing + , due_utc = Nothing + , closed_utc = Nothing + , state = Nothing + , group_ulid = Nothing + , repetition_duration = Nothing + , recurrence_duration = Nothing + , priority_adjustment = Nothing + , user = "" + , metadata = Nothing + } + + +setMetadataField :: Text -> Value -> Task -> Task +setMetadataField fieldNameText value task = + task + { metadata = + case metadata task of + Just (Object obj) -> + Just $ Object $ KeyMap.insert (Key.fromText fieldNameText) value obj + Nothing -> + Just $ Object $ fromList [(Key.fromText fieldNameText, value)] + _ -> metadata task + } + + +{-| Convert a task to a YAML string 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 + (tags :: [[P.Text]]) <- + query + conn + [sql| + SELECT tag + FROM task_to_tag + WHERE task_ulid == ? + |] + (Only $ ulid task) + + (notes :: [[P.Text]]) <- + query + conn + [sql| + SELECT note + FROM task_to_note + WHERE task_ulid == ? + |] + (Only $ ulid task) + + let indentNoteContent noteContent = + noteContent + & T.strip + & T.lines + <&> T.stripEnd + & T.intercalate "\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 diff --git a/source/TaskToNote.hs b/source/TaskToNote.hs new file mode 100644 --- /dev/null +++ b/source/TaskToNote.hs @@ -0,0 +1,56 @@ +module TaskToNote where + +import Protolude as P ( + Eq, + Generic, + Show, + Text, + decodeUtf8, + (.), + (<$>), + (<*>), + ) + +import Data.Generics (Data) +import Data.Text as T (dropEnd) +import Data.Yaml as Yaml (ToJSON, encode) +import Database.SQLite.Simple (FromRow, field, fromRow, toRow) +import Database.SQLite.Simple.ToField (toField) +import Database.SQLite.Simple.ToRow (ToRow) +import Prettyprinter (Pretty (pretty)) + + +-- | Record for storing entries of the `task_to_note` table +data TaskToNote = TaskToNote + { ulid :: Text -- Ulid + , task_ulid :: Text + , note :: Text + } + deriving (Show, Eq, Generic, Data) + + +instance FromRow TaskToNote where + fromRow = + TaskToNote + <$> field + <*> field + <*> field + + +instance ToRow TaskToNote where + toRow TaskToNote{..} = + [ toField ulid + , toField task_ulid + , toField note + ] + + +instance ToJSON TaskToNote + + +instance Pretty TaskToNote where + pretty = + pretty + . T.dropEnd 1 -- Drop trailing newline to maybe add it later + . decodeUtf8 + . Yaml.encode diff --git a/source/TaskToTag.hs b/source/TaskToTag.hs new file mode 100644 --- /dev/null +++ b/source/TaskToTag.hs @@ -0,0 +1,55 @@ +module TaskToTag where + +import Protolude as P ( + Eq, + Generic, + Show, + Text, + decodeUtf8, + (.), + (<$>), + (<*>), + ) + +import Data.Generics (Data) +import Data.Text as T (dropEnd) +import Data.Yaml as Yaml (ToJSON, encode) +import Database.SQLite.Simple (FromRow, ToRow, field, fromRow, toRow) +import Database.SQLite.Simple.ToField (toField) +import Prettyprinter (Pretty (pretty)) + + +-- | Record for storing entries of the `task_to_tag` table +data TaskToTag = TaskToTag + { ulid :: Text -- Ulid + , task_ulid :: Text + , tag :: Text + } + deriving (Show, Eq, Generic, Data) + + +instance FromRow TaskToTag where + fromRow = + TaskToTag + <$> field + <*> field + <*> field + + +instance ToRow TaskToTag where + toRow TaskToTag{..} = + [ toField ulid + , toField task_ulid + , toField tag + ] + + +instance ToJSON TaskToTag + + +instance Pretty TaskToTag where + pretty = + pretty + . T.dropEnd 1 -- Drop trailing newline to maybe add it later + . decodeUtf8 + . Yaml.encode diff --git a/source/Utils.hs b/source/Utils.hs new file mode 100644 --- /dev/null +++ b/source/Utils.hs @@ -0,0 +1,356 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use maybe" #-} + +{-| +Several utility functions (e.g for parsing & serializing UTC stamps) +-} +module Utils where + +import Protolude ( + Alternative ((<|>)), + Applicative (pure), + Char, + Double, + Eq, + Fractional (fromRational, (/)), + Functor (fmap), + IO, + Int, + Integer, + Integral (div, mod), + Maybe (..), + Monoid (mempty), + Num ((*), (+)), + Ord ((<), (>)), + Rational, + Real (toRational), + RealFrac (properFraction, truncate), + Semigroup ((<>)), + Show, + Word16, + flip, + forM, + fromIntegral, + fromMaybe, + fst, + otherwise, + readMaybe, + realToFrac, + show, + stderr, + ($), + (&), + (.), + (<&>), + ) +import Protolude qualified as P + +import Control.Monad.Catch (catchAll) +import Data.Colour.RGBSpace (RGB (..)) +import Data.Hourglass ( + DateTime, + Elapsed (Elapsed), + ElapsedP (..), + ISO8601_DateAndTime (ISO8601_DateAndTime), + NanoSeconds (NanoSeconds), + Seconds (Seconds), + Time (timeFromElapsedP), + TimeFormat (toFormat), + TimeFormatString, + Timeable (timeGetElapsedP), + timeGetDateTimeOfDay, + timeParse, + timePrint, + ) +import Data.Text as T ( + Text, + chunksOf, + drop, + intercalate, + pack, + take, + toLower, + unlines, + unpack, + ) +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.Render.Terminal ( + AnsiStyle, + Color (Black), + 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) + + +type IdText = Text +type TagText = Text + + +data Filter a = NoFilter | Only a + deriving (Eq, Ord, Show) + + +data ListModifiedFlag = AllItems | ModifiedItemsOnly + deriving (Eq, Show) + + +-- | Combine documents with 2 newlines +(<++>) :: Doc ann -> Doc ann -> Doc ann +x <++> y = + x <> softline <> softline <> y + + +-- | Combine documents with 2 newlines if both documents are non-empty +(<$$>) :: Doc ann -> Doc ann -> Doc ann +Empty <$$> y = y +x <$$> Empty = x +x <$$> y = x <++> y + + +infixr 6 <$$> + + +vsepCollapse :: [Doc ann] -> Doc ann +vsepCollapse = P.foldr (<$$>) Empty + + +zeroTime :: DateTime +zeroTime = timeFromElapsedP 0 + + +emptyUlid :: ULID +emptyUlid = + ULID + { timeStamp = mkULIDTimeStamp 0 + , random = mkULIDRandom (mkStdGen 0) & P.fst + } + + +utcFormatReadable :: TimeFormatString +utcFormatReadable = + toFormat ("YYYY-MM-DD H:MI:S" :: [Char]) + + +parseUtcNum :: Int -> Maybe DateTime +parseUtcNum number = + parseUtc (show number) + + +parseUtc :: Text -> Maybe DateTime +parseUtc utcText = + let + utcString = unpack $ T.toLower utcText + + -- TODO: Remove after https://github.com/vincenthz/hs-hourglass/issues/50 + addSpaceAfter10 = T.intercalate " " . T.chunksOf 10 + addSpaceAfter13 = T.intercalate " " . T.chunksOf 13 + unixMicro = "EPOCH ms us" :: [Char] + unixMilli = "EPOCH ms" :: [Char] + + tParse :: [Char] -> Maybe DateTime + tParse formatString = + timeParse (toFormat formatString) utcString + in + -- From long (specific) to short (unspecific) + timeParse ISO8601_DateAndTime utcString + -- <|> tParse "YYYY-MM-DDtH:MI:S.ns" + <|> tParse "YYYY-MM-DDtH:MI:S.msusns" + <|> tParse "YYYY-MM-DDtH:MI:S.msus" + <|> tParse "YYYY-MM-DDtH:MI:S.ms" + <|> tParse "YYYY-MM-DDtH:MI:S" + <|> tParse "YYYY-MM-DDtH:MI" + <|> tParse "YYYYMMDDtHMIS" + <|> tParse "YYYY-MM-DD H:MI:S" + <|> tParse "YYYY-MM-DD H:MI" + <|> tParse "YYYY-MM-DD" + <|> timeParse + (toFormat unixMicro) + (unpack $ (addSpaceAfter10 . addSpaceAfter13) utcText) + <|> timeParse (toFormat unixMilli) (unpack $ addSpaceAfter10 utcText) + <|> tParse "EPOCH" + + +parseUlidUtcSection :: Text -> Maybe DateTime +parseUlidUtcSection encodedUtc = do + let + decodedUtcMaybe = Base32.decode encodedUtc + getElapsed val = Elapsed $ Seconds $ val `div` 1000 + + elapsed <- fmap getElapsed decodedUtcMaybe + milliSecPart <- fmap (`mod` 1000) decodedUtcMaybe + + let nanoSeconds = NanoSeconds $ milliSecPart * 1000000 + + pure $ timeGetDateTimeOfDay $ ElapsedP elapsed nanoSeconds + + +ulidTextToDateTime :: Text -> Maybe DateTime +ulidTextToDateTime = + T.take 10 >>> parseUlidUtcSection + + +{-| `ulid2utc` converts a ULID to a UTC timestamp + +>>> ulid2utc "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) + + +parseUlidText :: Text -> Maybe ULID +parseUlidText ulidText = do + let + mkUlidTimeMaybe text = fmap toUlidTime (ulidTextToDateTime text) + + mkUlidRandomMaybe :: Text -> Maybe ULIDRandom + mkUlidRandomMaybe = readMaybe . T.unpack . T.drop 10 + + ulidTime <- mkUlidTimeMaybe ulidText + ulidRandom <- mkUlidRandomMaybe ulidText + pure $ ULID ulidTime ulidRandom + + +-- TODO: Remove after https://github.com/vincenthz/hs-hourglass/issues/52 +rationalToElapsedP :: Rational -> ElapsedP +rationalToElapsedP secondsFrac = + let (sec, nanoSec) = properFraction secondsFrac + in ElapsedP (Elapsed (Seconds sec)) (NanoSeconds $ truncate $ nanoSec * 1e9) + + +-- TODO: Remove after https://github.com/vincenthz/hs-hourglass/issues/45 +elapsedPToRational :: ElapsedP -> Rational +elapsedPToRational (ElapsedP (Elapsed (Seconds s)) (NanoSeconds ns)) = + ((1e9 * fromIntegral s) + fromIntegral ns) / 1e9 + + +toUlidTime :: DateTime -> ULIDTimeStamp +toUlidTime = + mkULIDTimeStamp . realToFrac . elapsedPToRational . timeGetElapsedP + + +setDateTime :: ULID -> DateTime -> ULID +setDateTime ulid dateTime = + ULID + (toUlidTime dateTime) + (random ulid) + + +{-| Currently not needed + addStartUtc :: DateTime -> Iso8601.Interval -> Iso8601.Interval + addStartUtc utc interval = case interval of + Iso8601.Interval (Iso8601.JustDuration duration) -> + Iso8601.Interval (Iso8601.StartDuration (dateTimeToUtcTime utc) duration) + _ -> interval +-} +zonedTimeToDateTime :: ZonedTime -> DateTime +zonedTimeToDateTime zTime = + zTime + & zonedTimeToUTC + & utcTimeToPOSIXSeconds + & toRational + & rationalToElapsedP + & timeFromElapsedP + + +utcTimeToDateTime :: UTCTime -> DateTime +utcTimeToDateTime utcTime = + utcTime + & utcTimeToPOSIXSeconds + & toRational + & rationalToElapsedP + & timeFromElapsedP + + +dateTimeToUtcTime :: DateTime -> UTCTime +dateTimeToUtcTime dateTime = + dateTime + & timeGetElapsedP + & elapsedPToRational + & fromRational + & flip addUTCTime (posixSecondsToUTCTime 0) + + +-- From https://mail.haskell.org/pipermail/haskell-cafe/2009-August/065854.html +numDigits :: Integer -> Integer -> Integer +numDigits base num = + let + ilog b n + | n < b = (0, n) + | otherwise = + let (e, r) = ilog (b * b) n + in if r < b then (2 * e, r) else (2 * e + 1, r `div` b) + in + 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 + + pure $ + cmdOutput + <&> T.pack + & T.unlines + & pretty + + +applyColorMode :: Config -> IO Config +applyColorMode conf = do + layerColorBgMb <- + catchAll + (hGetLayerColor stderr Background) + (\_ -> pure Nothing) + + let + calcLuminance :: RGB Word16 -> Double + calcLuminance (RGB{..}) = + ( 0.3 * fromIntegral channelRed + + 0.6 * fromIntegral channelGreen + + 0.1 * fromIntegral channelBlue + ) + / 65536 + + isLightMode = + layerColorBgMb + <&> calcLuminance + & fromMaybe 0 -- Default to dark mode + & (> 0.5) + + pure $ + if isLightMode + then conf{bodyStyle = colorDull Black} + else conf diff --git a/tasklite-core.cabal b/tasklite-core.cabal new file mode 100644 --- /dev/null +++ b/tasklite-core.cabal @@ -0,0 +1,176 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: tasklite-core +version: 0.3.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, + while still providing a powerful interface for managing tasks. + It's heavily inspired by Taskwarrior and stems from my personal frustration + with some of its design decisions. + Check out https://tasklite.org/differences_taskwarrior + for a full comparison. +category: CLI, Task, Todo +homepage: https://github.com/ad-si/TaskLite#readme +bug-reports: https://github.com/ad-si/TaskLite/issues +author: Adrian Sieber +maintainer: mail@adriansieber.com +copyright: Adrian Sieber +license: AGPL-3.0-or-later +build-type: Simple +extra-source-files: + README.md +data-files: + example-config.yaml + +source-repository head + type: git + location: https://github.com/ad-si/TaskLite + +library + exposed-modules: + Base32 + Cli + Config + FullTask + ImportExport + Lib + Migrations + Note + Server + SqlUtils + Task + TaskToNote + TaskToTag + Utils + other-modules: + Paths_tasklite_core + autogen-modules: + Paths_tasklite_core + hs-source-dirs: + source + default-extensions: + DeriveAnyClass + LambdaCase + MultiWayIf + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + RecordWildCards + TypeFamilies + UndecidableInstances + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-orphans -Wredundant-constraints -Wunused-packages + build-depends: + QuickCheck ==2.14.* + , aeson >=2.2.1 && <2.3 + , airgql >=0.7.1.2 && <0.8 + , ansi-terminal >=0.11 && <1.1 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , cassava >=0.5.2 && <0.6 + , colour ==2.3.* + , directory ==1.3.* + , editor-open >=0.4 && <0.7 + , exceptions ==0.10.* + , file-embed >=0.0.14 && <0.1 + , filepath >=1.4 && <1.6 + , fuzzily ==0.2.* + , generic-random >=1.3 && <1.6 + , githash >=0.1.6 && <0.2 + , hourglass >=0.2.10 && <0.3 + , hsemail >=2.0 && <2.3 + , iso8601-duration >=0.1.1 && <0.2 + , optparse-applicative >=0.16 && <0.19 + , parsec ==3.1.* + , portable-lines ==0.1.* + , prettyprinter >=1.6 && <1.8 + , prettyprinter-ansi-terminal ==1.1.* + , process ==1.6.* + , protolude ==0.3.* + , quickcheck-instances >=0.3.28 && <0.4 + , random ==1.2.* + , servant >=0.18 && <0.21 + , servant-blaze >=0.7 && <0.10 + , servant-multipart >=0.11 && <0.13 + , servant-server >=0.18 && <0.21 + , simple-sql-parser >=0.6 && <0.8 + , sqlite-simple ==0.4.* + , syb ==0.7.* + , text >=1.2 && <2.2 + , time >=1.11 && <1.15 + , ulid ==0.3.* + , unix ==2.8.* + , vector >=0.12 && <0.14 + , wai ==3.2.* + , wai-app-static ==3.1.* + , wai-cors ==0.2.* + , wai-extra ==3.1.* + , warp >=3.3 && <3.5 + , yaml ==0.11.* + default-language: GHC2021 + +test-suite tasklite-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + LibSpec + TestUtils + TypesSpec + Paths_tasklite_core + autogen-modules: + Paths_tasklite_core + hs-source-dirs: + test + default-extensions: + DeriveAnyClass + LambdaCase + MultiWayIf + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + RecordWildCards + TypeFamilies + UndecidableInstances + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-orphans -Wredundant-constraints -Wunused-packages + build-depends: + aeson + , base >=4.18 && <5 + , hourglass + , hspec + , neat-interpolation + , protolude >=0.3 + , sqlite-simple + , tasklite-core + , text + , yaml + default-language: GHC2021 + +benchmark tasklite-bench + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_tasklite_core + autogen-modules: + Paths_tasklite_core + hs-source-dirs: + benchmarks + default-extensions: + DeriveAnyClass + LambdaCase + MultiWayIf + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + RecordWildCards + TypeFamilies + UndecidableInstances + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-orphans -Wredundant-constraints -Wunused-packages + build-depends: + base >=4.18 && <5 + , criterion + , protolude >=0.3 + default-language: GHC2021 diff --git a/test/LibSpec.hs b/test/LibSpec.hs new file mode 100644 --- /dev/null +++ b/test/LibSpec.hs @@ -0,0 +1,132 @@ +module LibSpec where + +import Protolude ( + Maybe (..), + Text, + pure, + show, + ($), + (<>), + ) +import Protolude qualified as P + +import Config (defaultConfig) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + shouldContain, + shouldEndWith, + shouldNotContain, + ) + +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 TaskToNote qualified +import TestUtils (withMemoryDb) + + +task1 :: Task +task1 = + zeroTask + { ulid = "01hs68z7mdg4ktpxbv0yfafznq" + , body = "New task 1" + } + + +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" + } + + 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 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 = + zeroTask + { ulid = "01hs6zsf3c0vqx6egfnmbqtmvy" + , body = "New task 2" + , closed_utc = Just "2024-04-10T18:54:10Z" + , state = Just Done + } + + insertRecord "tasks" memConn task1 + insertRecord "tasks" memConn task2 + + cliOutput <- newTasks defaultConfig now memConn (Just ["state:done"]) + 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 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 "lets you edit a task and 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] + P.show warnings `shouldBe` T.empty + + cliOutput <- + editTaskByTask + (ApplyPreEdit (<> ("\ntags: " <> P.show [existTag, "new-tag"]))) + memConn + task1 + let errMsg = "Tag \"" <> T.unpack existTag <> "\" is already assigned" + show cliOutput `shouldContain` errMsg + + 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\"" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,445 @@ +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 + + +main :: IO () +main = do + nowElapsed <- timeCurrentP + let now = timeFromElapsedP nowElapsed :: DateTime + hspec $ testSuite defaultConfig now diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils.hs @@ -0,0 +1,18 @@ +module TestUtils where + +import Protolude ( + IO, + ($), + ) + +import Database.SQLite.Simple qualified as Sql + +import Config (Config (..)) +import Migrations (runMigrations) + + +withMemoryDb :: Config -> (Sql.Connection -> IO a) -> IO a +withMemoryDb conf action = + Sql.withConnection ":memory:" $ \memConn -> do + _ <- runMigrations conf memConn + action memConn diff --git a/test/TypesSpec.hs b/test/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/TypesSpec.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE QuasiQuotes #-} + +module TypesSpec where + +import Protolude (Maybe (..), Text, ($), (&), (<&>), (<>)) +import Protolude qualified as P + +import Test.Hspec (Spec, describe, it, shouldBe) + +import Config (defaultConfig) +import Data.Text qualified as T +import Data.Yaml qualified +import FullTask (FullTask (body, notes, tags, ulid), emptyFullTask) +import Lib (insertNotes, insertRecord, insertTags) +import NeatInterpolation (trimming) +import Note (Note (Note, body, ulid)) +import Task (Task (body, ulid), taskToEditableYaml, zeroTask) +import TestUtils (withMemoryDb) + + +sampleNotes :: [Note] +sampleNotes = + [ Note + { Note.ulid = "01hw5n9m99papg470w8j9k9vd3" + , Note.body = + "Sample note 1 is quite long \ + \so we can observer how automatic wrapping \ + \can produce unexpected results." + } + , Note + { Note.ulid = "01hw5n9y3q27zys83b139s7e2r" + , Note.body = + "\nSample note 2 is short\n\ + \but has \nsurprising \nline breaks." + } + ] + + +spec :: Spec +spec = do + describe "Types" $ do + describe "Task" $ do + let + sampleTask = + zeroTask + { Task.ulid = "01hs68z7mdg4ktpxbv0yfafznq" + , Task.body = "Sample task" + } + + it "can be converted to YAML" $ do + let + taskYaml = sampleTask & Data.Yaml.encode & P.decodeUtf8 + + expected :: Text + expected = + [trimming| + awake_utc: null + body: Sample task + closed_utc: null + due_utc: null + group_ulid: null + metadata: null + modified_utc: '' + priority_adjustment: null + ready_utc: null + recurrence_duration: null + repetition_duration: null + review_utc: null + state: null + ulid: 01hs68z7mdg4ktpxbv0yfafznq + user: '' + waiting_utc: null + |] + <> "\n" + + 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 + + taskYaml <- taskToEditableYaml memConn sampleTask + let + expected :: P.ByteString + expected = + [trimming| + awake_utc: null + body: Sample task + closed_utc: null + due_utc: null + group_ulid: null + metadata: null + modified_utc: '' + priority_adjustment: null + ready_utc: null + recurrence_duration: null + repetition_duration: null + review_utc: null + state: null + ulid: 01hs68z7mdg4ktpxbv0yfafznq + user: '' + waiting_utc: null + + # | Existing tags and notes can't be edited here, but new ones can be added + + # tags: ["tag-0","tag-1","tag-2","tag-3","tag-4","tag-5","tag-6","tag-7","tag-8","tag-9"] + tags: [] + + # notes: + # - Sample note 1 is quite long so we can observer how automatic wrapping can produce unexpected results. + # - Sample note 2 is short + # but has + # surprising + # line breaks. + notes: [] + |] + <> "\n" + & P.encodeUtf8 + + 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 + } + + it "can be converted to YAML" $ do + let + taskYaml = sampleFullTask & Data.Yaml.encode & P.decodeUtf8 + + expected :: Text + expected = + [trimming| + awake_utc: null + body: Sample task + closed_utc: null + due_utc: null + group_ulid: null + metadata: null + modified_utc: '' + notes: + - body: Sample note 1 is quite long so we can observer how automatic wrapping can + produce unexpected results. + ulid: 01hw5n9m99papg470w8j9k9vd3 + - body: "\nSample note 2 is short\nbut has \nsurprising \nline breaks." + ulid: 01hw5n9y3q27zys83b139s7e2r + priority: null + ready_utc: null + recurrence_duration: null + repetition_duration: null + review_utc: null + state: null + tags: + - tag1 + - tag2 + ulid: 01hs68z7mdg4ktpxbv0yfafznq + user: '' + waiting_utc: null + |] + <> "\n" + + taskYaml `shouldBe` expected