tasklite-core (empty) → 0.3.0.0
raw patch · 23 files changed
+8991/−0 lines, 23 filesdep +QuickCheckdep +aesondep +airgqlsetup-changed
Dependencies added: QuickCheck, aeson, airgql, ansi-terminal, base, bytestring, cassava, colour, criterion, directory, editor-open, exceptions, file-embed, filepath, fuzzily, generic-random, githash, hourglass, hsemail, hspec, iso8601-duration, neat-interpolation, optparse-applicative, parsec, portable-lines, prettyprinter, prettyprinter-ansi-terminal, process, protolude, quickcheck-instances, random, servant, servant-blaze, servant-multipart, servant-server, simple-sql-parser, sqlite-simple, syb, tasklite-core, text, time, ulid, unix, vector, wai, wai-app-static, wai-cors, wai-extra, warp, yaml
Files
- README.md +4/−0
- Setup.hs +4/−0
- benchmarks/Main.hs +35/−0
- example-config.yaml +35/−0
- source/Base32.hs +64/−0
- source/Cli.hs +1358/−0
- source/Config.hs +358/−0
- source/FullTask.hs +248/−0
- source/ImportExport.hs +792/−0
- source/Lib.hs +2966/−0
- source/Migrations.hs +593/−0
- source/Note.hs +82/−0
- source/Server.hs +257/−0
- source/SqlUtils.hs +335/−0
- source/Task.hs +451/−0
- source/TaskToNote.hs +56/−0
- source/TaskToTag.hs +55/−0
- source/Utils.hs +356/−0
- tasklite-core.cabal +176/−0
- test/LibSpec.hs +132/−0
- test/Spec.hs +445/−0
- test/TestUtils.hs +18/−0
- test/TypesSpec.hs +171/−0
+ README.md view
@@ -0,0 +1,4 @@+# TaskLite Core++This Haskell package provides the core functionality for TaskLite.+Use it to interact with a TaskLite database programmatically.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ benchmarks/Main.hs view
@@ -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+ ]+ ]
+ example-config.yaml view
@@ -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')
+ source/Base32.hs view
@@ -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
+ source/Cli.hs view
@@ -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 <adriansieber.com>"+ <> "\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 <id>")+ )+ 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+ )
+ source/Config.hs view
@@ -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+ }+ }
+ source/FullTask.hs view
@@ -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+ }
+ source/ImportExport.hs view
@@ -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 "<stdin>" content of+ Left error -> die $ show error+ Right email -> insertImportTask connection $ emailToImportTask email+++emailToImportTask :: GenericMessage BSL.ByteString -> ImportTask+emailToImportTask email@(Message headerFields msgBody) =+ let+ addBody (ImportTask task notes tags) =+ ImportTask+ task+ { Task.body =+ Task.body task+ <> ( msgBody+ & lines8+ <&> (TL.decodeUtf8 >>> toStrict)+ & T.unlines+ & T.dropEnd 1+ )+ }+ notes+ tags++ namesToJson names =+ Array $+ V.fromList $+ names+ <&> ( \(Email.NameAddr name emailAddress) ->+ Object $+ KeyMap.fromList $+ [ ("name", Aeson.String $ T.pack $ fromMaybe "" name)+ , ("email", Aeson.String $ T.pack emailAddress)+ ]+ )++ addHeaderToTask :: ImportTask -> Email.Field -> ImportTask+ addHeaderToTask impTask@(ImportTask task notes tags) headerValue =+ case headerValue of+ Email.Date emailDate ->+ let+ utc = zonedTimeToDateTime emailDate+ ulidGeneratedRes = (email & show :: Text) & (hash >>> toInteger >>> abs >>> ulidFromInteger)+ ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` utc+ in+ ImportTask+ task+ { Task.ulid = T.toLower $ show ulidCombined+ , Task.modified_utc =+ T.pack $ timePrint (toFormat importUtcFormat) utc+ }+ notes+ tags+ Email.From names ->+ ImportTask+ (setMetadataField "from" (namesToJson names) task)+ notes+ tags+ Email.To names ->+ ImportTask+ (setMetadataField "to" (namesToJson names) task)+ notes+ tags+ Email.MessageID msgId ->+ ImportTask+ (setMetadataField "messageId" (Aeson.String $ T.pack msgId) task)+ notes+ tags+ Email.Subject subj ->+ ImportTask+ task{Task.body = Task.body task <> T.pack subj}+ notes+ tags+ Email.Keywords kwords ->+ ImportTask+ task+ notes+ (tags <> fmap (T.unwords . fmap T.pack) kwords)+ Email.Comments cmnts ->+ ImportTask+ (setMetadataField "comments" (Aeson.String $ T.pack cmnts) task)+ notes+ tags+ _ -> impTask+ in+ foldl addHeaderToTask (addBody emptyImportTask) headerFields+++importFile :: Config -> Connection -> FilePath -> IO (Doc AnsiStyle)+importFile _ connection filePath = do+ content <- BSL.readFile filePath++ let+ fileExt = takeExtension filePath++ case fileExt of+ ".json" ->+ let decodeResult = Aeson.eitherDecode content :: Either [Char] ImportTask+ in case decodeResult of+ Left error ->+ die $ T.pack error <> " in task \n" <> show content+ Right importTaskRecord ->+ insertImportTask connection importTaskRecord+ ".eml" ->+ case Parsec.parse message filePath content of+ Left error -> die $ show error+ Right email -> insertImportTask connection $ emailToImportTask email+ _ -> die $ T.pack $ "File type " <> fileExt <> " is not supported"+++ingestFile :: Config -> Connection -> FilePath -> IO (Doc AnsiStyle)+ingestFile _config connection filePath = do+ content <- BSL.readFile filePath++ let+ fileExt = takeExtension filePath++ resultDocs <- case fileExt of+ ".json" ->+ let decodeResult = Aeson.eitherDecode content :: Either [Char] ImportTask+ in case decodeResult of+ Left error ->+ die $ T.pack error <> " in task \n" <> show content+ Right importTaskRecord@ImportTask{task} ->+ sequence+ [ insertImportTask connection importTaskRecord+ , editTaskByTask NoPreEdit connection task+ ]+ ".eml" ->+ case Parsec.parse message filePath content of+ Left error -> die $ show error+ Right email ->+ let taskRecord@ImportTask{task} =+ emailToImportTask email+ in sequence+ [ insertImportTask connection taskRecord+ , editTaskByTask NoPreEdit connection task+ ]+ _ -> die $ T.pack $ "File type " <> fileExt <> " is not supported"++ removeFile filePath++ pure $+ P.fold resultDocs+ <+> "❌ Deleted file \""+ <> pretty filePath+ <> "\""+++-- TODO: Use Task instead of FullTask to fix broken notes export+dumpCsv :: Config -> IO (Doc AnsiStyle)+dumpCsv conf = do+ execWithConn conf $ \connection -> do+ rows :: [FullTask] <- query_ connection "SELECT * FROM tasks_view"+ pure $ pretty $ TL.decodeUtf8 $ Csv.encodeDefaultOrderedByName rows+++dumpNdjson :: Config -> IO (Doc AnsiStyle)+dumpNdjson conf = do+ -- TODO: Use Task instead of FullTask to fix broken notes export+ execWithConn conf $ \connection -> do+ tasks :: [FullTask] <- query_ connection "SELECT * FROM tasks_view"+ pure $+ vsep $+ fmap (pretty . TL.decodeUtf8 . Aeson.encode) tasks+++dumpJson :: Config -> IO (Doc AnsiStyle)+dumpJson conf = do+ -- TODO: Use Task instead of FullTask to fix broken notes export+ execWithConn conf $ \connection -> do+ tasks :: [FullTask] <- query_ connection "SELECT * FROM tasks_view"+ pure $ pretty $ fmap (TL.decodeUtf8 . Aeson.encode) tasks+++dumpSql :: Config -> IO (Doc AnsiStyle)+dumpSql conf = do+ result <-+ readProcess+ "sqlite3"+ [ dataDir conf </> dbName conf+ , ".dump"+ ]+ []+ pure $ pretty result+++backupDatabase :: Config -> IO (Doc AnsiStyle)+backupDatabase conf = do+ now <- timeCurrent++ let+ fileUtcFormat = toFormat ("YYYY-MM-DDtHMI" :: [Char])+ backupDirName = "backups"+ backupDirPath = dataDir conf </> backupDirName+ backupFilePath = backupDirPath </> timePrint fileUtcFormat now <> ".db"++ -- Create directory (and parents because of True)+ createDirectoryIfMissing True backupDirPath++ result <-+ pretty+ <$> readProcess+ "sqlite3"+ [ dataDir conf </> dbName conf+ , ".backup '" <> backupFilePath <> "'"+ ]+ []++ pure $+ result+ <> hardline+ <> pretty+ ( "✅ Backed up database \""+ <> dbName conf+ <> "\" to \""+ <> backupFilePath+ <> "\""+ )+++data PreEdit+ = ApplyPreEdit (P.ByteString -> P.ByteString)+ | NoPreEdit+++editTaskByTask :: PreEdit -> Connection -> Task -> IO (Doc AnsiStyle)+editTaskByTask preEdit conn taskToEdit = do+ taskYaml <- taskToEditableYaml conn taskToEdit+ newContent <- case preEdit of+ ApplyPreEdit editFunc -> pure $ editFunc taskYaml+ NoPreEdit -> runUserEditorDWIM yamlTemplate taskYaml++ if newContent == taskYaml+ then+ pure $+ "⚠️ Nothing changed" <+> hardline+ else do+ let+ parseMetadata :: Value -> Parser Bool+ parseMetadata val = case val of+ Object obj -> do+ let mdataMaybe = KeyMap.lookup "metadata" obj+ pure $ case mdataMaybe of+ Just (Object _) -> True+ _ -> False+ _ -> pure False++ hasMetadata =+ parseMaybe parseMetadata+ =<< (rightToMaybe $ Yaml.decodeEither' newContent :: Maybe Value)++ decodeResult :: Either ParseException ImportTask+ decodeResult = Yaml.decodeEither' newContent++ case decodeResult of+ Left error -> die $ show error <> " in task \n" <> show newContent+ Right importTaskRecord -> do+ effectiveUserName <- getEffectiveUserName+ let+ taskParsed = task importTaskRecord+ taskFixed =+ taskParsed+ { Task.user =+ if Task.user taskParsed == ""+ then T.pack effectiveUserName+ else Task.user taskParsed+ , Task.metadata =+ if hasMetadata == Just True+ then Task.metadata taskParsed+ else Nothing+ }++ updateTask conn taskFixed+ warnings <-+ insertTags+ conn+ Nothing+ taskFixed+ (tags importTaskRecord)+ insertNotes+ conn+ Nothing+ taskFixed+ (notes importTaskRecord)+ pure $+ warnings+ <$$> "✏️ Edited task"+ <+> dquotes (pretty $ Task.body taskFixed)+ <+> "with ulid"+ <+> dquotes (pretty $ Task.ulid taskFixed)+ <+> hardline+++editTask :: Config -> Connection -> IdText -> IO (Doc AnsiStyle)+editTask conf conn idSubstr = do+ execWithTask conf conn idSubstr $ \taskToEdit -> do+ editTaskByTask NoPreEdit conn taskToEdit
+ source/Lib.hs view
@@ -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+ ]
+ source/Migrations.hs view
@@ -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
+ source/Note.hs view
@@ -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)
+ source/Server.hs view
@@ -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
+ source/SqlUtils.hs view
@@ -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"
+ source/Task.hs view
@@ -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
+ source/TaskToNote.hs view
@@ -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
+ source/TaskToTag.hs view
@@ -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
+ source/Utils.hs view
@@ -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
+ tasklite-core.cabal view
@@ -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
+ test/LibSpec.hs view
@@ -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\""
+ test/Spec.hs view
@@ -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
+ test/TestUtils.hs view
@@ -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
+ test/TypesSpec.hs view
@@ -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