From e1f312251de05c003b1c8677342e1402171613f7 Mon Sep 17 00:00:00 2001 From: mbays Date: Tue, 25 Jan 2022 00:00:00 +0000 Subject: [PATCH] add command "fetch" to cache-and-queue --- Command.hs | 7 +++++-- diohsc.hs | 65 ++++++++++++++++++++++++++++++++++++++++---------------------- 2 files changed, 47 insertions(+), 25 deletions(-) diff --git a/Command.hs b/Command.hs index 325f59c..cc519ad 100644 --- a/Command.hs +++ b/Command.hs @@ -36,7 +36,7 @@ commands restricted = metaCommands ++ navCommands ++ infoCommands ++ actionCommands restricted ++ otherCommands where metaCommands = ["help", "quit"] - navCommands = ["repeat", "mark", "inventory", "identify", "add", "delete"] + navCommands = ["repeat", "mark", "inventory", "identify", "add", "fetch", "delete"] infoCommands = ["show", "page", "uri", "links", "mime"] unsafeActionCommands = ["save", "view", "browse", "!", "|", "||", "||-"] safeActionCommands = ["cat"] @@ -394,7 +394,10 @@ helpOn s = , "TARGETS {add} foo: add targets to the named queue foo~." , "TARGETS {add} foo N: add targets to the named queue after entry foo~N." , "" - , "See also: {queue}, {targets}." ] + , "See also: {fetch}, {queue}, {targets}." ] + "fetch" -> + [ "{fetch} acts like {add}, but targets are fetched and cached before being added." + , "See {add} for syntax." ] "delete" -> [ "TARGETS {delete}: delete specified uris from the queue." , "e.g. \"~3-5,7d\" to delete certain entries, or \"~-d\" to clear the queue," diff --git a/diohsc.hs b/diohsc.hs index d2d03eb..f98f9ec 100644 --- a/diohsc.hs +++ b/diohsc.hs @@ -23,6 +23,7 @@ import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bifunctor (second) import Data.Char (isAlpha, isUpper, toLower) import Data.Hash (Hash, hash) +import Data.IORef (modifyIORef, newIORef, readIORef) import Data.List (find, intercalate, isPrefixOf, isSuffixOf, sort, stripPrefix) import Data.Maybe @@ -157,10 +158,13 @@ data ClientConfig = ClientConfig defaultClientConfig :: ClientConfig defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre False 1000 80 False False -data QueueItem = QueueItem - { queueOrigin :: Maybe HistoryOrigin - , queueUri :: URI - } +data QueueItem + = QueueURI (Maybe HistoryOrigin) URI + | QueueHistory HistoryItem + +queueUri :: QueueItem -> URI +queueUri (QueueURI _ uri) = uri +queueUri (QueueHistory item) = historyUri item data ClientState = ClientState { clientCurrent :: Maybe HistoryItem @@ -353,7 +357,7 @@ lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir qfs <- ((\qn -> (queuesDir qn, qn)) <$>) <$> listDirectory queuesDir return $ qf <> qfs queueLine :: T.Text -> Maybe QueueItem - queueLine s = QueueItem Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s) + queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s) appendQueuesToFiles :: ClientM () appendQueuesToFiles = do @@ -437,8 +441,9 @@ targetUri (TargetIdUri _ uri) = uri targetUri (TargetUri uri) = uri targetQueueItem :: Target -> QueueItem -targetQueueItem (TargetFrom o uri) = QueueItem (Just o) uri -targetQueueItem i = QueueItem Nothing $ targetUri i +targetQueueItem (TargetFrom o uri) = QueueURI (Just o) uri +targetQueueItem (TargetHistory item) = QueueHistory item +targetQueueItem i = QueueURI Nothing $ targetUri i handleCommandLine :: ClientOptions -> ClientState -> CommandLine -> ClientM () handleCommandLine @@ -614,8 +619,9 @@ handleCommandLine (matchPatternOn $ show . queueUri) queue specs where queue = M.findWithDefault [] qname queues - queueTarget (QueueItem Nothing uri) = TargetUri uri - queueTarget (QueueItem (Just o) uri) = TargetFrom o uri + queueTarget (QueueURI Nothing uri) = TargetUri uri + queueTarget (QueueURI (Just o) uri) = TargetFrom o uri + queueTarget (QueueHistory item) = TargetHistory item resolveTarget (PTargetRoot base) = (rootOf <$>) <$> resolveTarget base @@ -717,6 +723,17 @@ handleCommandLine modify $ \s -> s { clientQueuedCommands = clientQueuedCommands s ++ queued } | otherwise = liftIO $ mapM_ T.putStrLn ls + parseQueueSpec :: [CommandArg] -> Maybe (String, Maybe Int) + parseQueueSpec [] = Just ("", Nothing) + parseQueueSpec [CommandArg a _] | Just n <- readMay a = Just ("", Just n) + parseQueueSpec (CommandArg a _:as) | not (null a), all isAlpha a + , Just mn <- case as of + [] -> Just Nothing + [CommandArg a' _] | Just n <- readMay a' -> Just (Just n) + _ -> Nothing + = Just (a, mn) + parseQueueSpec _ = Nothing + handleBareTargets :: [Target] -> ClientM () handleBareTargets [] = return () handleBareTargets (_:_:_) = @@ -864,20 +881,22 @@ handleCommandLine Nothing -> printErr "No current location. Enter an URI, or type \"help\"." handleCommand ts ("add", args) = case parseQueueSpec args of - Nothing -> printErr "Bad arguments to 'add'." - Just (qname, mn) -> - enqueue qname mn $ targetQueueItem <$> ts - where - parseQueueSpec :: [CommandArg] -> Maybe (String, Maybe Int) - parseQueueSpec [] = Just ("", Nothing) - parseQueueSpec [CommandArg a _] | Just n <- readMay a = Just ("", Just n) - parseQueueSpec (CommandArg a _:as) | not (null a), all isAlpha a - , Just mn <- case as of - [] -> Just Nothing - [CommandArg a' _] | Just n <- readMay a' -> Just (Just n) - _ -> Nothing - = Just (a, mn) - parseQueueSpec _ = Nothing + Nothing -> printErr "Bad arguments to 'add'." + Just (qname, mn) -> enqueue qname mn $ targetQueueItem <$> ts + + handleCommand ts ("fetch", args) = case parseQueueSpec args of + Nothing -> printErr "Bad arguments to 'fetch." + Just (qname, mn) -> do + -- XXX: we have to use an IORef to store the items, since + -- CommandAction doesn't allow a return value. + lRef <- liftIO $ newIORef [] + let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:) + forM_ ts $ \t -> case t of + TargetHistory item -> add item + _ -> dropUriFromQueues uri >> doRequestUri uri add + where uri = targetUri t + l <- liftIO $ reverse <$> readIORef lRef + enqueue qname mn $ QueueHistory <$> l handleCommand ts cargs = mapM_ handleTargetCommand ts -- 2.11.4.GIT