diohsc 0.1.11 → 0.1.12
raw patch · 12 files changed
+140/−80 lines, 12 filesdep ~memorydep ~tls
Dependency ranges changed: memory, tls
Files
- CHANGELOG.md +6/−0
- Command.hs +5/−3
- GeminiProtocol.hs +47/−17
- Makefile +1/−1
- Mundanities.hs +8/−0
- Pager.hs +18/−17
- ServiceCerts.hs +16/−1
- TextGemini.hs +3/−4
- URI.hs +7/−2
- Version.hs +1/−1
- diohsc.cabal +3/−3
- diohsc.hs +25/−31
CHANGELOG.md view
@@ -2,6 +2,12 @@ This file covers only non-trivial user-visible changes; see the git log for full gory details. +# 0.1.12+* SECURITY FIX: Restrict TOFU-trust of a certificate to a single service. Previous behaviour could be exploited for a MitM attack, by convincing the user to accept a certificate for one host, then using it in a MitM for another host.+* Immediately run commands entered in pager mode+* Wrap title lines+* Tell user if a certificate has been temporarily trusted before+ # 0.1.11 * Drop targets of "log" from queues * Preserve history when using relative links (e.g. "2?foo")
Command.hs view
@@ -235,9 +235,11 @@ , " 1-9 : advance by the specified number of lines" , " c : continue to end" , " q, enter : quit pager"- , " :, > : enter a diohsc command to be executed after quitting the pager"- , " example: \":3a\" adds link 3 to the uri queue"- , "There is no way to go back."+ , " :, > : enter a diohsc command to be executed immediately. Examples:"+ , " \":3v\" views link 3 (e.g. an image)"+ , " \":5a\" adds link 5 to the uri queue"+ , ""+ , "There is no way to go backwards; use your terminal's scrollback facility." , "The {||} command can be used to invoke an alternative pager." , "See also: {default_action}" ] "proxies" ->
GeminiProtocol.hs view
@@ -8,6 +8,7 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -62,6 +63,7 @@ import ServiceCerts import URI+import Util import Data.Digest.DrunkenBishop @@ -109,6 +111,7 @@ data RequestContext = RequestContext InteractionCallbacks CertificateStore+ (MVar (Set.Set (Fingerprint, ServiceID))) (MVar (Set.Set Fingerprint)) (MVar (Set.Set Fingerprint)) (MVar (Set.Set String))@@ -128,8 +131,9 @@ certStore <- fromMaybe (makeCertificateStore []) <$> readCertificateStore certPath mTrusted <- newMVar Set.empty mIgnoredCertErrors <- newMVar Set.empty+ mWarnedCA <- newMVar Set.empty mIgnoredCCertWarnings <- newMVar Set.empty- RequestContext callbacks certStore mTrusted mIgnoredCertErrors mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy <$> newClientSessions+ RequestContext callbacks certStore mTrusted mIgnoredCertErrors mWarnedCA mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy <$> newClientSessions requestOfProxiesAndUri :: M.Map String Host -> URI -> Maybe Request requestOfProxiesAndUri proxies uri =@@ -150,7 +154,7 @@ hostname <- decodeIPv6 <$> uriRegName uri let port = fromMaybe defaultGeminiPort $ uriPort uri return $ Host hostname port- return . NetworkRequest host $ uri+ return . NetworkRequest host . stripUriForGemini $ uri where decodeIPv6 :: String -> String decodeIPv6 ('[':rest) | last rest == ']', addr <- init rest, isIPv6address addr = addr@@ -171,7 +175,7 @@ -> Bool -- ^whether to display extra information about connection -> Request -> IO (Either SomeException (Response, IO ())) makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ promptYN)- certStore mTrusted mIgnoredCertErrors mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy clientSessions) mIdent bound verboseConnection (NetworkRequest (Host hostname port) uri) =+ certStore mTrusted mIgnoredCertErrors mWarnedCA mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy clientSessions) mIdent bound verboseConnection (NetworkRequest (Host hostname port) uri) = let requestBytes = TS.encodeUtf8 . TS.pack $ show uri ++ "\r\n" uriLength = BS.length requestBytes - 2 ccfp = clientCertFingerprint . identityCert <$> mIdent@@ -294,7 +298,13 @@ in verify signedCerts doTofu errors = if not . any isTrustError $ errors- then return errors+ then do+ (tailFingerprint `Set.member`) <$> readMVar mWarnedCA >>! do+ displayInfo [ "Accepting valid certificate chain with trusted root CA: " <>+ showIssuerDN signedCerts ]+ when verboseConnection . displayInfo $ showChain signedCerts+ modifyMVar_ mWarnedCA (return . Set.insert tailFingerprint)+ return errors else do trust <- checkTrust $ filter isTrustableError errors return $ if trust@@ -303,10 +313,10 @@ checkTrust :: [FailedReason] -> IO Bool checkTrust errors = do- trusted <- (tailFingerprint `Set.member`) <$> readMVar mTrusted+ trusted <- ((tailFingerprint, service) `Set.member`) <$> readMVar mTrusted if trusted then return True else do trust <- checkTrust' errors- when trust $ modifyMVar_ mTrusted (return . Set.insert tailFingerprint)+ when trust $ modifyMVar_ mTrusted (return . Set.insert (tailFingerprint, service)) return trust checkTrust' :: [FailedReason] -> IO Bool checkTrust' _ | Just sigFail <- chainSigsFail = do@@ -315,10 +325,11 @@ checkTrust' errors = do let certs = map getCertificate signedCerts tailCert = head certs+ tailHex = "SHA256:" <> fingerprintHex tailFingerprint serviceString = serviceToString service warnErrors = unless (null errors) . displayWarning $ [ "WARNING: tail certificate has verification errors: " <> show errors ]- known <- loadServiceCert serviceCertsPath service `catch` ((>> return Nothing) . printIOErr)+ known <- loadServiceCert serviceCertsPath service if known == Just tailSigned then do displayInfo [ "Accepting previously trusted certificate " ++ take 8 (fingerprintHex tailFingerprint) ++ "; expires " ++ printExpiry tailCert ++ "." ] when verboseConnection . displayInfo $ fingerprintPicture tailFingerprint@@ -329,10 +340,16 @@ p <- promptYN df pprompt if p then return (True,True) else (False,) <$> promptYN df tprompt+ tempTimes <- loadTempServiceInfo serviceCertsPath service >>= \case+ Just (n,tempHex) | tempHex == tailHex -> pure n+ _ -> pure 0 (saveCert,trust) <- case known of Nothing -> do displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ] warnErrors+ when (tempTimes > 0) $ displayInfo [+ "This certificate has been temporarily trusted " <>+ show tempTimes <> " times." ] let prompt = "provided certificate (" ++ take 8 (fingerprintHex tailFingerprint) ++ ")?" promptTrust True ("Permanently trust " ++ prompt)@@ -343,7 +360,8 @@ expired = currentTime > (snd . certValidity) trustedCert samePubKey = certPubKey trustedCert == certPubKey tailCert oldFingerprint = fingerprint trustedSignedCert- oldInfo = [ "Fingerprint of old certificate: " ++ fingerprintHex oldFingerprint ]+ oldHex = "SHA256:" <> fingerprintHex oldFingerprint+ oldInfo = [ "Fingerprint of old certificate: " <> oldHex ] ++ fingerprintPicture oldFingerprint ++ [ "Old certificate " ++ (if expired then "expired" else "expires") ++ ": " ++ printExpiry trustedCert ]@@ -362,6 +380,9 @@ else displayWarning $ ("CAUTION: A certificate with a different public key for " ++ serviceString ++ " was previously explicitly trusted and has not expired!") : oldInfo+ when (tempTimes > 0) $ displayInfo [+ "The new certificate has been temporarily trusted " <>+ show tempTimes <> " times." ] warnErrors promptTrust (signedByOld || expired || samePubKey) ("Permanently trust new certificate" <>@@ -372,26 +393,35 @@ else " (but keep old certificate)") <> "?") when (saveCert && not readOnly) $ saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr- return trust+ when (trust && not saveCert && not readOnly) $+ saveTempServiceInfo serviceCertsPath service (tempTimes + 1, tailHex) `catch` printIOErr+ pure trust printExpiry :: Certificate -> String printExpiry = timePrint ISO8601_Date . snd . certValidity + showCN :: DistinguishedName -> String+ showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . getCharacterStringRawData) . getDnElement DnCommonName++ showIssuerDN :: [SignedCertificate] -> String+ showIssuerDN signed = case lastMay signed of+ Nothing -> ""+ Just headSigned -> showCN . certIssuerDN $ getCertificate headSigned+ showChain :: [SignedCertificate] -> [String] showChain [] = [""] showChain signed = let sigChain = reverse signed- certs = map getCertificate sigChain- showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . getCharacterStringRawData) . getDnElement DnCommonName+ certs = getCertificate <$> sigChain issuerCN = showCN . certIssuerDN $ head certs- subjectCNs = map (showCN . certSubjectDN) certs- hexes = map (fingerprintHex . fingerprint) sigChain- pics = map (fingerprintPicture . fingerprint) sigChain- expStrs = map (("Expires " ++) . printExpiry) certs- picsWithInfo = map (map $ centre 23) $ zipWith (++) pics $ transpose [subjectCNs, expStrs]+ subjectCNs = showCN . certSubjectDN <$> certs+ hexes = ("SHA256:" <>) . fingerprintHex . fingerprint <$> sigChain+ pics = fingerprintPicture . fingerprint <$> sigChain+ expStrs = ("Expires " ++) . printExpiry <$> certs+ picsWithInfo = ((centre 23 <$>) <$>) $ zipWith (++) pics $ transpose [subjectCNs, expStrs] centre n s = take n $ replicate ((n - length s) `div` 2) ' ' ++ s ++ repeat ' ' tweenCol = replicate 6 " " ++ [" >>> "] ++ replicate 6 " "- sideBySide = map concat . transpose+ sideBySide = (concat <$>) . transpose in [ "Certificate chain: " ++ intercalate " >>> " (issuerCN:subjectCNs) ] ++ (sideBySide . intersperse tweenCol $ picsWithInfo) ++ zipWith (++) ("": repeat ">>> ") hexes
Makefile view
@@ -1,4 +1,4 @@-VERSION=0.1.11+VERSION=0.1.12 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa
Mundanities.hs view
@@ -15,6 +15,7 @@ import Control.Applicative (Alternative, empty) import Control.Monad.Catch (MonadMask, handle) import Control.Monad.IO.Class (MonadIO, liftIO)+import Safe import System.Directory import System.FilePath @@ -49,6 +50,13 @@ readFileLines :: FilePath -> IO [T.Text] readFileLines path = ignoreIOErr $ map T.strip . T.lines . T.decodeUtf8 . BL.fromStrict <$> BS.readFile path++writeReadFile :: (Show a) => FilePath -> a -> IO ()+writeReadFile path = BL.writeFile path . T.encodeUtf8 . T.pack . show++readReadFile :: (Read a) => FilePath -> IO (Maybe a)+readReadFile path = ignoreIOErrAlt $+ readMay . T.unpack . T.decodeUtf8 . BL.fromStrict <$> BS.readFile path -- delete all but last n lines of file truncateToEnd :: Int -> FilePath -> IO ()
Pager.hs view
@@ -8,30 +8,29 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Pager where -import Control.Monad (join, when)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Writer (WriterT, execWriterT, tell)-import Data.Char (toLower)-import Data.Maybe (fromMaybe, isJust, maybeToList)-import Safe (readMay)-import System.IO (hFlush, stdout)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Char (toLower)+import Data.Maybe (fromMaybe, isJust)+import Safe (readMay)+import System.IO (hFlush, stdout) -import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.IO as T+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T import ANSIColour import Prompt -printLinesPaged :: Int -> Int -> Int -> [T.Text] -> IO [String]-printLinesPaged wrapCol termWidth perpage- | perpage <= 0 = \_ -> return []- | otherwise = execWriterT . printLinesPaged' perpage Nothing+printLinesPaged :: MonadIO m => Int -> Int -> Int -> (String -> m ()) -> [T.Text] -> m ()+printLinesPaged wrapCol termWidth perpage doCmd+ | perpage <= 0 = \_ -> pure ()+ | otherwise = printLinesPaged' perpage Nothing where- printLinesPaged' :: Int -> Maybe Int -> [T.Text] -> WriterT [String] IO () printLinesPaged' n mcol [] | n > 0 = when (isJust mcol) . liftIO $ putStrLn "" printLinesPaged' n mcol (l:ls) | n > 0 = do@@ -52,7 +51,9 @@ Just c' | Just m <- readMay (c':""), m > 0 -> printLinesPaged' m Nothing ls Just 'c' -> printLinesPaged' 9999 Nothing ls Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing ls- Just c' | c' == ':' || c' == '>' ->- liftIO (promptLine "Queue command: ") >>= tell . maybeToList . join >>- printLinesPaged' 0 Nothing ls+ Just c' | c' == ':' || c' == '>' -> do+ liftIO (promptLine "> ") >>= \case+ Just (Just cmd) -> doCmd cmd+ _ -> pure ()+ printLinesPaged' 0 Nothing ls _ -> printLinesPaged' perpage Nothing ls
ServiceCerts.hs view
@@ -16,7 +16,7 @@ import Data.PEM import Data.X509 import Data.X509.Validation-import System.Directory (doesFileExist, renamePath)+import System.Directory (doesFileExist, removeFile, renamePath) import System.FilePath import qualified Data.ByteString as BS@@ -45,10 +45,25 @@ _ -> Nothing _ -> Nothing) . pemParseBS <$> BS.readFile filepath +-- |'#' is illegal in a hostname, so this avoids clashes+tempSuffix :: String+tempSuffix = "#temp"+ saveServiceCert :: FilePath -> ServiceID -> SignedCertificate -> IO () saveServiceCert path service cert = let filepath = path </> serviceToString service in isSubPath path filepath >>? do doesFileExist filepath >>? renamePath filepath (filepath ++ ".bk")+ ignoreIOErr . removeFile $ filepath <> tempSuffix BS.writeFile filepath . pemWriteBS . PEM "CERTIFICATE" [] . encodeSignedObject $ cert++type TempServiceInfo = (Int,String)++loadTempServiceInfo :: FilePath -> ServiceID -> IO (Maybe TempServiceInfo)+loadTempServiceInfo path service =+ readReadFile $ path </> serviceToString service <> tempSuffix++saveTempServiceInfo :: FilePath -> ServiceID -> TempServiceInfo -> IO ()+saveTempServiceInfo path service =+ writeReadFile (path </> serviceToString service <> tempSuffix)
TextGemini.hs view
@@ -78,12 +78,11 @@ printLine (PreformattedLine alt line) | preOpt == PreOptAlt && not (T.null alt) = [] | otherwise = (:[]) $ applyIf ansi ((resetCode <>) . withBoldStr) "` " <> line- printLine (HeadingLine level line) = (:[])- . ((T.take (fromIntegral level) (T.repeat '#') <> " ") <>)+ printLine (HeadingLine level line) =+ wrapWith (T.take (fromIntegral level) (T.repeat '#') <> " ") False . applyIf ansi ( applyIf (level /= 2) withUnderlineStr- . applyIf (level < 3) withBoldStr )- $ line+ . applyIf (level < 3) withBoldStr ) $ line printLine (ItemLine line) = wrapWith "* " False line printLine (QuoteLine line) = wrapWith "> " True line printLine (ErrorLine line) = (:[]) $ applyIf ansi (withColourStr Red)
URI.hs view
@@ -27,6 +27,7 @@ , relativeTo , setQuery , stripUri+ , stripUriForGemini , unescapeUriString , uriFragment , uriPath@@ -84,7 +85,6 @@ normaliseUri uri = URI $ uri { NU.uriPath = (\p -> if null p then "/" else p) . NU.normalizePathSegments . NU.normalizeEscape $ NU.uriPath uri- , NU.uriFragment = "" , NU.uriScheme = if null $ NU.uriScheme uri then defaultScheme else toLower <$> NU.uriScheme uri , NU.uriAuthority = (\auth -> auth@@ -92,10 +92,15 @@ if NU.uriPort auth == ':' : show defaultPort then "" else NU.uriPort auth , NU.uriRegName = toLower <$> NU.uriRegName auth- , NU.uriUserInfo = "" }) <$> NU.uriAuthority uri , NU.uriQuery = NU.normalizeEscape $ NU.uriQuery uri+ }++stripUriForGemini :: URI -> URI+stripUriForGemini (URI uri) = URI $ uri+ { NU.uriAuthority = (\auth -> auth {NU.uriUserInfo = ""}) <$> NU.uriAuthority uri+ , NU.uriFragment = "" } parseAbsoluteUri :: String -> Maybe URI
Version.hs view
@@ -16,4 +16,4 @@ programName = "diohsc" version :: String-version = "0.1.11"+version = "0.1.12"
diohsc.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: diohsc-version: 0.1.11+version: 0.1.12 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org@@ -95,7 +95,7 @@ hourglass >=0.2.12 && <0.3, mime >=0.4.0.2 && <0.5, mtl >=2.1.3.1 && <2.4,- memory >=0.14 && <0.18,+ memory >=0.14 && <0.19, network >=2.4.2.3 && <3.2, network-simple >=0.4.3 && <0.5, network-uri >=2.6.3.0 && <2.8,@@ -108,7 +108,7 @@ temporary ==1.3.*, terminal-size >=0.3.2.1 && <0.4, text >=1.1.0.0 && <2.1,- tls >=1.5.4 && <1.6,+ tls >=1.5.4 && <1.7, transformers >=0.3.0.0 && <0.7, x509 >=1.7.5 && <1.8, x509-store >=1.6.7 && <1.7,
diohsc.hs view
@@ -53,9 +53,9 @@ import qualified System.Console.Haskeline as HL import qualified System.Console.Terminal.Size as Size -import ANSIColour import ActiveIdentities import Alias+import ANSIColour import qualified BStack import ClientCert (KeyType (..)) import Command@@ -70,8 +70,8 @@ import Prompt hiding (promptYN) import qualified Prompt import Request-import RunExternal hiding (runRestrictedIO) import qualified RunExternal+import RunExternal hiding (runRestrictedIO) import Slurp import TextGemini import URI@@ -176,7 +176,6 @@ , clientMarks :: Marks , clientSessionMarks :: M.Map Int HistoryItem , clientAliases :: Aliases- , clientQueuedCommands :: [String] , clientConfig :: ClientConfig } @@ -185,7 +184,7 @@ type CommandAction = HistoryItem -> ClientM () emptyClientState :: ClientState-emptyClientState = ClientState Nothing Nothing BStack.empty S.empty M.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 :: String -> Maybe Int -> [QueueItem] -> ClientM () enqueue _ _ [] = return ()@@ -208,13 +207,6 @@ qnames <- gets $ M.keys . clientQueues forM_ qnames (`dropUriFromQueue` uri) -popQueuedCommand :: ClientM (Maybe String)-popQueuedCommand = do- cmd <- gets $ headMay . clientQueuedCommands- when (isJust cmd) . modify $ \s ->- s { clientQueuedCommands = drop 1 $ clientQueuedCommands s }- return cmd- modifyCConf :: (ClientConfig -> ClientConfig) -> ClientM () modifyCConf f = modify $ \s -> s { clientConfig = f $ clientConfig s } @@ -327,12 +319,7 @@ lineClient' :: HL.InputT ClientM () lineClient' = do- cmd <- runMaybeT $ msum- [ do- c <- MaybeT $ lift popQueuedCommand- printInfoOpt ansi $ "> " <> c- return $ Just c- , MaybeT $ lift getPrompt >>= promptLineInputT ]+ cmd <- lift getPrompt >>= promptLineInputT lift addToQueuesFromFiles quit <- case cmd of Nothing -> if interactive@@ -422,7 +409,7 @@ handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of Left err -> printErrOpt ansi err >> return False Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True- Right cline -> handleCommandLine cOpts s cline >> return False+ Right cline -> handleCommandLine cOpts s False cline >> return False where catchInterrupts = HL.handleInterrupt (printErrOpt ansi "Interrupted." >> return False) . HL.withInterrupt . lift backupHandler :: SomeException -> HL.InputT ClientM Bool@@ -445,11 +432,12 @@ targetQueueItem (TargetHistory item) = QueueHistory item targetQueueItem i = QueueURI Nothing $ targetUri i -handleCommandLine :: ClientOptions -> ClientState -> CommandLine -> ClientM ()+handleCommandLine :: ClientOptions -> ClientState -> Bool -> CommandLine -> ClientM () handleCommandLine cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)- cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases _+ cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases (ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection))+ blockGo = \(CommandLine mt mcas) -> case mcas of Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases -> let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args@@ -719,11 +707,11 @@ doPage :: [T.Text] -> ClientM () doPage ls | interactive = do- (height,width) <- liftIO getTermSize- let pageWidth = min maxWrapWidth (width - 4)- let perPage = height - min 3 (height `div` 4)- queued <- liftIO $ printLinesPaged pageWidth width perPage ls- modify $ \s -> s { clientQueuedCommands = clientQueuedCommands s ++ queued }+ (height,width) <- liftIO getTermSize+ let pageWidth = min maxWrapWidth (width - 4)+ perPage = height - min 3 (height `div` 4)+ doCmd str = get >>= \s -> doSubCommand s True str+ printLinesPaged pageWidth width perPage doCmd ls | otherwise = liftIO $ mapM_ T.putStrLn ls parseQueueSpec :: [CommandArg] -> Maybe (String, Maybe Int)@@ -1046,9 +1034,8 @@ actionOfCommand ("||", args) = Just $ pipeRendered ansi args actionOfCommand ("||-", args) = Just $ pipeRendered False args actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData- actionOfCommand ("at", CommandArg _ str : _) = Just $ \item -> void . runMaybeT $ do- cl <- either ((>>mzero) . printErr) return $ parseCommandLine str- lift $ handleCommandLine cOpts (cState { clientCurrent = Just item }) cl+ actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->+ doSubCommand (cState { clientCurrent = Just item }) blockGo str actionOfCommand _ = Nothing pipeRendered :: Bool -> [CommandArg] -> CommandAction@@ -1063,6 +1050,11 @@ (CommandArg _ cmd : _) -> return cmd lift . doRestricted . pipeToShellLazily cmd (historyEnv item) . T.encodeUtf8 $ T.unlines ls + doSubCommand :: ClientState -> Bool -> String -> ClientM ()+ doSubCommand s block str = void . runMaybeT $ do+ cl <- either ((>>mzero) . printErr) return $ parseCommandLine str+ lift $ handleCommandLine cOpts s block cl+ setCurr :: HistoryItem -> ClientM () setCurr i = let isJump = isNothing $ curr >>= pathItemByUri i . historyUri@@ -1075,22 +1067,22 @@ maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction goHistory :: HistoryItem -> ClientM ()+ goHistory _ | blockGo = printErr "Can't go anywhere now." goHistory item = do dropUriFromQueues uri showUri uri- doDefault item setCurr item+ doDefault item where uri = historyUri item goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()+ goUri _ _ _ | blockGo = printErr "Can't go anywhere now." goUri forceRequest origin uri = do 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- 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 }@@ -1100,6 +1092,8 @@ glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l } item' = item { historyParent = glueOrigin <$> origin } setCurr item'+ doDefault item+ liftIO $ slurpItem item doRequestUri :: URI -> CommandAction -> ClientM () doRequestUri uri0 action = doRequestUri' 0 uri0