diff --git a/ANSIColour.hs b/ANSIColour.hs --- a/ANSIColour.hs +++ b/ANSIColour.hs @@ -28,7 +28,7 @@ , visibleLength , splitAtVisible , escapePromptCSI - , sanitiseNonCSI + , sanitiseForDisplay , Colour(..) ) where @@ -155,6 +155,9 @@ let post' = T.drop 1 post isCSI = T.take 1 post' == "[" in pre <> (if isCSI then "\ESC" else "\\ESC") <> sanitiseNonCSI post' + +sanitiseForDisplay :: T.Text -> T.Text +sanitiseForDisplay = sanitiseNonCSI . T.filter (\c -> c == '\ESC' || wcwidth c >= 0) -- |append \STX to each CSI sequence, as required in Haskeline prompts. -- See https://github.com/judah/haskeline/wiki/ControlSequencesInPrompt diff --git a/Alias.hs b/Alias.hs --- a/Alias.hs +++ b/Alias.hs @@ -29,7 +29,9 @@ defaultAliases :: Aliases defaultAliases = second aliasOf <$> [ ("back", "<") , ("forward", ">") , ("next", "~") ] - where aliasOf s = let Right cl = parseCommandLine s in Alias s cl + where aliasOf s = case parseCommandLine s of + Right cl -> Alias s cl + Left _ -> error "BUG: Failed to parse command for default alias." lookupAlias :: String -> Aliases -> Maybe Alias lookupAlias s aliases = diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ This file covers only non-trivial user-visible changes; see the git log for full gory details. +# 0.1.13 +* Set CLIENT_CERT and CLIENT_KEY environment variables when invoking external commands +* Improve wrapping of lines with words longer than the screen width + # 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 diff --git a/ClientCert.hs b/ClientCert.hs --- a/ClientCert.hs +++ b/ClientCert.hs @@ -92,7 +92,11 @@ let CertificateChainRaw rawCerts = encodeCertificateChain chain chainPEMs = map (pemWriteBS . PEM "CERTIFICATE" []) rawCerts BS.writeFile certpath $ BS.intercalate "\n" chainPEMs - BS.writeFile keypath . pemWriteBS . PEM "PRIVATE KEY" [] . encodeDER $ key + let header = case key of + -- Use the header string the openssl commandline tool expects: + PrivKeyRSA _ -> "RSA PRIVATE KEY" + _ -> "PRIVATE KEY" + BS.writeFile keypath . pemWriteBS . PEM header [] . encodeDER $ key #ifndef WINDOWS setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600 #endif diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -424,18 +424,29 @@ , "TARGET {browse} COMMAND: run given shell command on uri." , "%s is substituted with the uri" , "if no %s appears, the uri is used as an additional final argument." - , "A literal '%' can be escaped as '%%'." ] + , "A literal '%' can be escaped as '%%'." + , "" + , "If an identity would be used at the target URI (if it had scheme gemini)," + , "the environment variables $CLIENT_CERT and $CLIENT_KEY will be set to the paths" + , "of the corresponding certificate and private key files." ] "!" -> [ "TARGET {!} COMMAND: run shell command on body." , "The line after '!' is used as a shell command after transforming as follows:" , "%s is substituted with the path to a temporary file containing the target;" , "if no %s appears, this path is appended to the end (separated by a space)." , "A literal '%' can be escaped as '%%'." - , "Environment variables $URI and $MIMETYPE are set to correspond to the target." ] + , "" + , "Environment variables $URI, $MIMETYPE, $CLIENT_CERT, and $CLIENT_KEY" + , "are set to correspond to the target." ] "|" -> [ "TARGET {|} COMMAND: pipe body through shell command." - , "Environment variables $URI and $MIMETYPE are set to correspond to the target." ] + , "" + , "Environment variables $URI, $MIMETYPE, $CLIENT_CERT, and $CLIENT_KEY" + , "are set to correspond to the target." ] "||" -> [ "TARGET {||} [COMMAND]: pipe rendered text through shell command." , "The default command is the contents of the environment variable $PAGER." - , "Environment variables $URI and $MIMETYPE are set to correspond to the target." + , "" + , "Environment variables $URI, $MIMETYPE, $CLIENT_CERT, and $CLIENT_KEY" + , "are set to correspond to the target." + , "" , "See {||-} for a variant which does not produce ansi escapes." , "See also: {default_action}, {||-}" ] "||-" -> [ "TARGET {||-} [COMMAND]: pipe plain rendered text through shell command." diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -430,7 +430,7 @@ printIOErr = displayWarning . (:[]) . show fingerprintHex :: Fingerprint -> String - fingerprintHex (Fingerprint fp) = concat $ hexWord8 <$> BS.unpack fp + fingerprintHex (Fingerprint fp) = concatMap hexWord8 $ BS.unpack fp where hexWord8 w = let (a,b) = quotRem w 16 hex = ("0123456789abcdef" !!) . fromIntegral diff --git a/Identity.hs b/Identity.hs --- a/Identity.hs +++ b/Identity.hs @@ -19,6 +19,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Safe import System.Directory (listDirectory) +import System.FilePath import ANSIColour import ClientCert @@ -44,6 +45,12 @@ loadIdentity :: FilePath -> String -> IO (Maybe Identity) loadIdentity idsPath idName = (Identity idName <$>) <$> loadClientCert idsPath idName + +identityEnvironment :: FilePath -> Identity -> [(String,String)] +identityEnvironment idsPath (Identity idName _) = + [ ("CLIENT_CERT", idsPath idName <.> "crt") + , ("CLIENT_KEY", idsPath idName <.> "key") + ] getIdentity :: Bool -> Bool -> FilePath -> KeyType -> String -> IO (Maybe Identity) getIdentity _ _ _ tp "" = runMaybeT $ Identity "" <$> liftIO (generateSelfSigned tp "") diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.12 +VERSION=0.1.13 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa diff --git a/TextGemini.hs b/TextGemini.hs --- a/TextGemini.hs +++ b/TextGemini.hs @@ -106,23 +106,21 @@ prependHeader _ [] = [] wrap :: Int -> T.Text -> [[T.Text]] - wrap wrapWidth line = wrap' "" 0 $ T.words line + wrap wrapWidth line = wrap' [] "" 0 $ T.words line where maxWCWidth = 2 ww = max maxWCWidth wrapWidth - wrap' l n ws | n > ww = - chunkVisible l : wrap' "" 0 ws - where - chunkVisible s | T.null s = [] - chunkVisible s = let (a,b) = splitAtVisible ww s in a : chunkVisible b - wrap' l _ [] = [[l]] - wrap' l n (w:ws) = - let l' = if T.null l then w else l <> " " <> w - nw = visibleLength w + wrap' ls l _ [] = [ls <> [l] ] + wrap' ls l n (w:ws) = + let nw = visibleLength w + l' = if T.null l then w else l <> " " <> w n' = n + nw + (if T.null l then 0 else 1) - in if n' > ww - then (if T.null l then id else ([l]:)) $ wrap' w nw ws - else wrap' l' n' ws + in if nw > ww && n + 1 < ww + then let (a,b) = splitAtVisible ww l' + in wrap' (ls <> [a]) "" 0 $ b:ws + else if n' > ww + then (ls <> [l]:) $ wrap' [] "" 0 $ w:ws + else wrap' ls l' n' ws data GeminiParseState = GeminiParseState { numLinks :: Int, preformatted :: Maybe T.Text } diff --git a/URI.hs b/URI.hs --- a/URI.hs +++ b/URI.hs @@ -26,6 +26,7 @@ , relativeFrom , relativeTo , setQuery + , setSchemeDefault , stripUri , stripUriForGemini , unescapeUriString @@ -68,6 +69,9 @@ -- | strips trailing ':' uriScheme :: URI -> String uriScheme = init . NU.uriScheme . uriUri + +setSchemeDefault :: URI -> URI +setSchemeDefault = URI . (\nuri -> nuri { NU.uriScheme = defaultScheme <> ":" }) . uriUri pathSegments :: URI -> [String] pathSegments (URI uri) = NU.pathSegments 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.12" +version = "0.1.13" 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.12 +version: 0.1.13 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org diff --git a/diohsc.hs b/diohsc.hs --- a/diohsc.hs +++ b/diohsc.hs @@ -123,11 +123,6 @@ historyUri :: HistoryItem -> URI historyUri = requestUri . historyRequest -historyEnv :: HistoryItem -> [(String,String)] -historyEnv item = - [ ("URI", show $ historyUri item) - , ("MIMETYPE", showMimeType $ historyMimedData item) ] - historyAncestors :: HistoryItem -> [HistoryItem] historyAncestors i = case historyParent i of Nothing -> [] @@ -335,7 +330,7 @@ qfs <- ignoreIOErr $ liftIO findQueueFiles forM_ qfs $ \(qfile, qname) -> enqueue qname Nothing <=< ignoreIOErr . liftIO $ - catMaybes . (queueLine <$>) <$> readFileLines qfile <* removeFile qfile + mapMaybe queueLine <$> readFileLines qfile <* removeFile qfile ignoreIOErr . liftIO $ removeDirectory queuesDir where findQueueFiles :: IO [(FilePath,String)] @@ -551,6 +546,12 @@ savesDir = userDataDir "saves" marksDir = userDataDir "marks" + historyEnv :: HistoryItem -> ClientM [(String,String)] + historyEnv item = gets clientActiveIdentities >>= \ais -> pure $ + [ ("URI", show $ historyUri item) + , ("MIMETYPE", showMimeType $ historyMimedData item) ] <> + (maybe [] (identityEnvironment idsPath) . idAtUri ais $ historyUri item) + setMark :: String -> URIWithIdName -> ClientM () setMark mark uriId | markNameValid mark = do modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s } @@ -694,7 +695,7 @@ else Just $ TargetFrom (HistoryOrigin item $ Just n) uri in resolveElemsSpecs "link" isMatch slice specs >>= (\case [] -> Left "No such link" - targs -> return targs) . catMaybes . (linkTarg <$>) + targs -> return targs) . mapMaybe linkTarg matchPattern :: String -> String -> Bool matchPattern patt = @@ -939,18 +940,22 @@ then getIdentityRequesting ansi idsPath else getIdentity interactive ansi idsPath KeyRSA "" lift $ addIdentity req ident - handleUriCommand uri ("browse", args) = void . liftIO . runMaybeT $ do - cmd <- case args of - [] -> maybe notSet - (\s -> if null s then notSet else return $ parseBrowser s) =<< - lift (lookupEnv "BROWSER") - where - notSet = printErr "Please set $BROWSER or give a command to run" >> mzero - -- |based on specification for $BROWSER in 'man 1 man' - parseBrowser :: String -> String - parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':') - (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c - lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd []) + handleUriCommand uri ("browse", args) = do + ais <- gets clientActiveIdentities + let envir = maybe [] (identityEnvironment idsPath) . + idAtUri ais . setSchemeDefault $ uri + void . liftIO . runMaybeT $ do + cmd <- case args of + [] -> maybe notSet + (\s -> if null s then notSet else return $ parseBrowser s) =<< + lift (lookupEnv "BROWSER") + where + notSet = printErr "Please set $BROWSER or give a command to run" >> mzero + -- |based on specification for $BROWSER in 'man 1 man' + parseBrowser :: String -> String + parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':') + (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c + lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd envir) handleUriCommand uri ("repl",_) = repl Nothing uri handleUriCommand uri ("query", CommandArg _ str : _) = goUri True Nothing . setQuery ('?':escapeQuery str) $ uri @@ -1021,16 +1026,20 @@ t0 <- timeCurrentP BL.writeFile fullpath =<< interleaveProgress t0 body - actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted . - shellOnData noConfirm cmd userDataDir (historyEnv item) . mimedBody $ historyMimedData item + actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> do + env <- historyEnv item + liftIO . handle printIOErr . doRestricted . + shellOnData noConfirm cmd userDataDir env . mimedBody $ historyMimedData item actionOfCommand ("view",_) = Just $ \item -> let mimed = historyMimedData item mimetype = showMimeType mimed body = mimedBody mimed in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body - actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted $ - pipeToShellLazily cmd (historyEnv item) . mimedBody $ historyMimedData item + actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> do + env <- historyEnv item + liftIO . handle printIOErr . doRestricted $ + pipeToShellLazily cmd env . mimedBody $ historyMimedData item actionOfCommand ("||", args) = Just $ pipeRendered ansi args actionOfCommand ("||-", args) = Just $ pipeRendered False args actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData @@ -1039,7 +1048,8 @@ actionOfCommand _ = Nothing pipeRendered :: Bool -> [CommandArg] -> CommandAction - pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> + pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> do + env <- historyEnv item liftIO . void . runMaybeT $ do cmd <- case args of [] -> maybe notSet @@ -1048,7 +1058,7 @@ where notSet = printErr "Please set $PAGER or give a command to run" >> mzero (CommandArg _ cmd : _) -> return cmd - lift . doRestricted . pipeToShellLazily cmd (historyEnv item) . T.encodeUtf8 $ T.unlines ls + lift . doRestricted . pipeToShellLazily cmd env . T.encodeUtf8 $ T.unlines ls doSubCommand :: ClientState -> Bool -> String -> ClientM () doSubCommand s block str = void . runMaybeT $ do @@ -1135,8 +1145,9 @@ let uri' = to `relativeTo` uri crossSite = uriRegName uri' /= uriRegName uri crossScheme = uriScheme uri' /= uriScheme uri - [fromId,toId] = idAtUri ais <$> [uri,uri'] - crossScope = isJust toId && fromId /= toId + crossScope = case idAtUri ais <$> [uri,uri'] of + [fromId,toId] -> isJust toId && fromId /= toId + _ -> False warningStr = colour BoldRed proceed <- (isJust <$>) . lift . runMaybeT $ do when crossSite $ guard <=< (liftIO . promptYN False) $ @@ -1266,7 +1277,7 @@ Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) . doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>) where appendNewline = (`BL.snoc` 10) - (Right <$>) . applyFilter . (sanitiseNonCSI <$>) $ case textType of + (Right <$>) . applyFilter . (sanitiseForDisplay <$>) $ case textType of "gemini" -> let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText diff --git a/diohscrc.sample b/diohscrc.sample --- a/diohscrc.sample +++ b/diohscrc.sample @@ -55,9 +55,13 @@ #alias Read ||- espeak -s 300 --stdin --stdout | aplay #alias BGRead ||- espeak -s 300 --stdin --stdout | aplay & -# For use with https://alexschroeder.ch/cgit/gemini-titan/ -# Invoke as "TARGET Ti TOKEN [FILE]" -#alias Titan br titan %s +# For use with gemini://gemini.thegonz.net/titan-upload.sh +# Invoke as "TARGET TU [FILE] [-t TOKEN]" where TARGET is a titan:// uri to +# upload an existing file (or compose one), +# or as "TARGET TE [-t TOKEN]" to edit a gemini TARGET and upload the changed +# version via titan. +#alias TU br titan-upload.sh %s +#alias TE ! $EDITOR %s && titan-upload.sh titan://${URI#gemini://} %s ## Identification # You may want to configure certain cryptographic identities to always be used