diohsc 0.1.9 → 0.1.10
raw patch · 9 files changed
+182/−70 lines, 9 files
Files
- CHANGELOG.md +7/−0
- Command.hs +23/−7
- CommandLine.hs +12/−4
- GeminiProtocol.hs +1/−1
- Makefile +1/−1
- RunExternal.hs +1/−1
- Version.hs +1/−1
- diohsc.cabal +1/−1
- diohsc.hs +135/−54
CHANGELOG.md view
@@ -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 '!'
Command.hs view
@@ -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}" ]
CommandLine.hs view
@@ -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 ]
GeminiProtocol.hs view
@@ -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.
Makefile view
@@ -1,4 +1,4 @@-VERSION=0.1.9+VERSION=0.1.10 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa
RunExternal.hs view
@@ -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
Version.hs view
@@ -16,4 +16,4 @@ programName = "diohsc" version :: String-version = "0.1.9"+version = "0.1.10"
diohsc.cabal view
@@ -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
diohsc.hs view
@@ -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 }