diohsc 0.1.12 → 0.1.13

raw patch · 14 files changed

+103/−55 lines, 14 files

Files

• ANSIColour.hs +4/−1
• Alias.hs +3/−1
• CHANGELOG.md +4/−0
• ClientCert.hs +5/−1
• Command.hs +15/−4
• GeminiProtocol.hs +1/−1
• Identity.hs +7/−0
• Makefile +1/−1
• TextGemini.hs +11/−13
• URI.hs +4/−0
• Version.hs +1/−1
• diohsc.cabal +1/−1
• diohsc.hs +39/−28
• diohscrc.sample +7/−3

@@ -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

@@ -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 =

@@ -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

@@ -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

@@ -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."

@@ -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

@@ -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 "")

@@ -1,4 +1,4 @@-VERSION=0.1.12+VERSION=0.1.13  GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa 

@@ -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 }

@@ -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

@@ -16,4 +16,4 @@ programName = "diohsc"  version :: String-version = "0.1.12"+version = "0.1.13"

@@ -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

@@ -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

@@ -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