diohsc 0.1.4 → 0.1.5
raw patch · 16 files changed
+150/−99 lines, 16 filesdep +network-simple
Dependencies added: network-simple
Files
- ANSIColour.hs +18/−11
- CHANGELOG.md +8/−0
- ClientCert.hs +10/−5
- Command.hs +12/−2
- GeminiProtocol.hs +5/−16
- Identity.hs +9/−9
- Makefile +1/−1
- Opts.hs +2/−0
- Pager.hs +2/−2
- Prompt.hs +9/−5
- TextGemini.hs +21/−21
- URI.hs +5/−4
- Version.hs +1/−1
- diohsc.1.md +7/−0
- diohsc.cabal +2/−1
- diohsc.hs +38/−21
ANSIColour.hs view
@@ -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)
CHANGELOG.md view
@@ -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
ClientCert.hs view
@@ -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
Command.hs view
@@ -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,>N), and session marks ('N)." , "see also: {log}" ]
GeminiProtocol.hs view
@@ -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
Identity.hs view
@@ -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]
Makefile view
@@ -1,4 +1,4 @@-VERSION=0.1.4+VERSION=0.1.5 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa
Opts.hs view
@@ -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)"
Pager.hs view
@@ -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
Prompt.hs view
@@ -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 }
TextGemini.hs view
@@ -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 }
URI.hs view
@@ -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
Version.hs view
@@ -16,4 +16,4 @@ programName = "diohsc" version :: String-version = "0.1.4"+version = "0.1.5"
diohsc.1.md view
@@ -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.
diohsc.cabal view
@@ -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,
diohsc.hs view
@@ -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 ->