diff --git a/docs-source/cli/hooks.md b/docs-source/cli/hooks.md index d361985..8dec3c7 100644 --- a/docs-source/cli/hooks.md +++ b/docs-source/cli/hooks.md @@ -59,7 +59,7 @@ Included fields are: } ``` -After execution, a called hook can print a JSON object to stdout. +During execution, a called hook should print a result JSON object to stdout. All fields of the JSON are optional. Possible values: @@ -69,14 +69,14 @@ Possible values: message: "…", // A message to display on stdout warning: "…", // A warning to display on stderr error: "…", // An error to display on stderr - … // Any other fields you want to include + … // Other fields depending on hook type (check out table below) } ``` -Hooks can write to stdout at any time, but it's not recommended. -Rather write a `{ message: "…" }` object to stdout and -let TaskLite print the message with improved formatting and coloring. -Same goes for stderr. +Hooks can write to stderr at any time, but it's not recommended. +Rather write a JSON object to stdout and +let TaskLite print the message / warning / error +with improved formatting and coloring. @@ -135,7 +135,13 @@ Same goes for stderr. taskAdded: {} } - + - - - - - - 
{ message: "…", … }
+{
+  taskAdded: {},
+  message: "…",
+  …
+}
+      
{ message: "…", … }
Processing terminates @@ -151,7 +157,7 @@ Same goes for stderr. 
 {
-  taskModified: {},
+  taskToModify: {},
   message: "…",
   …
 }
@@ -191,15 +197,6 @@ Same goes for stderr.
         Processing terminates
