From 887c6126214e4422149b7aea44d14efb45059933 Mon Sep 17 00:00:00 2001 From: mbays Date: Fri, 24 Dec 2021 00:00:00 +0000 Subject: [PATCH] add named queues --- Command.hs | 10 ++++- CommandLine.hs | 6 ++- GeminiProtocol.hs | 2 +- diohsc.hs | 132 ++++++++++++++++++++++++++++++++++++------------------ 4 files changed, 103 insertions(+), 47 deletions(-) diff --git a/Command.hs b/Command.hs index 3ef4a4c..be41a95 100644 --- a/Command.hs +++ b/Command.hs @@ -223,7 +223,11 @@ helpOn s = , "" , "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" @@ -386,6 +390,10 @@ helpOn s = [ "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." + , "" + , "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}." ] "delete" -> [ "TARGETS {delete}: delete specified uris from queue." diff --git a/CommandLine.hs b/CommandLine.hs index e60f3e3..8158cfc 100644 --- a/CommandLine.hs +++ b/CommandLine.hs @@ -76,7 +76,7 @@ data PTarget | PTargetMark String | PTargetAbs String | PTargetLog ElemsSpecs - | PTargetQueue ElemsSpecs + | PTargetQueue String ElemsSpecs | PTargetRoot PTarget | PTargetAncestors PTarget ElemsSpecs | PTargetDescendants PTarget ElemsSpecs @@ -179,7 +179,9 @@ baseTarget = choice [ PTargetLog <$> elemsSpecsBy (string "$") , PTargetLinks False PTargetCurr <$> elemsSpecs , PTargetRef PTargetCurr <$> ref "./?" - , 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 index 490e349..fc0ec82 100644 --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -161,7 +161,7 @@ newtype RequestException = ExcessivelyLongUri Int 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/diohsc.hs b/diohsc.hs index 6250200..e5f0000 100644 --- a/diohsc.hs +++ b/diohsc.hs @@ -21,7 +21,7 @@ import Control.Monad.Catch 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.List (find, intercalate, isPrefixOf, isSuffixOf, sort, stripPrefix) @@ -167,7 +167,7 @@ data ClientState = ClientState , 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,17 +181,28 @@ type ClientM = StateT ClientState IO 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} + +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 } -dropUriFromQueue :: URI -> ClientM () -dropUriFromQueue uri = modify $ \s -> s { clientQueue = filter ((/= uri) . queueUri) $ clientQueue s } +dropUriFromQueues :: URI -> ClientM () +dropUriFromQueues uri = do + qnames <- gets $ M.keys . clientQueues + forM_ qnames (`dropUriFromQueue` uri) popQueuedCommand :: ClientM (Maybe String) popQueuedCommand = do @@ -302,10 +313,10 @@ lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM () 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 +329,7 @@ lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir 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 +338,44 @@ lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir 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 [] - - appendQueueToFile :: ClientM () - appendQueueToFile = do - queue <- gets clientQueue - unless (null queue) . liftIO . BL.appendFile queueFile . - T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue - - queueFile :: FilePath + 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 = QueueItem Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s) + + 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, 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 @@ -415,7 +443,7 @@ targetQueueItem i = QueueItem 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,9 +609,11 @@ handleCommandLine 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 + queue = M.findWithDefault [] qname queues queueTarget (QueueItem Nothing uri) = TargetUri uri queueTarget (QueueItem (Just o) uri) = TargetFrom o uri @@ -720,7 +750,7 @@ handleCommandLine 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) @@ -729,9 +759,10 @@ handleCommandLine 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 +863,22 @@ handleCommandLine 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 + 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 + handleCommand ts cargs = mapM_ handleTargetCommand ts where @@ -841,7 +886,7 @@ handleCommandLine 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 +899,8 @@ handleCommandLine 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 _ : _) @@ -1000,7 +1046,7 @@ handleCommandLine 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' -- 2.11.4.GIT