diff --git a/ANSIColour.hs b/ANSIColour.hs --- a/ANSIColour.hs +++ b/ANSIColour.hs @@ -17,9 +17,11 @@ , resetCode , withColour , withBold + , withReverse , withUnderline , withColourStr , withBoldStr + , withReverseStr , withUnderlineStr , stripCSI , visibleLength @@ -41,10 +43,11 @@ | BoldBlue | BoldMagenta | BoldCyan | BoldWhite deriving (Eq,Ord,Show,Read) -resetCode,boldCode,underlineCode :: MetaString a => a +resetCode,boldCode,reverseCode,underlineCode :: MetaString a => a resetCode = "\ESC[0m" boldCode = "\ESC[1m" underlineCode = "\ESC[4m" +reverseCode = "\ESC[7m" colourCode :: MetaString a => Colour -> a colourCode c = (if isBold c then boldCode else "") <> "\ESC[3" <> fromString (colNum c) <> "m" where @@ -70,19 +73,23 @@ thenReset :: IO () -> IO a -> IO a thenReset = (`bracket_` T.putStr resetCode) +withCode :: T.Text -> IO a -> IO a +withCode c = thenReset $ T.putStr c withColour :: Colour -> IO a -> IO a -withColour c = thenReset $ T.putStr (colourCode c) -withBold :: IO a -> IO a -withBold = thenReset $ T.putStr boldCode -withUnderline :: IO a -> IO a -withUnderline = thenReset $ T.putStr underlineCode +withColour c = withCode $ colourCode c +withBold, withReverse, withUnderline :: IO a -> IO a +withBold = withCode boldCode +withReverse = withCode reverseCode +withUnderline = withCode underlineCode +withCodeStr :: MetaString a => a -> a -> a +withCodeStr c s = c <> s <> resetCode withColourStr :: MetaString a => Colour -> a -> a -withColourStr c s = colourCode c <> s <> resetCode -withBoldStr :: MetaString a => a -> a -withBoldStr s = boldCode <> s <> resetCode -withUnderlineStr :: MetaString a => a -> a -withUnderlineStr s = underlineCode <> s <> resetCode +withColourStr c = withCodeStr $ colourCode c +withBoldStr, withReverseStr, withUnderlineStr :: MetaString a => a -> a +withBoldStr = withCodeStr boldCode +withReverseStr = withCodeStr reverseCode +withUnderlineStr = withCodeStr underlineCode -- |"applyIf cond f" is shorthand for "if cond then f else id" applyIf :: Bool -> (a -> a) -> (a -> a) diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ This file covers only non-trivial user-visible changes; see the git log for full gory details. +## 0.1.5 +* Align and wrap link lines; add option to print description first +* Use reverse video in prompt for added visibility (thanks Ben) +* Try all addresses when making connections (thanks rwv) +* Improve behaviour in non-interactive mode; add --batch to enable it +* Fix X.509 version and use dummy notAfter in generated client certificates +* Fix bugs in wrapping and relative link display + ## 0.1.4 * Indicate links to cached history items * Retry with full handshake if session resume fails diff --git a/ClientCert.hs b/ClientCert.hs --- a/ClientCert.hs +++ b/ClientCert.hs @@ -77,8 +77,13 @@ #endif saveClientCert _ _ _ = putStrLn "! Error: can't save key of this type" --- |generate 2048bit RSA key with (-1y,+50y) validity --- FIXME: these choices fingerprint the client +-- RFC5280: To indicate that a certificate has no well-defined expiration +-- date, the notAfter SHOULD be assigned the GeneralizedTime value of +-- 99991231235959Z. +notAfterMax :: DateTime +notAfterMax = DateTime (Date 9999 December 31) (TimeOfDay 23 59 59 0) + +-- |generate 2048bit RSA key with maximum validity generateSelfSigned :: String -> IO ClientCert generateSelfSigned cn = do (pubKey, secKey) <- generate 256 65537 @@ -86,10 +91,10 @@ currentTime <- timeConvert <$> timeCurrent let dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)] sigAlg = SignatureALG HashSHA256 PubKeyALG_RSA - to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 50, periodMonths = 0, periodDays = 0} - from = timeConvert . dateAddPeriod currentTime $ Period {periodYears = -1, periodMonths = 0, periodDays = 0} + to = timeConvert notAfterMax + from = currentTime cert = Certificate - { certVersion = 3 + { certVersion = 2 , certSerial = 0 , certSignatureAlg = sigAlg , certIssuerDN = dn diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -129,7 +129,7 @@ topics :: [String] topics = ["targets", "queue", "pager", "trust", "configuration" , "default_action", "proxies", "geminators", "render_filter" - , "pre_display", "log_length", "max_wrap_width", "no_confirm" + , "pre_display", "link_desc_first", "log_length", "max_wrap_width", "no_confirm" , "verbose_connection", "copying", "topics"] helpOn :: String -> [String] @@ -308,6 +308,9 @@ [ "{set} {pre_display} pre: suppress alt text of preformatted blocks" , "{set} {pre_display} alt: display only alt text of preformatted blocks" , "{set} {pre_display} both: display alt text and contents of preformatted blocks" ] + "link_desc_first" -> + [ "{set} {link_desc_first} true: show link description before uri" + , "{set} {link_desc_first} false: show uri before link description" ] "log_length" -> [ "{set} {log_length} N: set number of items to store in log" , "{set} {log_length} 0: clear log and disable logging" @@ -337,10 +340,17 @@ "repeat" -> ["TARGET repeat: request target"] "mark" -> [ "TARGET {mark} MARK: mark target, which can subsequently be specified as 'MARK." + , "{mark}: list marks." , "Marks are saved in {~/marks}. To delete a mark, remove the corresponding file." , "" + , "The mark '' is a special \"jump back\" mark which is automatically set when" + , "navigating to a new uri without following a link." + , "" , "Marks '0 to '9 are special per-session marks:" - , "they are not saved, and they are listed in the output of \"inventory\"" ] + , "they are not saved, and they are listed in the output of \"inventory\"." + , "" + , "The marks '' and '0-'9 refer to targets with their full history;" + , "they and their ancestors can be manipulated without causing network requests." ] "inventory" -> [ "{inventory}: show current queue (~N), path (N), and session marks ('N)." , "see also: {log}" ] diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -28,11 +28,8 @@ import Data.X509.CertificateStore import Data.X509.Validation hiding (Fingerprint (..), getFingerprint) -import Network.Socket (AddrInfo (..), Socket, - SocketOption (..), SocketType (..), - close, connect, defaultHints, - getAddrInfo, setSocketOption, - socket) +import Network.Simple.TCP (closeSock, connectSock) +import Network.Socket (Socket) import Network.TLS as TLS import Network.TLS.Extra.Cipher import Safe @@ -222,7 +219,7 @@ unless (BS.null r) $ writeBSChan chan r >> recvAllLazily recvThread <- forkFinally recvAllLazily $ \_ -> -- |XXX: note that writeBSChan can't block when writing BS.empty - writeBSChan chan BS.empty >> bye context >> close sock + writeBSChan chan BS.empty >> bye context >> closeSock sock lazyResp <- parseResponse . BL.fromChunks . takeWhile (not . BS.null) <$> getBSChanContents chan return $ Right (lazyResp, killThread recvThread) where @@ -230,15 +227,7 @@ handleAll = return . Left openSocket :: IO Socket - openSocket = do - let hints = defaultHints { addrSocketType = Stream } - addr:_ <- getAddrInfo (Just hints) (Just hostname) (Just $ show port) - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - ignoreIOErr $ - -- set SO_KEEPALIVE so we detect when a stream connection goes down: - setSocketOption sock KeepAlive 1 - connect sock $ addrAddress addr - return sock + openSocket = fst <$> connectSock hostname (show port) checkServerCert store cache service chain@(CertificateChain signedCerts) = do errors <- doTofu =<< validate Data.X509.HashSHA256 defaultHooks @@ -320,7 +309,7 @@ warnErrors let prompt = "provided certificate (" ++ take 8 (fingerprintHex tailFingerprint) ++ ")?" - promptTrust (null errors) ("Permamently trust " ++ prompt) + promptTrust (null errors) ("Permanently trust " ++ prompt) ("Temporarily trust " ++ prompt) Just trustedSignedCert -> do currentTime <- timeConvert <$> timeCurrent diff --git a/Identity.hs b/Identity.hs --- a/Identity.hs +++ b/Identity.hs @@ -12,11 +12,11 @@ module Identity where -import Control.Monad (guard, msum) +import Control.Monad (guard, msum, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Safe import System.Directory (listDirectory) @@ -46,19 +46,18 @@ loadIdentity idsPath idName = (Identity idName <$>) <$> loadClientCert idsPath idName getIdentity :: Bool -> Bool -> FilePath -> String -> IO (Maybe Identity) -getIdentity noConfirm _ _ "" = runMaybeT $ do - (guard =<<) $ lift . promptYN (not noConfirm) True $ "Create and use new temporary anonymous identity?" - Identity "" <$> liftIO (generateSelfSigned "") -getIdentity _ ansi idsPath idName' = runMaybeT $ do +getIdentity _ _ _ "" = runMaybeT $ Identity "" <$> liftIO (generateSelfSigned "") +getIdentity interactive ansi idsPath idName' = runMaybeT $ do idName <- MaybeT . return $ normaliseIdName idName' msum [ MaybeT $ loadIdentity idsPath idName , do - lift $ do + when interactive . lift $ do putStrLn "Creating a new long-term identity." putStrLn $ "We will refer to it as " <> showIdentityName ansi idName <> ", but you may also set a \"Common Name\";" putStrLn "this is recorded in the identity certificate, and may be interpreted by the server as a username." putStrLn "The common name may be left blank. Use ^C to cancel identity generation." - clientCert <- liftIO . generateSelfSigned =<< MaybeT (promptLine "Common Name: ") + clientCert <- liftIO . generateSelfSigned . fromMaybe "" =<< + if not interactive then return Nothing else MaybeT (promptLine "Common Name: ") liftIO $ mkdirhier idsPath lift $ saveClientCert idsPath idName clientCert return $ Identity idName clientCert @@ -71,7 +70,8 @@ "or nothing to create and use a temporary anonymous identity,\n\t" ++ "or use ^C to abort." let prompt = applyIf ansi (withColourStr Green) "Identity" <> ": " - idName <- MaybeT $ promptLineWithCompletions prompt =<< listIdentities idsPath + idName <- (fromMaybe "" <$>) . MaybeT $ + promptLineWithCompletions prompt =<< listIdentities idsPath MaybeT $ getIdentity True ansi idsPath idName listIdentities :: FilePath -> IO [String] diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.4 +VERSION=0.1.5 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa diff --git a/Opts.hs b/Opts.hs --- a/Opts.hs +++ b/Opts.hs @@ -19,6 +19,7 @@ data Opt = Restricted | Interactive + | Batch | ScriptFile FilePath | OptCommand String | DataDir FilePath @@ -35,6 +36,7 @@ , Option ['e'] ["command"] (ReqArg OptCommand "COMMAND") "execute command" , Option ['f'] ["file"] (ReqArg ScriptFile "PATH") "execute commands from file (\"-\" for stdin)" , Option ['i'] ["interact"] (NoArg Interactive) "interactive mode (assumed unless -e/-f used)" + , Option ['b'] ["batch"] (NoArg Batch) "non-interactive mode (assumed if -e/-f used)" , Option ['c'] ["colour"] (NoArg Ansi) "use ANSI colour (assumed if stdout is term)" , Option ['C'] ["no-colour"] (NoArg NoAnsi) "do not use ANSI colour" , Option ['g'] ["ghost"] (NoArg Ghost) "write nothing to filesystem (unless commanded)" diff --git a/Pager.hs b/Pager.hs --- a/Pager.hs +++ b/Pager.hs @@ -12,7 +12,7 @@ module Pager where -import Control.Monad (when) +import Control.Monad (join, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Writer (WriterT, execWriterT, tell) import Data.Char (toLower) @@ -56,6 +56,6 @@ Just 'c' -> printLinesPaged' 9999 Nothing rest Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing rest Just c' | c' == ':' || c' == '>' -> - liftIO (promptLine "Queue command: ") >>= tell . maybeToList >> + liftIO (promptLine "Queue command: ") >>= tell . maybeToList . join >> printLinesPaged' 0 Nothing rest _ -> printLinesPaged' perpage Nothing rest diff --git a/Prompt.hs b/Prompt.hs --- a/Prompt.hs +++ b/Prompt.hs @@ -67,20 +67,24 @@ promptPassword :: String -> IO (Maybe String) promptPassword = runInputTDefWithAbortValue Nothing . HL.getPassword (Just '*') . escapePromptCSI -promptLineInputT :: (MonadIO m, MonadMask m) => String -> HL.InputT m (Maybe String) -promptLineInputT = HL.handleInterrupt (return Nothing) . HL.withInterrupt . HL.getInputLine . escapePromptCSI +-- Possible return values: +-- Nothing: interrupted +-- Just Nothing: EOF +-- Just line +promptLineInputT :: (MonadIO m, MonadMask m) => String -> HL.InputT m (Maybe (Maybe String)) +promptLineInputT = HL.handleInterrupt (return Nothing) . HL.withInterrupt . (Just <$>) . HL.getInputLine . escapePromptCSI -promptLine :: String -> IO (Maybe String) +promptLine :: String -> IO (Maybe (Maybe String)) promptLine = HL.runInputT defaultInputSettings . promptLineInputT -promptLineWithCompletions :: String -> [String] -> IO (Maybe String) +promptLineWithCompletions :: String -> [String] -> IO (Maybe (Maybe String)) promptLineWithCompletions prompt completions = HL.runInputT settings $ promptLineInputT prompt where settings = defaultInputSettings { HL.complete = HL.completeWord Nothing " " $ \w -> return . map HL.simpleCompletion $ filter (isPrefixOf w) completions } -promptLineWithHistoryFile :: FilePath -> String -> IO (Maybe String) +promptLineWithHistoryFile :: FilePath -> String -> IO (Maybe (Maybe String)) promptLineWithHistoryFile path = HL.runInputT settings . promptLineInputT where settings = defaultInputSettings { HL.historyFile = Just path } diff --git a/TextGemini.hs b/TextGemini.hs --- a/TextGemini.hs +++ b/TextGemini.hs @@ -57,25 +57,22 @@ showPreOpt PreOptBoth = "both" data GemRenderOpts = GemRenderOpts - { grOptsAnsi :: Bool - , grOptsPre :: PreOpt - , grOptsWrapWidth :: Int + { grOptsAnsi :: Bool + , grOptsPre :: PreOpt + , grOptsWrapWidth :: Int + , grOptsLinkDescFirst :: Bool } deriving (Eq,Ord,Show) printGemDoc :: GemRenderOpts -> (URIRef -> T.Text) -> GeminiDocument -> [T.Text] -printGemDoc (GemRenderOpts ansi preOpt width) +printGemDoc (GemRenderOpts ansi preOpt width linkDescFirst) showUri (GeminiDocument ls) = concatMap printLine ls where printLine (TextLine line) = wrap width line - printLine (LinkLine n link) = (:[]) $ - printGemLinkLine ansi showUri (n+1) link printLine (AltTextLine line) | preOpt == PreOptPre = [] | preOpt == PreOptBoth && T.null line = [] | otherwise = (:[]) $ applyIf ansi withBoldStr "`` " <> line - -- |the spec says preformat toggle lines should not be rendered, but it's the most convenient - -- non-disruptive way to unambiguously indicate which lines are preformatted. printLine PreformatToggleLine = [] printLine (PreformattedLine line) @@ -85,14 +82,24 @@ then applyIf (level /= 2) withUnderlineStr . applyIf (level < 3) withBoldStr $ line else T.take (fromIntegral level) (T.repeat '#') <> " " <> line - printLine (ItemLine line) = wrapWith "* " " " line - printLine (QuoteLine line) = wrapWith "> " "> " line + printLine (ItemLine line) = wrapWith "* " False line + printLine (QuoteLine line) = wrapWith "> " True line printLine (ErrorLine line) = (:[]) $ applyIf ansi (withColourStr Red) "! Formatting error in text/gemini: " <> line + printLine (LinkLine n (Link uri desc)) = + wrapWith (T.pack $ '[' : show (n+1) ++ if n+1 < 10 then "] " else "] ") False + $ (if T.null desc then id + else (if linkDescFirst then id else flip) (\a b -> a <> " " <> b) + $ applyIf ansi (withColourStr Cyan) desc) + (showUri uri) - wrapWith first subsequent line = - zipWith (<>) lineHeaders $ wrap (width - fromIntegral (T.length first)) line - where lineHeaders = map (applyIf ansi withBoldStr) $ first : repeat subsequent + wrapWith :: T.Text -> Bool -> T.Text -> [T.Text] + wrapWith pre all line = + zipWith (<>) lineHeaders $ wrap (width - n) line + where + n = visibleLength pre + lineHeaders = (pre:) . repeat $ + if all then pre else T.replicate (fromIntegral n) " " wrap :: Int -> T.Text -> [T.Text] wrap wrapWidth line = wrap' "" 0 $ T.words line @@ -103,16 +110,9 @@ nw = visibleLength w n' = n + nw + (if T.null l then 0 else 1) in if n' > wrapWidth - then l : wrap' w nw ws + then (if T.null l then id else (l:)) $ wrap' w nw ws else wrap' l' n' ws -printGemLinkLine :: Bool -> (URIRef -> T.Text) -> Int -> Link -> T.Text -printGemLinkLine ansi showUri n (Link uri desc) = - applyIf ansi withBoldStr (T.pack $ '[' : show n ++ "]") - <> " " - <> showUri uri - <> (if T.null desc then "" else - applyIf ansi (withColourStr Cyan) $ " " <> desc) data GeminiParseState = GeminiParseState { numLinks :: Int, preformatted :: Bool } diff --git a/URI.hs b/URI.hs --- a/URI.hs +++ b/URI.hs @@ -124,12 +124,13 @@ setScheme ref | isNothing (NU.uriAuthority ref) = ref | otherwise = ref { NU.uriScheme = NU.uriScheme uri1 } stripSlash ref | '/':path' <- NU.uriPath ref - , not $ null path' - , ref' <- ref { NU.uriPath = path' } - , NU.relativeTo ref' uri2 == uri1 = ref' + , not $ null path' + , ref' <- ref { NU.uriPath = path' } + , NU.relativeTo ref' uri2 == uri1 = ref' | otherwise = ref fixDots ref = case NU.uriPath ref of - "" -> ref { NU.uriPath = "." } + "" | ref' <- ref { NU.uriPath = "." } + , NU.relativeTo ref' uri2 == uri1 -> ref' "../" -> ref { NU.uriPath = ".." } _ -> ref 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.4" +version = "0.1.5" diff --git a/diohsc.1.md b/diohsc.1.md --- a/diohsc.1.md +++ b/diohsc.1.md @@ -41,6 +41,10 @@ : as appropriate. : This is the default mode unless "-e" or "-f" is used. +-b, \-\-batch +: Do not prompt for input. +: This is the default mode if "-e" or "-f" is used. + -c, \-\-colour : Use ANSI escape sequences for formatting. : This is the default if stdout is a terminal. @@ -111,6 +115,9 @@ # BUGS Only ANSI escape sequences are supported. + +Private keys for identities are stored in an ad hoc non-standard format, +making it impossible to share identities between diohsc and other clients. # LICENCE diohsc is free software, released under the terms of the GNU GPL v3 or later. diff --git a/diohsc.cabal b/diohsc.cabal --- a/diohsc.cabal +++ b/diohsc.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: diohsc -version: 0.1.4 +version: 0.1.5 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org @@ -86,6 +86,7 @@ mime >=0.4.0.2 && <0.5, mtl >=2.1.3.1 && <2.3, network >=2.4.2.3 && <3.2, + network-simple >=0.4.3 && <5, network-uri >=2.6.3.0 && <2.8, parsec >=3.1.5 && <3.2, pem >=0.2.4 && <0.3, diff --git a/diohsc.hs b/diohsc.hs --- a/diohsc.hs +++ b/diohsc.hs @@ -147,6 +147,7 @@ , clientConfGeminators :: [(String,(Regex,String))] , clientConfRenderFilter :: Maybe String , clientConfPreOpt :: PreOpt + , clientConfLinkDescFirst :: Bool , clientConfMaxLogLen :: Int , clientConfMaxWrapWidth :: Int , clientConfNoConfirm :: Bool @@ -154,7 +155,7 @@ } defaultClientConfig :: ClientConfig -defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre 1000 80 False False +defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre False 1000 80 False False data QueueItem = QueueItem { queueOrigin :: Maybe HistoryOrigin @@ -222,7 +223,8 @@ argCommands (OptCommand c) = return [c] argCommands _ = return [] optCommands <- concat <$> mapM argCommands opts - let interactive = null optCommands || Interactive `elem` opts + let interactive = Batch `notElem` opts && (null optCommands || Interactive `elem` opts) + let repl = null optCommands let argToUri arg = doesPathExist arg >>= \case True -> Just . ("file://" <>) . escapePathString <$> makeAbsolute arg @@ -276,7 +278,7 @@ , clientLog = cLog, clientVisited = visited} in do endState <- (`execStateT` initState) . HL.runInputT hlSettings $ - lineClient clientOptions initialCommands + lineClient clientOptions initialCommands repl closeLog logH -- |reread file rather than just writing clientLog, in case another instance has also -- been appending to the log. @@ -293,13 +295,13 @@ Size.Window height width <- fromMaybe (Size.Window (2^31) 80) <$> Size.size return (height,width) -lineClient :: ClientOptions -> [String] -> HL.InputT ClientM () +lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM () lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir - , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands = do + , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do (liftIO . readFileLines $ userDataDir "diohscrc") >>= mapM_ (handleLine' . T.unpack) lift addToQueueFromFile mapM_ handleLine' initialCommands - when interactive lineClient' + when repl lineClient' unless ghost $ lift appendQueueToFile where handleLine' :: String -> HL.InputT ClientM Bool @@ -311,14 +313,15 @@ [ do c <- MaybeT $ lift popQueuedCommand printInfoOpt ansi $ "> " <> c - return c + return $ Just c , MaybeT $ lift getPrompt >>= promptLineInputT ] lift addToQueueFromFile quit <- case cmd of Nothing -> if interactive then printErrOpt ansi "Use \"quit\" to quit" >> return False else return True - Just line -> handleLine' line + Just Nothing -> return True + Just (Just line) -> handleLine' line unless quit lineClient' addToQueueFromFile :: ClientM () @@ -371,12 +374,13 @@ in uriStr ++ (if null idStr then "" else colour Green idStr) prompt :: Int -> String - prompt maxPromptWidth - | interactive = (colour BoldCyan "%%% " ++) . (++ bold "> ") . unwords $ catMaybes + prompt maxPromptWidth = + ((applyIf ansi withReverseStr $ colour BoldCyan "%%%") ++) + . (" " ++) . (++ bold "> ") . unwords $ catMaybes [ queueStatus - , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus) . historyUri <$> curr + , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus) + . historyUri <$> curr ] - | otherwise = "" prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool @@ -409,7 +413,7 @@ handleCommandLine cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH) cState@(ClientState curr jumpBack cLog visited queue _ marks sessionMarks aliases _ - (ClientConfig defaultAction proxies geminators renderFilter preOpt maxLogLen maxWrapWidth confNoConfirm verboseConnection)) + (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 -> let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args @@ -743,6 +747,7 @@ printMap id $ second snd <$> geminators putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt + putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst putStrLn $ expand "{log_length}: " <> show maxLogLen putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth putStrLn $ expand "{no_confirm}: " <> show noConfirm @@ -783,6 +788,12 @@ [CommandArg s _] | map toLower s `isPrefixOf` "alt" -> modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt } _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display" + | opt `isPrefixOf` "link_desc_first" = case val of + [CommandArg s _] | map toLower s `isPrefixOf` "true" -> + modifyCConf $ \c -> c { clientConfLinkDescFirst = True } + [CommandArg s _] | map toLower s `isPrefixOf` "false" -> + modifyCConf $ \c -> c { clientConfLinkDescFirst = False } + _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first" | opt `isPrefixOf` "log_length" = case val of [CommandArg s _] | Just n <- readMay s, n >= 0 -> do modifyCConf $ \c -> c { clientConfMaxLogLen = n } @@ -849,8 +860,10 @@ Just (root,(ident,_)) -> endIdentityPrompted root ident Nothing -> void . runMaybeT $ do ident <- MaybeT . liftIO $ case args of - (CommandArg idName _ : _) -> getIdentity noConfirm ansi idsPath idName - [] -> getIdentityRequesting ansi idsPath + (CommandArg idName _ : _) -> getIdentity interactive ansi idsPath idName + [] -> if interactive + then getIdentityRequesting ansi idsPath + else getIdentity interactive ansi idsPath "" lift $ addIdentity req ident handleUriCommand uri ("browse", args) = void . liftIO . runMaybeT $ do cmd <- case args of @@ -871,7 +884,7 @@ repl :: Maybe HistoryOrigin -> URI -> ClientM () repl origin uri = repl' where - repl' = liftIO (promptInput ">> ") >>= \case + repl' = liftIO (join <$> promptInput ">> ") >>= \case Nothing -> return () Just query -> do goUri True origin . setQuery ('?':escapeQuery query) $ uri @@ -890,9 +903,12 @@ actionOfCommand ("links",_) = Just $ \item -> do ais <- gets clientActiveIdentities let cl = childLink =<< historyChild item - linkLine n link = + linkLine n (Link uri desc) = applyIf (cl == Just (n-1)) (bold "* " <>) $ - printGemLinkLine ansi (showUriRefFull ansi ais $ historyUri item) n link + T.pack ('[' : show n ++ "] ") + <> showUriRefFull ansi ais (historyUri item) uri + <> if T.null desc then "" else " " <> + applyIf ansi (withColourStr Cyan) desc doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item actionOfCommand ("mark", CommandArg mark _ : _) | @@ -1007,8 +1023,8 @@ handleResponse :: Response -> ClientM () handleResponse (Input isPass prompt) = do let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]" - prompter = if isPass then promptPassword else promptInput - (liftIO . prompter $ (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case + (liftIO . (join <$>) . promptInput $ + (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case Nothing -> return () Just query -> doRequestUri' redirs . setQuery ('?':escapeQuery query) $ uri @@ -1038,6 +1054,7 @@ _ -> "Server rejects provided identification certificate" ++ (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else "")) ++ if null info then "" else ": " ++ info + guard interactive MaybeT . liftIO $ getIdentityRequesting ansi idsPath lift $ do addIdentity req identity @@ -1146,7 +1163,7 @@ where appendNewline = (`BL.snoc` 10) (Right <$>) . applyFilter . (sanitiseNonCSI <$>) $ case textType of "gemini" -> - let opts = GemRenderOpts ansi' preOpt pageWidth + let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText _ -> T.stripEnd <$> T.lines bodyText mimeType ->