diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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") diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -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" -> diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -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 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.11 +VERSION=0.1.12 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa diff --git a/Mundanities.hs b/Mundanities.hs --- a/Mundanities.hs +++ b/Mundanities.hs @@ -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 () diff --git a/Pager.hs b/Pager.hs --- a/Pager.hs +++ b/Pager.hs @@ -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 diff --git a/ServiceCerts.hs b/ServiceCerts.hs --- a/ServiceCerts.hs +++ b/ServiceCerts.hs @@ -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) diff --git a/TextGemini.hs b/TextGemini.hs --- a/TextGemini.hs +++ b/TextGemini.hs @@ -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) diff --git a/URI.hs b/URI.hs --- a/URI.hs +++ b/URI.hs @@ -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 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.11" +version = "0.1.12" 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.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, diff --git a/diohsc.hs b/diohsc.hs --- a/diohsc.hs +++ b/diohsc.hs @@ -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