post‑exit
❌
{ message: "…", … }
 - 
{ message: "…", … }
- Processing terminates -
diff --git a/tasklite-core/source/Cli.hs b/tasklite-core/source/Cli.hs index 720dae5..f48d1f3 100644 --- a/tasklite-core/source/Cli.hs +++ b/tasklite-core/source/Cli.hs @@ -140,6 +140,7 @@ import Config ( HooksConfig (..), addHookFilesToConfig, ) +import Hooks (HookResult (message), executeHooks) import ImportExport ( backupDatabase, dumpCsv, @@ -225,9 +226,9 @@ import Utils ( IdText, ListModifiedFlag (AllItems, ModifiedItemsOnly), TagText, - executeHooks, parseUtc, ulidText2utc, + (<$$>), ) @@ -1341,8 +1342,13 @@ printOutput appName argsMb config = do let configNorm = addHookFilesToConfig configNormHookDir hookFilesPermContent - preLaunchResult <- executeHooks "" configNorm.hooks.launch.pre - putDoc preLaunchResult + preLaunchResults <- executeHooks "" configNorm.hooks.launch.pre + let preLaunchHookMsg = + preLaunchResults + <&> \case + Left error -> pretty error + Right hookResult -> pretty hookResult.message + & P.fold connection <- setupConnection configNorm @@ -1359,7 +1365,7 @@ printOutput appName argsMb config = do args <- case argsMb of Just args -> pure args Nothing -> getArgs - postLaunchResult <- + postLaunchResults <- executeHooks ( TL.toStrict $ TL.decodeUtf8 $ @@ -1367,7 +1373,13 @@ printOutput appName argsMb config = do object ["arguments" .= args] ) configNorm.hooks.launch.post - putDoc postLaunchResult + + let postLaunchHookMsg = + postLaunchResults + <&> \case + Left error -> pretty error + Right hookResult -> pretty hookResult.message + & P.fold doc <- executeCLiCommand configNorm now connection progName args @@ -1375,7 +1387,11 @@ printOutput appName argsMb config = do SQLite.close connection -- TODO: Remove color when piping into other command - putDoc $ migrationsStatus <> doc <> hardline + putDoc $ + preLaunchHookMsg + <$$> migrationsStatus + <> doc + <$$> postLaunchHookMsg exampleConfig :: Text diff --git a/tasklite-core/source/Hooks.hs b/tasklite-core/source/Hooks.hs new file mode 100644 index 0000000..8933ea1 --- /dev/null +++ b/tasklite-core/source/Hooks.hs @@ -0,0 +1,174 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use maybe" #-} + +module Hooks where + +import Protolude ( + Applicative (pure), + IO, + Maybe (..), + Show, + otherwise, + ($), + (&), + (<&>), + ) +import Protolude qualified as P + +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Data.Text qualified as T +import System.Process (readProcess) + +import Config (Hook (body, filePath, interpreter)) +import Control.Arrow ((>>>)) +import ImportTask (ImportTask) +import Options.Applicative.Arrows (left) +import System.FilePath (takeExtension) + + +data HookTiming = PreEvent | PostEvent + deriving (Show) + + +data HookType + = LaunchHook + | AddHook + | ModifyHook + | ExitHook + deriving (Show) + + +data HookEvent = HookEvent HookType HookTiming + deriving (Show) + + +data HookResult + = BasicHookResult + { message :: Maybe Text + , warning :: Maybe Text + , error :: Maybe Text + } + | PreAddHookResult + { taskToAdd :: Maybe ImportTask + , message :: Maybe Text + , warning :: Maybe Text + , error :: Maybe Text + } + | PostAddHookResult + { taskAdded :: ImportTask + , message :: Maybe Text + , warning :: Maybe Text + , error :: Maybe Text + } + | PreModifyHookResult + { taskToModify :: ImportTask + , message :: Maybe Text + , warning :: Maybe Text + , error :: Maybe Text + } + | PostModifyHookResult + { taskModified :: ImportTask + , message :: Maybe Text + , warning :: Maybe Text + , error :: Maybe Text + } + deriving (Show, P.Generic) + + +instance Aeson.FromJSON HookResult where + parseJSON = Aeson.withObject "PreAddHookResult" $ \v -> do + message <- v Aeson..:? "message" + warning <- v Aeson..:? "warning" + error <- v Aeson..:? "error" + + taskToAddMb <- v Aeson..:? "taskToAdd" + taskAddedMb <- v Aeson..:? "taskAdded" + taskToModifyMb <- v Aeson..:? "taskToModify" + taskModifiedMb <- v Aeson..:? "taskModified" + + case (taskToAddMb, taskAddedMb, taskToModifyMb, taskModifiedMb) of + (Just taskToAdd, _, _, _) -> do + pure $ PreAddHookResult taskToAdd message warning error + (_, Just taskAdded, _, _) -> do + pure $ PostAddHookResult taskAdded message warning error + (_, _, Just taskToModify, _) -> do + pure $ PreModifyHookResult taskToModify message warning error + (_, _, _, Just taskModified) -> do + pure $ PostModifyHookResult taskModified message warning error + (_, _, _, _) -> do + pure $ BasicHookResult message warning error + + +data ExecMode = ExecFile | ExecStdin + + +type String = [P.Char] + + +executeHooks :: Text -> [Hook] -> IO [P.Either Text HookResult] +executeHooks stdinText hooks = do + let + stdinStr = T.unpack stdinText + + getInterpreter :: String -> (String, [String], ExecMode) + getInterpreter s = + if + | s `P.elem` ["javascript", "js", "node", "node.js"] -> + ("node", ["-e"], ExecStdin) + | s `P.elem` ["lua"] -> + ("lua", ["-e"], ExecStdin) + | s `P.elem` ["python", "python3", "py"] -> + ("python3", ["-c"], ExecStdin) + | s `P.elem` ["ruby", "rb"] -> + ("ruby", ["-e"], ExecStdin) + | s `P.elem` ["v", "vsh"] -> + -- `crun` keeps the binary after execution + ("v", ["-raw-vsh-tmp-prefix", "_v_executable_"], ExecFile) + | otherwise -> + ("", [""], ExecFile) + + hookToResult <- + P.sequence $ + hooks <&> \hook -> do + case hook.filePath of + Just fPath -> do + case fPath & takeExtension & P.drop 1 of + "" -> + -- Is excuted with shell + readProcess fPath [] stdinStr + ext -> do + let (interpreter, cliFlags, execMode) = getInterpreter ext + case execMode of + ExecStdin -> do + fileContent <- P.readFile fPath + readProcess + interpreter + (P.concat [cliFlags, [T.unpack fileContent]]) + stdinStr + ExecFile -> do + readProcess + interpreter + (P.concat [cliFlags, [fPath]]) + stdinStr + --- + Nothing -> do + let + (interpreter, cliFlags, _) = + getInterpreter (T.unpack hook.interpreter) + readProcess + interpreter + (P.concat [cliFlags, [T.unpack hook.body]]) + stdinStr + + let parsedHookResults :: [P.Either Text HookResult] = + hookToResult + & P.filter (T.pack >>> T.strip >>> T.null >>> P.not) + <&> ( ( \hookOutput -> do + Aeson.eitherDecodeStrictText (T.pack hookOutput) + ) + >>> left T.pack + ) + + pure parsedHookResults diff --git a/tasklite-core/source/ImportExport.hs b/tasklite-core/source/ImportExport.hs index f59deb3..914d6f7 100644 --- a/tasklite-core/source/ImportExport.hs +++ b/tasklite-core/source/ImportExport.hs @@ -4,7 +4,6 @@ Functions to import and export tasks module ImportExport where import Protolude ( - Alternative ((<|>)), Applicative (pure), Bool (..), Char, @@ -13,22 +12,17 @@ import Protolude ( 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, putErrLn, rightToMaybe, show, @@ -38,11 +32,9 @@ import Protolude ( (&), (+), (.), - (/=), (<$>), (<&>), (=<<), - (>>=), (||), ) import Protolude qualified as P @@ -52,37 +44,28 @@ import Control.Arrow ((>>>)) import Control.Monad.Catch (catchAll) import Data.Aeson (Value) 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 (ULID, ulidFromInteger) +import Data.ULID (ulidFromInteger) import Data.ULID.TimeStamp (getULIDTimeStamp) import Data.Vector qualified as V import Data.Yaml (ParseException (InvalidYaml), YamlException (YamlException, YamlParseException), YamlMark (YamlMark)) import Data.Yaml qualified as Yaml import Database.SQLite.Simple as Sql (Connection, query_) import FullTask (FullTask) +import ImportTask (ImportTask (..), emptyImportTask, importUtcFormat, setMissingFields) import Lib ( execWithConn, execWithTask, @@ -106,31 +89,7 @@ import System.Directory (createDirectoryIfMissing, listDirectory, removeFile) import System.FilePath (isExtensionOf, 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 - ), - emptyTask, - setMetadataField, - taskToEditableYaml, - textToTaskState, - ) +import Task (Task (body, closed_utc, metadata, modified_utc, ulid, user), setMetadataField, taskToEditableYaml) import Text.Editor (runUserEditorDWIM, yamlTemplate) import Text.Parsec.Rfc2822 (GenericMessage (..), message) import Text.Parsec.Rfc2822 qualified as Email @@ -140,402 +99,14 @@ import Time.System (dateCurrent, timeCurrent) import Utils ( IdText, emptyUlid, - parseUlidText, - parseUtc, - parseUtcNum, setDateTime, - toUlidTime, ulidTextToDateTime, - zeroTime, zeroUlidTxt, 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.ms" :: [Char]) - - -data ImportTask = ImportTask - { task :: Task - , notes :: [Note] - , tags :: [Text] - } - deriving (Show) - - -emptyImportTask :: ImportTask -emptyImportTask = - ImportTask - { task = emptyTask - , notes = [] - , tags = [] - } - - --- | Values a suffixed with a prime (') to avoid name collisions -instance FromJSON ImportTask where - parseJSON = withObject "task" $ \o -> do - utc <- o .:? "utc" - entry <- o .:? "entry" - creation <- o .:? "creation" - creation_utc <- o .:? "creation_utc" - creationUtc <- o .:? "creationUtc" - created <- o .:? "created" - created_at <- o .:? "created_at" - createdAt <- o .:? "createdAt" - created_utc <- o .:? "created_utc" - createdUtc_ <- o .:? "createdUtc" - - let - parsedCreatedUtc = - parseUtc - =<< ( utc - <|> entry - <|> creation - <|> creation_utc - <|> creationUtc - <|> created - <|> created_at - <|> createdAt - <|> created_utc - <|> createdUtc_ - ) - createdUtc = fromMaybe zeroTime parsedCreatedUtc - - o_title <- o .:? "title" - o_body <- o .:? "body" - description <- o .:? "description" - let body = fromMaybe "" (o_title <|> o_body <|> description) - - o_priority_adjustment <- o .:? "priority_adjustment" - urgency <- o .:? "urgency" - priority <- optional (o .: "priority") - let priority_adjustment = o_priority_adjustment <|> urgency <|> priority - - modified <- o .:? "modified" - modified_at <- o .:? "modified_at" - o_modified_utc <- o .:? "modified_utc" - modification_date <- o .:? "modification_date" - updated_at <- o .:? "updated_at" - let - -- TODO: Parse the fields first and then combine them with `<|>` - maybeModified = - modified - <|> modified_at - <|> o_modified_utc - <|> modification_date - <|> updated_at - modified_utc = - maybeModified - >>= parseUtc - & fromMaybe createdUtc - & timePrint importUtcFormat - & T.pack - - o_state <- o .:? "state" - status <- o .:? "status" - let - state = textToTaskState =<< (o_state <|> status) - implicitCloseUtcMaybe = - if isJust state - then - maybeModified - <|> Just (T.pack $ timePrint importUtcFormat createdUtc) - else Nothing - - o_tags <- o .:? "tags" - (o_labelsMb :: Maybe [Value]) <- o .:? "labels" - let labels = - o_labelsMb - <&> ( ( \o_labels -> - o_labels <&> \case - String txt -> Just txt - Object obj -> - P.flip parseMaybe obj (\o_ -> o_ .:? "name" .!= "") - _ -> Nothing - ) - >>> P.catMaybes - ) - - project <- o .:? "project" - let - projects = project <&> (: []) - tags = fromMaybe [] (o_tags <> labels <> projects) - - due <- o .:? "due" - o_due_utc <- o .:? "due_utc" - due_on <- o .:? "due_on" - let - maybeDue = due <|> o_due_utc <|> due_on - due_utc = - fmap - (T.pack . timePrint importUtcFormat) - (parseUtc =<< maybeDue) - - awake' <- o .:? "awake" - awake_at' <- o .:? "awake_at" - sleep' <- o .:? "sleep" - sleep_utc' <- o .:? "sleep_utc" - sleep_until' <- o .:? "sleep_until" - wait' <- o .:? "wait" - wait_until' <- o .:? "wait_until" - let - maybeAwake = - awake' - <|> awake_at' - <|> sleep' - <|> sleep_utc' - <|> sleep_until' - <|> wait' - <|> wait_until' - awake_utc = - fmap - (T.pack . timePrint importUtcFormat) - (parseUtc =<< maybeAwake) - - ready' <- o .:? "ready" - ready_since' <- o .:? "ready_since" - ready_utc' <- o .:? "ready_utc" - let - maybeReady = ready' <|> ready_since' <|> ready_utc' - ready_utc = - fmap - (T.pack . timePrint importUtcFormat) - (parseUtc =<< maybeReady) - - review' <- o .:? "review" - review_at' <- o .:? "review_at" - review_since' <- o .:? "review_since" - review_utc' <- o .:? "review_utc" - let - maybeReview = review' <|> review_at' <|> review_since' <|> review_utc' - review_utc = - fmap - (T.pack . timePrint importUtcFormat) - (parseUtc =<< maybeReview) - - waiting' <- o .:? "waiting" - waiting_since' <- o .:? "waiting_since" - waiting_utc' <- o .:? "waiting_utc" - let - maybewaiting = waiting' <|> waiting_since' <|> waiting_utc' - waiting_utc = - fmap - (T.pack . timePrint importUtcFormat) - (parseUtc =<< maybewaiting) - - closed <- o .:? "closed" - o_closed_utc <- o .:? "closed_utc" - closed_at <- o .:? "closed_at" - closed_on <- o .:? "closed_on" - end <- o .:? "end" - o_end_utc <- o .:? "end_utc" - end_on <- o .:? "end_on" - let - maybeClosed = - closed - <|> o_closed_utc - <|> closed_at - <|> closed_on - <|> end - <|> o_end_utc - <|> end_on - <|> implicitCloseUtcMaybe - closed_utc = - fmap - (T.pack . timePrint importUtcFormat) - (parseUtc =<< maybeClosed) - - group_ulid <- o .:? "group_ulid" - - let parseIsoDurationMb durTextMb = - hush $ - fmap (P.decodeUtf8 . Iso.formatDuration) $ - Iso.parseDuration $ - P.encodeUtf8 $ - fromMaybe "" durTextMb - - repetition_duration' <- o .:? "repetition_duration" - repeat_duration' <- o .:? "repeat_duration" - let - maybeRepetition = repetition_duration' <|> repeat_duration' - repetition_duration = parseIsoDurationMb maybeRepetition - - recurrence_duration' <- o .:? "recurrence_duration" - recur_duration' <- o .:? "recur_duration" - let - maybeRecurrence = recurrence_duration' <|> recur_duration' - recurrence_duration = parseIsoDurationMb maybeRecurrence - - o_notes <- - asum - [ o .:? "notes" :: Parser (Maybe [Note]) - , do - notesMb <- o .:? "notes" :: Parser (Maybe [Text]) - pure $ case notesMb of - Just textNotes -> Just $ textNotes <&> textToNote createdUtc - Nothing -> Just [] - ] - annotations <- o .:? "annotations" :: Parser (Maybe [Annotation]) - - let - notes = case (o_notes, annotations) of - (Nothing, Nothing) -> [] - (Nothing, Just values) -> values <&> annotationToNote - (Just theNotes, _) -> case parsedCreatedUtc of - Just crUtc -> - theNotes - <&> ( \theNote -> - theNote - { Note.ulid = - theNote.ulid - & parseUlidText - <&> P.flip setDateTime crUtc - <&> show @ULID - & fromMaybe theNote.ulid - & T.toLower - } - ) - Nothing -> theNotes - - (o_userMb :: Maybe Value) <- o .:? "user" - o_author <- o .:? "author" - let - o_userNormMb = - o_userMb >>= \case - String txt -> Just txt - Object obj -> - P.flip parseMaybe obj (\o_ -> o_ .:? "login" .!= "") - _ -> Nothing - userMaybe = o_userNormMb <|> o_author - user = fromMaybe "" userMaybe - - o_metadata <- o .:? "metadata" - let - -- Only delete fields with highest priority, - -- as they would definitely have been used if available - -- TODO: Check which fields were actually used and delete only them - -- (Crudly done for title and body) - metadata = - o_metadata - <|> ( ( o - & ( case (o_title, o_body) of - (Nothing, Just _) -> KeyMap.delete "body" - _ -> KeyMap.delete "title" - ) - & KeyMap.delete "utc" - & KeyMap.delete "priority_adjustment" - & KeyMap.delete "tags" - & (if notes /= [] then KeyMap.delete "notes" else P.identity) - ) - & ( \val -> - if val == KeyMap.empty - then - Nothing - else Just (Object val) - ) - ) - tempTask = Task{ulid = "", ..} - - o_ulid <- o .:? "ulid" - let - ulidGeneratedRes = - tempTask & (hash >>> toInteger >>> abs >>> ulidFromInteger) - ulidCombined = - (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` createdUtc - ulid = - T.toLower $ - fromMaybe - "" - (o_ulid <|> Just (show ulidCombined)) - - -- let showInt = show :: Int -> Text - -- uuid <- o .:? "uuid" - -- -- Map `show` over `Parser` & `Maybe` to convert possible `Int` to `Text` - -- id <- (o .:? "id" <|> ((showInt <$>) <$> (o .:? "id"))) - -- let id = (uuid <|> id) - - let finalTask = tempTask{Task.ulid = ulid} - - pure $ ImportTask finalTask notes tags - - -setMissingFields :: ImportTask -> IO ImportTask -setMissingFields importTaskRec = do - now <- dateCurrent - let nowUlidTxt = now & toUlidTime & show & T.toLower - pure $ - importTaskRec - { task = - importTaskRec.task - { Task.ulid = - if zeroUlidTxt `T.isPrefixOf` importTaskRec.task.ulid - then - importTaskRec.task.ulid - & T.replace zeroUlidTxt nowUlidTxt - else importTaskRec.task.ulid - , Task.modified_utc = - if importTaskRec.task.modified_utc == "" - || importTaskRec.task.modified_utc == "1970-01-01 00:00:00" - || importTaskRec.task.modified_utc == "1970-01-01 00:00:00.000" - || parseUtc importTaskRec.task.modified_utc == parseUtcNum 0 - then - now - & timePrint (toFormat importUtcFormat) - & T.pack - else show importTaskRec.task.modified_utc - } - } - - insertImportTask :: Connection -> ImportTask -> IO (Doc AnsiStyle) insertImportTask connection importTask = do effectiveUserName <- getEffectiveUserName diff --git a/tasklite-core/source/ImportTask.hs b/tasklite-core/source/ImportTask.hs new file mode 100644 index 0000000..1fd657d --- /dev/null +++ b/tasklite-core/source/ImportTask.hs @@ -0,0 +1,477 @@ +{-| +Datatype `ImportTask` plus instances and functions +-} +module ImportTask where + +import Protolude ( + Alternative ((<|>)), + Applicative (pure), + Char, + Eq ((==)), + Functor (fmap), + Generic, + Hashable (hash), + Integral (toInteger), + Maybe (..), + Num (abs), + Semigroup ((<>)), + Show, + Text, + asum, + fromMaybe, + hush, + isJust, + optional, + show, + ($), + (&), + (.), + (/=), + (<&>), + (=<<), + (>>=), + (||), + ) +import Protolude qualified as P + +import Control.Arrow ((>>>)) +import Data.Aeson (Value) +import Data.Aeson as Aeson ( + FromJSON (parseJSON), + ToJSON, + Value (Object, String), + withObject, + (.!=), + (.:), + (.:?), + ) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser, parseMaybe) +import Data.Hourglass ( + DateTime, + Time (timeFromElapsedP), + TimeFormatString, + timePrint, + toFormat, + ) +import Data.Text qualified as T +import Data.Time.ISO8601.Duration qualified as Iso +import Data.ULID (ULID, ulidFromInteger) +import Note (Note (..)) +import System.Hourglass (dateCurrent) +import Task ( + Task ( + Task, + awake_utc, + body, + closed_utc, + due_utc, + group_ulid, + metadata, + modified_utc, + priority_adjustment, + ready_utc, + recurrence_duration, + repetition_duration, + review_utc, + state, + ulid, + user, + waiting_utc + ), + emptyTask, + textToTaskState, + ) +import Utils ( + emptyUlid, + parseUlidText, + parseUtc, + parseUtcNum, + setDateTime, + toUlidTime, + zeroTime, + zeroUlidTxt, + ) + + +data Annotation = Annotation + { entry :: Text + , description :: Text + } + deriving (Generic, Eq) + + +instance Hashable Annotation + + +instance ToJSON Annotation + + +instance FromJSON Annotation where + parseJSON = withObject "annotation" $ \o -> do + entry <- o .: "entry" + description <- o .: "description" + pure Annotation{..} + + +annotationToNote :: Annotation -> Note +annotationToNote annot@Annotation{entry, description} = do + let + utc = entry & parseUtc & fromMaybe (timeFromElapsedP 0 :: DateTime) + ulidGeneratedRes = annot & (hash >>> toInteger >>> abs >>> ulidFromInteger) + ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` utc + + Note + { ulid = (T.toLower . show) ulidCombined + , body = description + } + + +textToNote :: DateTime -> Text -> Note +textToNote utc body = + let + ulidGeneratedRes = body & (hash >>> toInteger >>> abs >>> ulidFromInteger) + ulidCombined = (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` utc + in + Note + { ulid = (T.toLower . show) ulidCombined + , body = body + } + + +importUtcFormat :: TimeFormatString +importUtcFormat = + toFormat ("YYYY-MM-DD H:MI:S.ms" :: [Char]) + + +data ImportTask = ImportTask + { task :: Task + , notes :: [Note] + , tags :: [Text] + } + deriving (Show) + + +emptyImportTask :: ImportTask +emptyImportTask = + ImportTask + { task = emptyTask + , notes = [] + , tags = [] + } + + +-- | Values a suffixed with a prime (') to avoid name collisions +instance FromJSON ImportTask where + parseJSON = withObject "task" $ \o -> do + utc <- o .:? "utc" + entry <- o .:? "entry" + creation <- o .:? "creation" + creation_utc <- o .:? "creation_utc" + creationUtc <- o .:? "creationUtc" + created <- o .:? "created" + created_at <- o .:? "created_at" + createdAt <- o .:? "createdAt" + created_utc <- o .:? "created_utc" + createdUtc_ <- o .:? "createdUtc" + + let + parsedCreatedUtc = + parseUtc + =<< ( utc + <|> entry + <|> creation + <|> creation_utc + <|> creationUtc + <|> created + <|> created_at + <|> createdAt + <|> created_utc + <|> createdUtc_ + ) + createdUtc = fromMaybe zeroTime parsedCreatedUtc + + o_title <- o .:? "title" + o_body <- o .:? "body" + description <- o .:? "description" + let body = fromMaybe "" (o_title <|> o_body <|> description) + + o_priority_adjustment <- o .:? "priority_adjustment" + urgency <- o .:? "urgency" + priority <- optional (o .: "priority") + let priority_adjustment = o_priority_adjustment <|> urgency <|> priority + + modified <- o .:? "modified" + modified_at <- o .:? "modified_at" + o_modified_utc <- o .:? "modified_utc" + modification_date <- o .:? "modification_date" + updated_at <- o .:? "updated_at" + let + -- TODO: Parse the fields first and then combine them with `<|>` + maybeModified = + modified + <|> modified_at + <|> o_modified_utc + <|> modification_date + <|> updated_at + modified_utc = + maybeModified + >>= parseUtc + & fromMaybe createdUtc + & timePrint importUtcFormat + & T.pack + + o_state <- o .:? "state" + status <- o .:? "status" + let + state = textToTaskState =<< (o_state <|> status) + implicitCloseUtcMaybe = + if isJust state + then + maybeModified + <|> Just (T.pack $ timePrint importUtcFormat createdUtc) + else Nothing + + o_tags <- o .:? "tags" + (o_labelsMb :: Maybe [Value]) <- o .:? "labels" + let labels = + o_labelsMb + <&> ( ( \o_labels -> + o_labels <&> \case + String txt -> Just txt + Object obj -> + P.flip parseMaybe obj (\o_ -> o_ .:? "name" .!= "") + _ -> Nothing + ) + >>> P.catMaybes + ) + + project <- o .:? "project" + let + projects = project <&> (: []) + tags = fromMaybe [] (o_tags <> labels <> projects) + + due <- o .:? "due" + o_due_utc <- o .:? "due_utc" + due_on <- o .:? "due_on" + let + maybeDue = due <|> o_due_utc <|> due_on + due_utc = + fmap + (T.pack . timePrint importUtcFormat) + (parseUtc =<< maybeDue) + + awake' <- o .:? "awake" + awake_at' <- o .:? "awake_at" + sleep' <- o .:? "sleep" + sleep_utc' <- o .:? "sleep_utc" + sleep_until' <- o .:? "sleep_until" + wait' <- o .:? "wait" + wait_until' <- o .:? "wait_until" + let + maybeAwake = + awake' + <|> awake_at' + <|> sleep' + <|> sleep_utc' + <|> sleep_until' + <|> wait' + <|> wait_until' + awake_utc = + fmap + (T.pack . timePrint importUtcFormat) + (parseUtc =<< maybeAwake) + + ready' <- o .:? "ready" + ready_since' <- o .:? "ready_since" + ready_utc' <- o .:? "ready_utc" + let + maybeReady = ready' <|> ready_since' <|> ready_utc' + ready_utc = + fmap + (T.pack . timePrint importUtcFormat) + (parseUtc =<< maybeReady) + + review' <- o .:? "review" + review_at' <- o .:? "review_at" + review_since' <- o .:? "review_since" + review_utc' <- o .:? "review_utc" + let + maybeReview = review' <|> review_at' <|> review_since' <|> review_utc' + review_utc = + fmap + (T.pack . timePrint importUtcFormat) + (parseUtc =<< maybeReview) + + waiting' <- o .:? "waiting" + waiting_since' <- o .:? "waiting_since" + waiting_utc' <- o .:? "waiting_utc" + let + maybewaiting = waiting' <|> waiting_since' <|> waiting_utc' + waiting_utc = + fmap + (T.pack . timePrint importUtcFormat) + (parseUtc =<< maybewaiting) + + closed <- o .:? "closed" + o_closed_utc <- o .:? "closed_utc" + closed_at <- o .:? "closed_at" + closed_on <- o .:? "closed_on" + end <- o .:? "end" + o_end_utc <- o .:? "end_utc" + end_on <- o .:? "end_on" + let + maybeClosed = + closed + <|> o_closed_utc + <|> closed_at + <|> closed_on + <|> end + <|> o_end_utc + <|> end_on + <|> implicitCloseUtcMaybe + closed_utc = + fmap + (T.pack . timePrint importUtcFormat) + (parseUtc =<< maybeClosed) + + group_ulid <- o .:? "group_ulid" + + let parseIsoDurationMb durTextMb = + hush $ + fmap (P.decodeUtf8 . Iso.formatDuration) $ + Iso.parseDuration $ + P.encodeUtf8 $ + fromMaybe "" durTextMb + + repetition_duration' <- o .:? "repetition_duration" + repeat_duration' <- o .:? "repeat_duration" + let + maybeRepetition = repetition_duration' <|> repeat_duration' + repetition_duration = parseIsoDurationMb maybeRepetition + + recurrence_duration' <- o .:? "recurrence_duration" + recur_duration' <- o .:? "recur_duration" + let + maybeRecurrence = recurrence_duration' <|> recur_duration' + recurrence_duration = parseIsoDurationMb maybeRecurrence + + o_notes <- + asum + [ o .:? "notes" :: Parser (Maybe [Note]) + , do + notesMb <- o .:? "notes" :: Parser (Maybe [Text]) + pure $ case notesMb of + Just textNotes -> Just $ textNotes <&> textToNote createdUtc + Nothing -> Just [] + ] + annotations <- o .:? "annotations" :: Parser (Maybe [Annotation]) + + let + notes = case (o_notes, annotations) of + (Nothing, Nothing) -> [] + (Nothing, Just values) -> values <&> annotationToNote + (Just theNotes, _) -> case parsedCreatedUtc of + Just crUtc -> + theNotes + <&> ( \theNote -> + theNote + { Note.ulid = + theNote.ulid + & parseUlidText + <&> P.flip setDateTime crUtc + <&> show @ULID + & fromMaybe theNote.ulid + & T.toLower + } + ) + Nothing -> theNotes + + (o_userMb :: Maybe Value) <- o .:? "user" + o_author <- o .:? "author" + let + o_userNormMb = + o_userMb >>= \case + String txt -> Just txt + Object obj -> + P.flip parseMaybe obj (\o_ -> o_ .:? "login" .!= "") + _ -> Nothing + userMaybe = o_userNormMb <|> o_author + user = fromMaybe "" userMaybe + + o_metadata <- o .:? "metadata" + let + -- Only delete fields with highest priority, + -- as they would definitely have been used if available + -- TODO: Check which fields were actually used and delete only them + -- (Crudly done for title and body) + metadata = + o_metadata + <|> ( ( o + & ( case (o_title, o_body) of + (Nothing, Just _) -> KeyMap.delete "body" + _ -> KeyMap.delete "title" + ) + & KeyMap.delete "utc" + & KeyMap.delete "priority_adjustment" + & KeyMap.delete "tags" + & (if notes /= [] then KeyMap.delete "notes" else P.identity) + ) + & ( \val -> + if val == KeyMap.empty + then + Nothing + else Just (Object val) + ) + ) + tempTask = Task{ulid = "", ..} + + o_ulid <- o .:? "ulid" + let + ulidGeneratedRes = + tempTask & (hash >>> toInteger >>> abs >>> ulidFromInteger) + ulidCombined = + (ulidGeneratedRes & P.fromRight emptyUlid) `setDateTime` createdUtc + ulid = + T.toLower $ + fromMaybe + "" + (o_ulid <|> Just (show ulidCombined)) + + -- let showInt = show :: Int -> Text + -- uuid <- o .:? "uuid" + -- -- Map `show` over `Parser` & `Maybe` to convert possible `Int` to `Text` + -- id <- (o .:? "id" <|> ((showInt <$>) <$> (o .:? "id"))) + -- let id = (uuid <|> id) + + let finalTask = tempTask{Task.ulid = ulid} + + pure $ ImportTask finalTask notes tags + + +setMissingFields :: ImportTask -> P.IO ImportTask +setMissingFields importTaskRec = do + now <- dateCurrent + let nowUlidTxt = now & toUlidTime & show & T.toLower + pure $ + importTaskRec + { task = + importTaskRec.task + { Task.ulid = + if zeroUlidTxt `T.isPrefixOf` importTaskRec.task.ulid + then + importTaskRec.task.ulid + & T.replace zeroUlidTxt nowUlidTxt + else importTaskRec.task.ulid + , Task.modified_utc = + if importTaskRec.task.modified_utc == "" + || importTaskRec.task.modified_utc == "1970-01-01 00:00:00" + || importTaskRec.task.modified_utc == "1970-01-01 00:00:00.000" + || parseUtc importTaskRec.task.modified_utc == parseUtcNum 0 + then + now + & timePrint (toFormat importUtcFormat) + & T.pack + else show importTaskRec.task.modified_utc + } + } diff --git a/tasklite-core/source/Lib.hs b/tasklite-core/source/Lib.hs index 257b7d3..22d20b9 100644 --- a/tasklite-core/source/Lib.hs +++ b/tasklite-core/source/Lib.hs @@ -14,7 +14,7 @@ import Protolude ( Char, Double, Down (Down), - Either, + Either (Left, Right), Eq (..), FilePath, Float, @@ -223,6 +223,8 @@ import FullTask ( cpTimesAndState, selectQuery, ) +import Hooks (HookResult (message, taskToAdd), executeHooks) +import ImportTask (setMissingFields, task) import Note (Note (body, ulid)) import SqlUtils (quoteKeyword, quoteText) import Task ( @@ -242,7 +244,6 @@ import Utils ( ListModifiedFlag (..), applyColorMode, dateTimeToUtcTime, - executeHooks, formatElapsedP, numDigits, parseUlidText, @@ -488,7 +489,7 @@ addTask conf connection bodyWords = do (ulid, modified_utc, effectiveUserName) <- getTriple conf let (body, tags, dueUtcMb, createdUtcMb) = parseTaskBody bodyWords - task = + taskDraft = emptyTask { Task.ulid = T.toLower $ show $ case createdUtcMb of Nothing -> ulid @@ -500,19 +501,39 @@ addTask conf connection bodyWords = do } args <- getArgs - preAddResult <- + preAddResults <- executeHooks ( TL.toStrict $ TL.decodeUtf8 $ Aeson.encode $ object [ "arguments" .= args - , "taskToAdd" .= task + , "taskToAdd" .= taskDraft -- TODO: Add tags and notes to task ] ) conf.hooks.add.pre - putDoc preAddResult + + -- Maybe the task was changed by the hook + task <- case preAddResults of + [] -> pure taskDraft + [Left error] -> do + putDoc $ pretty error + _ <- exitFailure + pure taskDraft + [Right hookResult] -> do + case hookResult.taskToAdd of + Nothing -> pure taskDraft + Just taskToAdd -> do + putDoc $ pretty hookResult.message + fullImportTask <- setMissingFields taskToAdd + pure fullImportTask.task + _ -> do + putDoc $ + annotate (color Red) $ + "ERROR: Multiple pre-add hooks are not supported yet. " + <> "None of the hooks were executed." + pure taskDraft insertRecord "tasks" connection task warnings <- insertTags connection Nothing task tags @@ -526,7 +547,7 @@ addTask conf connection bodyWords = do case insertedTasks of [insertedTask] -> do - postAddResult <- + postAddResults <- executeHooks ( TL.toStrict $ TL.decodeUtf8 $ @@ -539,6 +560,15 @@ addTask conf connection bodyWords = do ) conf.hooks.add.post + let + hookResultMsg :: Doc AnsiStyle + hookResultMsg = + postAddResults + <&> \case + Left error -> "ERROR:" <+> pretty error + Right hookResult -> pretty hookResult.message + & P.fold + pure $ warnings <$$> ( "🆕 Added task" @@ -546,7 +576,7 @@ addTask conf connection bodyWords = do <+> "with id" <+> dquotes (pretty task.ulid) ) - <$$> postAddResult + <$$> hookResultMsg --- _ -> pure "Task could not be added" diff --git a/tasklite-core/source/Utils.hs b/tasklite-core/source/Utils.hs index e0a171a..5577d98 100644 --- a/tasklite-core/source/Utils.hs +++ b/tasklite-core/source/Utils.hs @@ -20,7 +20,6 @@ import Protolude ( Integer, Integral (div, mod), Maybe (..), - Monoid (mempty), Num ((*), (+)), Ord ((<), (>)), Rational, @@ -30,7 +29,6 @@ import Protolude ( Show, Word16, flip, - forM, fromIntegral, fromMaybe, fst, @@ -71,7 +69,6 @@ import Data.Text as T ( pack, take, toLower, - unlines, unpack, ) import Data.Time (UTCTime, ZonedTime, addUTCTime, zonedTimeToUTC) @@ -79,20 +76,17 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.ULID (ULID (ULID, random, timeStamp)) import Data.ULID.Random (ULIDRandom, mkULIDRandom) import Data.ULID.TimeStamp (ULIDTimeStamp, mkULIDTimeStamp) -import Prettyprinter (Doc, Pretty (pretty), softline) +import Prettyprinter (Doc, 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, utcFormat), Hook (body, filePath, interpreter)) +import Config (Config (bodyStyle, utcFormat)) import Control.Arrow ((>>>)) import Prettyprinter.Internal.Type (Doc (Empty)) -import System.FilePath (takeExtension) import System.Random (mkStdGen) @@ -314,37 +308,6 @@ numDigits base num = 1 + fst (ilog base num) -executeHooks :: Text -> [Hook] -> IO (Doc AnsiStyle) -executeHooks stdinText hooks = do - let - stdinStr = T.unpack stdinText - getInterpreter s = - if - | s `P.elem` ["javascript", "js", "node", "node.js"] -> ("node", "-e") - | s `P.elem` ["lua"] -> ("lua", "-e") - | s `P.elem` ["python", "python3", "py"] -> ("python3", "-c") - | s `P.elem` ["ruby", "rb"] -> ("ruby", "-e") - | otherwise -> pure mempty - - cmdOutput <- forM hooks $ \hook -> do - case hook.filePath of - Just fPath -> do - case fPath & takeExtension & P.drop 1 of - "" -> - -- Is excuted with shell - readProcess fPath [] stdinStr - ext -> do - let (interpreter, cliFlag) = getInterpreter ext - fileContent <- P.readFile fPath - readProcess interpreter [cliFlag, T.unpack fileContent] stdinStr - --- - Nothing -> do - let (interpreter, cliFlag) = getInterpreter hook.interpreter - readProcess interpreter [cliFlag, T.unpack hook.body] stdinStr - - pure $ cmdOutput <&> T.pack & T.unlines & pretty - - applyColorMode :: Config -> IO Config applyColorMode conf = do layerColorBgMb <- diff --git a/tasklite-core/tasklite-core.cabal b/tasklite-core/tasklite-core.cabal index de123bd..c079b57 100644 --- a/tasklite-core/tasklite-core.cabal +++ b/tasklite-core/tasklite-core.cabal @@ -37,7 +37,9 @@ library Cli Config FullTask + Hooks ImportExport + ImportTask Lib Migrations Note diff --git a/tasklite-core/test/ImportExportSpec.hs b/tasklite-core/test/ImportExportSpec.hs index 6eaf2d4..b37476e 100644 --- a/tasklite-core/test/ImportExportSpec.hs +++ b/tasklite-core/test/ImportExportSpec.hs @@ -32,7 +32,8 @@ import Test.Hspec ( import Config (defaultConfig) import FullTask (FullTask, emptyFullTask) import FullTask qualified -import ImportExport (ImportTask (ImportTask, notes, tags, task), insertImportTask) +import ImportExport (insertImportTask) +import ImportTask (ImportTask (ImportTask, notes, tags, task)) import Task (Task (body, modified_utc, ulid, user), emptyTask) import TaskToNote (TaskToNote (TaskToNote)) import TaskToNote qualified diff --git a/tasklite/test/CliSpec.hs b/tasklite/test/CliSpec.hs index f3404b3..a78cefd 100644 --- a/tasklite/test/CliSpec.hs +++ b/tasklite/test/CliSpec.hs @@ -71,26 +71,46 @@ spec tmpDirPath = do preAddHook = getLuaHook [raw| - print("🏃 Executing pre-add script …") - print("ℹ️ Receives an object with arguments:", io.read("*a")) + io.stderr:write("🏃 Executing pre-add script …\n") + io.stderr:write( + "ℹ️ Receives an object with arguments:\n", + io.read("*a"), + "\n" + ) + -- print("{}") |] postAddHook = getLuaHook [raw| - print("🏃 Executing post-add script …") - print("ℹ️ Receives an object with arguments:", io.read("*a")) + io.stderr:write("🏃 Executing post-add script …\n") + io.stderr:write( + "ℹ️ Receives an object with arguments:\n", + io.read("*a"), + "\n" + ) + -- print("{}") |] preModifyHook = getLuaHook [raw| - print("🏃 Executing pre-modify script …") - print("ℹ️ Receives an object with arguments:", io.read("*a")) + io.stderr:write("🏃 Executing pre-modify script …\n") + io.stderr:write( + "ℹ️ Receives an object with arguments:\n", + io.read("*a"), + "\n" + ) + -- print("{}") |] postModifyHook = getLuaHook [raw| - print("🏃 Executing post-modify script …") - print("ℹ️ Receives an object with arguments:", io.read("*a")) + io.stderr:write("🏃 Executing post-modify script …\n") + io.stderr:write( + "ℹ️ Receives an object with arguments:\n", + io.read("*a"), + "\n" + ) + -- print("{}") |] testConf = defaultConfig @@ -125,15 +145,23 @@ spec tmpDirPath = do hookFor "pre-launch.lua" [raw| - print("🏃 Executing pre-launch script …") - print("ℹ️ Receives no input:", io.read("*a")) + io.stderr:write("🏃 Executing pre-launch script …\n") + io.stderr:write( + "ℹ️ Receives no input:", + io.read("*a"), + "\n" + ) |] hookFor "post-launch.lua" [raw| - print("🏃 Executing post-launch script …") - print("ℹ️ Receives an object with arguments:", io.read("*a")) + io.stderr:write("🏃 Executing post-launch script …\n") + io.stderr:write( + "ℹ️ Receives an object with arguments:", + io.read("*a"), + "\n" + ) |] _ <- printOutput "test-app" (Just ["head"]) testConf