diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ This file covers only non-trivial user-visible changes; see the git log for full gory details. +# 0.1.10 +* Allow pre-fetched items in queue, with new "fetch" command to add them +* Add named queues, e.g. foo~ +* Implement notation for (n-from) last element of a list, e.g. _$, _$2, _5-$2 +* Run default action on a history item when going to it, e.g. with < +* Don't shell-quote explicit '%s' arguments, only implicit final argument + # 0.1.9 * Improve wrapping and paging with long words, wide chars, or thin terminals * Shell-quote arguments to 'browse' and '!' diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -36,7 +36,7 @@ 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"] @@ -189,8 +189,10 @@ , " Specify first match of pattern with \"^pattern^\"," , " or all matches with \"^^pattern^\"." , " Specify multiple items or ranges by separating with \",\"." - , " Examples: \"1,3-5,^pattern^-\" refers to links 1,3,4,5 and all links from the" - , " the first match of pattern onwards, and \"~-\" refers to the whole queue." + , " Last item is denoted by \"$\", and nth from last by \"$n\"." + , " Examples: \"1,3-5,^pattern^-$2\" refers to links 1,3,4,5 and all links from" + , " the first match of pattern to the penultimate item;" + , " \"~-\" refers to the whole queue." , "" , " Patterns are (extended) regular expressions (see `man 7 regex`)." , " Matching is case-insensitive unless pattern contains an uppercase character." @@ -221,7 +223,11 @@ , "" , "Any uris written to {~/queue} (one uri per line)" , "will be added to the queue, after which that file will be deleted." - , "This allows e.g. an rss reader to add to the queue of a diohsc instance." ] + , "This allows e.g. an rss reader to add to the queue of a diohsc instance." + , "" + , "You may also create named queues like \"foo~\" with a name argument to {add}." + , "The corresponding file is e.g. {~/queues/foo}." + ] "pager" -> [ "Keys for the inbuilt pager:" , " space : advance one page" @@ -384,11 +390,21 @@ [ "TARGETS {add}: add targets to the end of the queue." , "TARGETS {add} 0: add targets to the start of the queue." , "TARGETS {add} N: add targets to the queue after entry ~N." - , "See also: {queue}, {targets}." ] + , "" + , "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: {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 queue." + [ "TARGETS {delete}: delete specified uris from the queue." , "e.g. \"~3-5,7d\" to delete certain entries, or \"~-d\" to clear the queue," - , "or \"-d\" to delete all queue entries which are links from the current location." ] + , "or \"-d\" to delete all queue entries which are links from the current location." + , "" + , "TARGETS {delete} foo: delete specified uris from the named queue foo~." + ] "show" -> ["TARGET {show}: show rendered text of target, without paging."] "page" -> [ "TARGET {page}: page rendered text of target." , "See also: {pager}, {default_action}" ] diff --git a/CommandLine.hs b/CommandLine.hs --- a/CommandLine.hs +++ b/CommandLine.hs @@ -32,6 +32,7 @@ data ElemSpec = ESNum Int + | ESNumFromEnd Int | ESSearch String deriving (Eq,Ord,Show) @@ -64,6 +65,7 @@ resolveES :: ElemSpec -> Either String Int resolveES (ESNum n) = return $ n - 1 + resolveES (ESNumFromEnd n) = return $ length as - n resolveES (ESSearch s) = maybe (Left $ "No " <> typeStr <> " matches pattern: " ++ s) Right $ headMay . map fst . filter snd . zip [0..] $ (s `match`) <$> as @@ -74,7 +76,7 @@ | PTargetMark String | PTargetAbs String | PTargetLog ElemsSpecs - | PTargetQueue ElemsSpecs + | PTargetQueue String ElemsSpecs | PTargetRoot PTarget | PTargetAncestors PTarget ElemsSpecs | PTargetDescendants PTarget ElemsSpecs @@ -142,6 +144,10 @@ elemSpec :: Parser ElemSpec elemSpec = choice [ ESNum <$> nat + , char '$' >> ESNumFromEnd <$> choice + [ nat + , (+ 1) <$> countMany (string "$") + ] , char '^' >> ESSearch <$> patt ] elemsSpec :: Parser ElemsSpec @@ -170,10 +176,12 @@ baseTarget :: Parser PTarget baseTarget = choice - [ PTargetLinks False PTargetCurr <$> elemsSpecs + [ PTargetLog <$> elemsSpecsBy (string "$") + , PTargetLinks False PTargetCurr <$> elemsSpecs , PTargetRef PTargetCurr <$> ref "./?" - , PTargetLog <$> elemsSpecsBy (string "$") - , PTargetQueue <$> elemsSpecsBy (string "~") + , try $ do + s <- many alphaNum + PTargetQueue s <$> elemsSpecsBy (string "~") , char '\'' >> choice [ char '\'' >> return PTargetJumpBack , PTargetMark <$> many1 alphaNum ] diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -161,7 +161,7 @@ deriving Show instance Exception RequestException --- |On success, returns `Right lazyResp terminate`. `lazyResp` is a `Response` +-- |On success, returns `Right (lazyResp,terminate)`. `lazyResp` is a `Response` -- with lazy IO, so attempts to read it may block while data is received. If -- the full response is not needed, for example because of an error, the IO -- action `terminate` should be called to close the connection. diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.9 +VERSION=0.1.10 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa diff --git a/RunExternal.hs b/RunExternal.hs --- a/RunExternal.hs +++ b/RunExternal.hs @@ -49,7 +49,7 @@ subPercent "" = return [] subPercent ('%':'%':s) = ('%':) <$> subPercent s subPercent ('%':'c':s) = (':':) <$> subPercent s - subPercent ('%':'s':s) = put True >> (shellQuote sub ++) <$> subPercent s + subPercent ('%':'s':s) = put True >> (sub ++) <$> subPercent s subPercent (c:s) = (c:) <$> subPercent s shellQuote s | all shellSafe s && not (null s) = s diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -16,4 +16,4 @@ programName = "diohsc" version :: String -version = "0.1.9" +version = "0.1.10" diff --git a/diohsc.cabal b/diohsc.cabal --- a/diohsc.cabal +++ b/diohsc.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: diohsc -version: 0.1.9 +version: 0.1.10 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org diff --git a/diohsc.hs b/diohsc.hs --- a/diohsc.hs +++ b/diohsc.hs @@ -21,8 +21,9 @@ import Control.Monad.State import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bifunctor (second) -import Data.Char (isUpper, toLower) +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,17 +158,20 @@ 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 , clientJumpBack :: Maybe HistoryItem , clientLog :: BStack.BStack T.Text , clientVisited :: S.Set Hash - , clientQueue :: [QueueItem] + , clientQueues :: M.Map String [QueueItem] , clientActiveIdentities :: ActiveIdentities , clientMarks :: Marks , clientSessionMarks :: M.Map Int HistoryItem @@ -181,18 +185,29 @@ type CommandAction = HistoryItem -> ClientM () emptyClientState :: ClientState -emptyClientState = ClientState Nothing Nothing BStack.empty S.empty [] M.empty emptyMarks M.empty defaultAliases [] defaultClientConfig +emptyClientState = ClientState Nothing Nothing BStack.empty S.empty M.empty M.empty emptyMarks M.empty defaultAliases [] defaultClientConfig -enqueue :: Maybe Int -> [QueueItem] -> ClientM () -enqueue _ [] = return () -enqueue after qs = modify $ \s -> s {clientQueue = insert after qs $ clientQueue s} - where - insert mn as bs = let (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn in del as bs' ++ as ++ del as bs'' - del as = filter $ (`notElem` (queueUri <$> as)) . queueUri +enqueue :: String -> Maybe Int -> [QueueItem] -> ClientM () +enqueue _ _ [] = return () +enqueue qname after qs = modify $ \s -> s {clientQueues = + M.alter (Just . insertInNubbedList after qs queueUri) qname $ clientQueues s} -dropUriFromQueue :: URI -> ClientM () -dropUriFromQueue uri = modify $ \s -> s { clientQueue = filter ((/= uri) . queueUri) $ clientQueue s } +insertInNubbedList :: Eq b => Maybe Int -> [a] -> (a -> b) -> Maybe [a] -> [a] +insertInNubbedList mn as f mbs = + let bs = fromMaybe [] mbs + (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn + del as' = filter $ (`notElem` (f <$> as')) . f + in del as bs' ++ as ++ del as bs'' +dropUriFromQueue :: String -> URI -> ClientM () +dropUriFromQueue qname uri = modify $ \s -> s { clientQueues = + M.adjust (filter ((/= uri) . queueUri)) qname $ clientQueues s } + +dropUriFromQueues :: URI -> ClientM () +dropUriFromQueues uri = do + qnames <- gets $ M.keys . clientQueues + forM_ qnames (`dropUriFromQueue` uri) + popQueuedCommand :: ClientM (Maybe String) popQueuedCommand = do cmd <- gets $ headMay . clientQueuedCommands @@ -302,10 +317,10 @@ lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do (liftIO . readFileLines $ userDataDir "diohscrc") >>= mapM_ (handleLine' . T.unpack) - lift addToQueueFromFile + lift addToQueuesFromFiles mapM_ handleLine' initialCommands when repl lineClient' - unless ghost $ lift appendQueueToFile + unless ghost $ lift appendQueuesToFiles where handleLine' :: String -> HL.InputT ClientM Bool handleLine' line = lift get >>= \s -> handleLine cOpts s line @@ -318,7 +333,7 @@ printInfoOpt ansi $ "> " <> c return $ Just c , MaybeT $ lift getPrompt >>= promptLineInputT ] - lift addToQueueFromFile + lift addToQueuesFromFiles quit <- case cmd of Nothing -> if interactive then printErrOpt ansi "Use \"quit\" to quit" >> return False @@ -327,27 +342,44 @@ Just (Just line) -> handleLine' line unless quit lineClient' - addToQueueFromFile :: ClientM () - addToQueueFromFile | ghost = return () - | otherwise = enqueue Nothing <=< (liftIO . ignoreIOErr) $ doesPathExist queueFile >>= \case - True -> catMaybes . (queueLine <$>) <$> readFileLines queueFile <* removeFile queueFile - where - queueLine :: T.Text -> Maybe QueueItem - queueLine s = QueueItem Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s) - False -> return [] + addToQueuesFromFiles :: ClientM () + addToQueuesFromFiles | ghost = return () + | otherwise = do + qfs <- ignoreIOErr $ liftIO findQueueFiles + forM_ qfs $ \(qfile, qname) -> enqueue qname Nothing <=< + ignoreIOErr . liftIO $ + catMaybes . (queueLine <$>) <$> readFileLines qfile <* removeFile qfile + ignoreIOErr . liftIO $ removeDirectory queuesDir + where + findQueueFiles :: IO [(FilePath,String)] + findQueueFiles = do + qf <- (\e -> [(queueFile, "") | e]) <$> doesFileExist queueFile + qfs <- ((\qn -> (queuesDir qn, qn)) <$>) <$> listDirectory queuesDir + return $ qf <> qfs + queueLine :: T.Text -> Maybe QueueItem + queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s) - appendQueueToFile :: ClientM () - appendQueueToFile = do - queue <- gets clientQueue - unless (null queue) . liftIO . BL.appendFile queueFile . - T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue + appendQueuesToFiles :: ClientM () + appendQueuesToFiles = do + queues <- gets $ M.toList . clientQueues + liftIO $ createDirectoryIfMissing True queuesDir + liftIO $ forM_ queues appendQueue + where + appendQueue (_, []) = pure () + appendQueue (qname, queue) = + let qfile = case qname of + "" -> queueFile + s -> queuesDir s + in warnIOErr $ BL.appendFile qfile . + T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue - queueFile :: FilePath + queueFile, queuesDir :: FilePath queueFile = userDataDir "queue" + queuesDir = userDataDir "queues" getPrompt :: ClientM String getPrompt = do - queue <- gets clientQueue + queue <- gets $ M.findWithDefault [] "" . clientQueues curr <- gets clientCurrent proxies <- gets $ clientConfProxies . clientConfig ais <- gets clientActiveIdentities @@ -409,13 +441,14 @@ 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 cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH) - cState@(ClientState curr jumpBack cLog visited queue _ marks sessionMarks aliases _ + cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases _ (ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection)) = \(CommandLine mt mcas) -> case mcas of Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases -> @@ -581,11 +614,14 @@ resolveTarget (PTargetLog specs) = (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs - resolveTarget (PTargetQueue specs) = - (queueTarget <$>) <$> resolveElemsSpecs "queue item" (matchPatternOn $ show . queueUri) queue specs + resolveTarget (PTargetQueue qname specs) = + (queueTarget <$>) <$> resolveElemsSpecs "queue item" + (matchPatternOn $ show . queueUri) queue specs where - queueTarget (QueueItem Nothing uri) = TargetUri uri - queueTarget (QueueItem (Just o) uri) = TargetFrom o uri + queue = M.findWithDefault [] qname queues + 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 @@ -687,6 +723,17 @@ 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 (_:_:_) = @@ -720,18 +767,22 @@ let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text showNumberedUri iter s (n,uri) = s <> (if iter && n == 1 then " " - else if iter && n == 2 then s + else if iter && n == 2 then T.takeEnd 1 s else T.pack (show n)) <> " " <> showUriFull ansi ais Nothing uri showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item) showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item) - showIteratedQueueItem s (n,q) = showNumberedUri True s (n, queueUri q) + showIteratedQueueItem s (n, QueueURI _ uri) = + showNumberedUri True s (n, uri) + showIteratedQueueItem s (n, QueueHistory item) = + showNumberedUri True s (n, historyUri item) <> " {fetched}" showJumpBack :: [T.Text] showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack doPage . intercalate [""] . filter (not . null) $ - [ showJumpBack - , showIteratedQueueItem "~" <$> zip [1..] queue - , showNumberedItem "'" <$> M.toAscList sessionMarks + showJumpBack : + [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue + | (qname, queue) <- M.toList queues ] + ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr)) ++ (("@ " <>) . showUriFull ansi ais Nothing . historyUri <$> maybeToList (curr >>= lastMay . historyAncestors)) @@ -832,8 +883,24 @@ Just item -> handleCommand [TargetHistory item] cargs Nothing -> printErr "No current location. Enter an URI, or type \"help\"." - handleCommand ts ("add", args) = - enqueue (readMay . commandArgArg =<< headMay args) $ targetQueueItem <$> ts + handleCommand ts ("add", args) = case parseQueueSpec args of + 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 where @@ -841,7 +908,7 @@ action item handleTargetCommand t | Just action <- actionOfCommand cargs = let uri = targetUri t - in dropUriFromQueue uri >> doRequestUri uri action + in dropUriFromQueues uri >> doRequestUri uri action handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs = goUri True (recreateOrigin <$> historyParent item) $ historyUri item handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs = @@ -854,7 +921,8 @@ recreateOrigin :: HistoryItem -> HistoryOrigin recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent - handleUriCommand uri ("delete",_) = dropUriFromQueue uri + handleUriCommand uri ("delete",[]) = dropUriFromQueue "" uri + handleUriCommand uri ("delete",CommandArg qname _ : _) = dropUriFromQueue qname uri handleUriCommand uri ("repeat",_) = goUri True Nothing uri handleUriCommand uri ("uri",_) = showUri uri handleUriCommand uri ("mark", CommandArg mark _ : _) @@ -907,6 +975,9 @@ goUri True origin . setQuery ('?':escapeQuery query) $ uri repl' + slurpItem :: HistoryItem -> IO () + slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item + actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction actionOnRendered ansi' m item = do ais <- gets clientActiveIdentities @@ -929,7 +1000,8 @@ doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item actionOfCommand ("mark", CommandArg mark _ : _) | - Just n <- readMay mark :: Maybe Int = Just $ \item -> + Just n <- readMay mark :: Maybe Int = Just $ \item -> do + liftIO $ slurpItem item modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s } actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir]) @@ -995,18 +1067,27 @@ when isJump $ modify $ \s -> s { clientJumpBack = curr } modify $ \s -> s { clientCurrent = Just i } + doDefault :: HistoryItem -> ClientM () + doDefault item = + maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction + goHistory :: HistoryItem -> ClientM () - goHistory i = setCurr i >> showUri (historyUri i) + goHistory item = do + dropUriFromQueues uri + showUri uri + doDefault item + setCurr item + where uri = historyUri item goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM () goUri forceRequest origin uri = do - dropUriFromQueue uri + dropUriFromQueues uri activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities case curr >>= flip pathItemByUri uri of Just i' | not (activeId || forceRequest) -> goHistory i' _ -> doRequestUri uri $ \item -> do - maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction - liftIO . slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item + doDefault item + liftIO $ slurpItem item let updateParent i = -- Lazily recursively update the links in the doubly linked list let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }