From e9d5306f9df690803399f81bcc31d86e28084ab9 Mon Sep 17 00:00:00 2001 From: defanor Date: Thu, 26 Oct 2017 01:27:09 +0300 Subject: Initial commit --- ChangeLog.md | 5 + LICENSE | 30 +++ Pancake.hs | 578 ++++++++++++++++++++++++++++++++++++++++++ README.org | 49 ++++ Text/Pandoc/Readers/Gopher.hs | 70 +++++ Text/Pandoc/Readers/Plain.hs | 20 ++ pancake.cabal | 39 +++ 7 files changed, 791 insertions(+) create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 Pancake.hs create mode 100644 README.org create mode 100644 Text/Pandoc/Readers/Gopher.hs create mode 100644 Text/Pandoc/Readers/Plain.hs create mode 100644 pancake.cabal diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..20a6b61 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for pancake + +## 0.1.0.0 -- 2017-10-26 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..ea70dd5 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, defanor + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of defanor nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Pancake.hs b/Pancake.hs new file mode 100644 index 0000000..0c9f8c5 --- /dev/null +++ b/Pancake.hs @@ -0,0 +1,578 @@ +{- | +Description : A CLI web\/gopher browser +Maintainer : defanor +Stability : unstable +Portability : non-portable (uses GHC extensions) + +A CLI web\/gopher\/file browser inspired by +. + +-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import qualified Text.Pandoc as P +import System.FilePath +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Char8 as BS +import Data.Default +import Network.URI +import System.Process +import Control.Monad.Writer hiding ((<>)) +import Control.Monad.State +import Data.Maybe +import Data.Either +import Data.List +import Data.String +import Data.Monoid.Colorful +import qualified System.Console.Terminfo as TI +import System.Environment +import Data.Yaml +import GHC.Generics +import qualified Data.Map as M +import System.Directory +import System.Exit +import GHC.IO.Handle +import qualified Data.ByteString.UTF8 as BSUTF8 +import Control.Exception +import Text.Pandoc.Readers.Plain +import Text.Pandoc.Readers.Gopher + + +-- * Document reading + +-- | Retrieves a document. Prints an error message and returns an +-- empty string on failure. +retrieve :: String + -- ^ Shell command to use for retrieval. + -> URI + -- ^ Document URI. + -> IO BS.ByteString + -- ^ Document contents. +retrieve cmd uri = do + putStrLn $ "Retrieving " ++ show uri + curEnv <- getEnvironment + let envAuthority = maybe [] (\x -> [ ("URI_USERINFO", uriUserInfo x) + , ("URI_REGNAME", uriRegName x) + , ("URI_PORT", uriPort x) ]) + (uriAuthority uri) + environment = ("URI", uriToString id uri "") + : ("URI_SCHEME", uriScheme uri) + : ("URI_PATH", uriPath uri) + : ("URI_QUERY", uriQuery uri) + : ("URI_FRAGMENT", uriFragment uri) + : curEnv + ++ envAuthority + handle (\(e :: SomeException) -> + putStrLn (concat ["Failed to run `", cmd, "`: ", show e]) + >> pure BS.empty) $ + withCreateProcess ((shell cmd) { env = Just environment + , std_out = CreatePipe + , std_err = CreatePipe }) $ + \_ stdout stderr ph -> case stdout of + Nothing -> putStrLn "No stdout" >> pure BS.empty + Just stdout' -> do + hSetBinaryMode stdout' True + out <- BS.hGetContents stdout' + ec <- waitForProcess ph + when (ec /= ExitSuccess) $ do + putStrLn $ concat ["An error occured. Exit code: ", show ec] + case stderr of + Nothing -> pure () + Just stderr' -> do + err <- BS.hGetContents stderr' + BS.putStrLn $ BS.concat ["stderr: ", err] + pure out + +-- | Reads a document: retrieves it and parses into a Pandoc +-- structure. The parser is chosen depending on the URI. +readDoc :: String + -- ^ Shell command to use for retrieval. + -> URI + -- ^ Document URI. + -> IO (Maybe P.Pandoc) + -- ^ A parsed document. +readDoc cmd uri = do + out <- retrieve cmd uri + term <- TI.setupTermFromEnv + let reader = case (uriScheme uri, takeExtension $ uriPath uri) of + -- some exceptions and special cases (might be better to make + -- this configurable) + ("http:", ".php") -> P.getReader "html" + ("https:", ".php") -> P.getReader "html" + ("http:", "") -> P.getReader "html" + ("https:", "") -> P.getReader "html" + ("gopher:", "") -> pure . P.StringReader . const $ pure . readGopher + (_, "") -> pure . P.StringReader . const $ pure . readPlain + (_, ".txt") -> pure . P.StringReader . const $ pure . readPlain + (_, ".md") -> P.getReader "markdown" + ("gopher:", ext) -> case splitDirectories $ uriPath uri of + ("/":"0":_) -> pure . P.StringReader . const $ pure . readPlain + ("/":"1":_) -> pure . P.StringReader . const $ pure . readGopher + ("/":"h":_) -> P.getReader "html" + _ -> P.getReader $ tail ext + (_, ext) -> P.getReader $ tail ext + cols = maybe 80 id $ TI.getCapability term TI.termColumns + opts = def { P.readerColumns = cols } + case reader of + Left err -> putStrLn err >> pure Nothing + Right reader' -> + case reader' of + P.StringReader f -> do + r <- f opts $ BSUTF8.toString out + case r of + Left err -> putStrLn (show err) >> pure Nothing + Right doc -> pure $ pure doc + P.ByteStringReader f -> do + r <- f opts $ BL.fromStrict out + case r of + Left err -> putStrLn (show err) >> pure Nothing + Right (doc, _) -> pure $ pure doc + + +-- * Rendering + +-- | Renderer state. +data RS = RS { indentationLevel :: Int + , linkCount :: Int + , bulleted :: Bool + , ordered :: Maybe Int + , columns :: Int + } deriving (Show, Eq) + +-- | Used to render 'Pandoc' docs by writing text lines and collected +-- links using 'Writer'. +type Renderer a = WriterT [Either URI (Colored String)] (State RS) a + +-- | Runs a 'Renderer'. +runRenderer :: Int + -- ^ Column count (line width). + -> Renderer a + -- ^ A renderer. + -> [Either URI (Colored String)] + -- ^ Collected links and text lines. +runRenderer cols r = snd $ fst $ runState (runWriterT r) (RS 0 0 False Nothing cols) + +-- | Stores a link, increasing the counter +storeLink :: URI -> Renderer Int +storeLink u = do + tell [Left u] + st <- get + put (st { linkCount = linkCount st + 1 }) + pure $ linkCount st + +-- | Increases indentation level, runs a renderer, decreases +-- indentation level. +withIndent :: Renderer a -> Renderer a +withIndent x = do + modify (\s -> s { indentationLevel = indentationLevel s + 1 }) + r <- x + modify (\s -> s { indentationLevel = indentationLevel s - 1 }) + pure r + +-- | Renders indented (with the current indent level) lines. +indented :: [Colored String] -> Renderer () +indented strings = do + st <- get + let indent = if bulleted st + then indentationLevel st + 2 + else maybe (indentationLevel st) + ((indentationLevel st + 2 +) . length . show) (ordered st) + case ( fitLines ((columns st) - indent) strings + , bulleted st + , ordered st) of + ([], _, _) -> tell [] + (x:xs, True, _) -> + tell $ Right (fromString (replicate (indentationLevel st) ' ') <> Fg Yellow "* " <> x) + : map (Right . (fromString (replicate indent ' ') <>)) xs + (x:xs, _, Just n) -> do + tell $ Right (mconcat [ fromString (replicate (indentationLevel st) ' ') + , Fg Yellow $ fromString (show n ++ ".") + , " " + , x]) + : map (Right . (fromString (replicate indent ' ') <>)) xs + modify (\s -> s { ordered = Just (n + 1) }) + (xs, _, _) -> tell $ map (Right . (fromString (replicate indent ' ') <>)) xs + +-- todo: deal with non-breaking spaces +-- | Fits words into terminal lines of a given width. +fitLines :: Int + -- ^ Line width. + -> [Colored String] + -- ^ Strings: usually words and similar short elements. + -> [Colored String] + -- ^ Fitted lines. +fitLines maxLen inlineBits = map mconcat $ map reverse $ fitWords [] 0 inlineBits + where + asString w = showColoredS TermDumb w "" + -- handle newline characters + fitWords curLine _ ("\n":ws) = curLine : fitWords [] 0 ws + -- a new line + fitWords _ 0 (w:ws) = fitWords [w] (length $ asString w) ws + -- add a word to a line + fitWords curLine curLen (w:ws) = let wLen = length (asString w) in + if curLen + wLen <= maxLen + then fitWords (w:curLine) (curLen + wLen) ws + else curLine : fitWords [] 0 (case w of + " " -> ws + _ -> (w:ws)) + -- end, no words pending + fitWords _ 0 [] = [] + -- end, with words pending + fitWords curLine _ [] = [curLine] + +-- | A helper function to put inline elements between two strings +-- (such as parens or quotes). +wrappedInlines :: Colored String + -- ^ String on the left. + -> Colored String + -- ^ String on the right. + -> [P.Inline] + -- ^ Inlines to wrap. + -> Renderer [Colored String] + -- ^ Resulting inlines. +wrappedInlines s e r = do + r' <- concat <$> mapM readInline r + pure $ s : r' ++ [e] + +-- | Reads an inline element, producing strings. Doesn't render them +-- (i.e., using 'Writer') on its own, but collects links. +readInline :: P.Inline -> Renderer [Colored String] +readInline (P.Str s) = pure $ intersperse " " $ map fromString $ words s +readInline (P.Emph s) = concatMap (fmap $ Style Italic) <$> mapM readInline s +readInline (P.Strong s) = concatMap (fmap $ Style Bold) <$> mapM readInline s +readInline (P.Strikeout s) = wrappedInlines "-" "-" s +readInline (P.Superscript s) = wrappedInlines "^{" "}" s +readInline (P.Subscript s) = wrappedInlines "_{" "}" s +readInline (P.SmallCaps s) = wrappedInlines "\\sc{" "}" s +readInline (P.Quoted P.SingleQuote s) = wrappedInlines "‘" "’" s +readInline (P.Quoted P.DoubleQuote s) = wrappedInlines "“" "”" s +readInline (P.Cite _ s) = concat <$> mapM readInline s +readInline (P.Code _ s) = pure $ map fromString $ intersperse "\n" $ lines s +readInline P.Space = pure . pure $ fromString " " +readInline P.SoftBreak = pure . pure $ fromString " " +readInline P.LineBreak = pure . pure $ fromString "\n" +readInline (P.Math _ s) = pure . pure $ fromString s +readInline (P.RawInline _ s) = pure . pure $ fromString s +readInline (P.Link _ alt (url, title)) = + case parseURIReference url of + Just uri -> do + cnt <- storeLink uri + a <- mapM readInline alt + let t = case (title, a) of + ("", []) -> [fromString url] + ("", alt') -> concat alt' + (title', []) -> [fromString title'] + (_, alt') -> concat alt' -- [[fromString title'], [" ("], concat alt', [")"]] + case uri of + -- fragment links are mostly useless here, at least for now. + -- but still marking them as links, to avoid confusion. + (URI "" Nothing "" "" _) -> pure $ map (Fg DullCyan) t + _ -> pure $ map (Fg Cyan) t ++ [Fg Blue (mconcat ["[", fromString $ show cnt, "]"])] + Nothing -> pure . pure $ fromString title +readInline (P.Image attr alt (url, title)) = do + asLink <- readInline (P.Link attr alt (url, title)) + pure $ Fg Red "(image) " : asLink +readInline (P.Note _) = pure $ pure "(note: todo)" +readInline (P.Span _ i) = do + strings <- concat <$> mapM readInline i + pure strings + +-- | Renders a block element. +renderBlock :: P.Block -> Renderer () +renderBlock (P.Plain i) = do + strings <- concat <$> mapM readInline i + indented strings +renderBlock (P.Para i) = do + strings <- concat <$> mapM readInline i + indented strings + tell [Right ""] +renderBlock (P.LineBlock i) = do + strings <- concatMap mconcat <$> mapM (mapM readInline) i + indented strings +renderBlock (P.CodeBlock _ s) = indented $ map fromString $ intersperse "\n" $ lines s +renderBlock (P.RawBlock _ s) = indented $ map fromString $ intersperse "\n" $ lines s +renderBlock (P.BlockQuote bs) = renderBlocks bs +renderBlock (P.OrderedList _ bs) = do + st <- get + let o = ordered st + put (st { ordered = Just 1 }) + mapM_ renderBlocks bs + modify (\s -> s { ordered = o }) +renderBlock (P.BulletList bs) = do + st <- get + let b = bulleted st + put (st { bulleted = True }) + mapM_ renderBlocks bs + modify (\s -> s { bulleted = b }) +renderBlock (P.DefinitionList dl) = + let renderDefinition (term, definition) = do + term' <- concat <$> mapM readInline term + indented term' + mapM_ renderBlocks definition + in mapM_ renderDefinition dl +renderBlock (P.Header _ _ i) = do + strings <- concat <$> mapM readInline i + indented $ "\n" : map (Fg Green . Style Bold . Style Underline) strings +renderBlock P.HorizontalRule = do + st <- get + indented [fromString $ replicate (columns st - indentationLevel st * 2) '-'] +renderBlock (P.Table _ _ _ headers rows) = do + -- that's a silly, yet a simple way to render a table. improve it + -- later (todo). + renderStairs headers + mapM_ renderStairs rows + where + renderStairs :: [[P.Block]] -> Renderer () + renderStairs [] = pure () + renderStairs (x:xs) = do + renderBlocks x + withIndent $ renderStairs xs +renderBlock (P.Div _ b) = renderBlocks b +renderBlock P.Null = pure () + +-- | Renders multiple block elements. +renderBlocks :: [P.Block] -> Renderer () +renderBlocks b = withIndent $ mapM_ renderBlock b + + +-- * Configuration + +-- | Application configuration. +data Config = Config { commands :: M.Map String String + -- ^ URI schemes and corresponding shell commands + -- for downloading. + , defaultCommand :: String + -- ^ A command to use if no other command + -- applies. + , externalViewers :: M.Map String String + -- ^ File extensions and corresponding external + -- applications. + , shortcuts :: M.Map String String + -- ^ Shortcuts to use (search engines, + -- dictionaries, etc). + , paginate :: Bool + -- ^ Enable pagination; print everything at once + -- otherwise. + } deriving (Generic, Show) + +-- | For configuration parsing +instance FromJSON Config +-- | For configuration writing, particularly that of default +-- configuration if it is missing. +instance ToJSON Config +-- | The default configuration to use if user configuration is +-- missing. +instance Default Config where + def = Config { commands = M.fromList + [ ("ssh", "scp \"${URI_REGNAME}:${URI_PATH}\" /dev/stdout") + -- gopher://bitreich.org:70/1/onion + , ("gopher", "torify curl \"${URI}\"")] + , defaultCommand = "curl -4 -L \"${URI}\"" + , externalViewers = M.fromList $ + map (flip (,) "emacsclient") ["hs", "cabal", "c", "h", "el", "scm", "idr"] + ++ map (flip (,) "xdg-open") ["svg", "png", "jpg", "jpeg", "gif", "pdf"] + , shortcuts = M.fromList + [ ("ddg", "https://duckduckgo.com/lite/?q=") + , ("wp", "https://en.m.wikipedia.org/wiki/Special:Search?search=") + , ("wt", "https://en.m.wiktionary.org/w/index.php?search=") + , ("gp", "gopher://gopherpedia.com:70/7/lookup?") + , ("vs", "gopher://gopher.floodgap.com/7/v2/vs?")] + , paginate = True + } + +-- | Loads configuration from an XDG config directory. +loadConfig :: MonadIO m => StateT LoopState m () +loadConfig = do + c <- liftIO $ do + dir <- getXdgDirectory XdgConfig "pancake" + createDirectoryIfMissing True dir + let configPath = dir "config.yaml" + exists <- doesFileExist configPath + if exists + then do + c <- decodeFile configPath + case c of + Just config -> pure config + Nothing -> putStrLn "Failed to read the configuration, using defaults" >> pure def + else encodeFile configPath (def :: Config) >> pure def + modify $ \s -> s {conf = c} + + +-- * Control + +-- | Interactive user command. +data Command = Quit + | Follow Int + | More + | GoTo URI + | Reload + | Back + | Forward + | Help + | Show Int + | ShowCurrent + | Shortcut String String + | ReloadConfig + deriving (Show, Eq) + +-- | A zipper kind of thing, for scrolling and history traversal. +type Sliding a = ([a], [a], [a]) + +-- | Main event loop's state. +data LoopState = LS { history :: Sliding (URI, P.Pandoc) + , display :: Sliding (Colored String) + , links :: [URI] + , conf :: Config + } deriving (Show) + +-- | Prints rendered lines. +showLines :: MonadIO m => [Colored String] -> StateT LoopState m () +showLines ls = liftIO $ do + term <- getTerm + mapM_ (\s -> printColoredS term s >> putChar '\n') ls + +-- | Renders a parsed document. +renderDoc :: MonadIO m => P.Pandoc -> StateT LoopState m () +renderDoc (P.Pandoc _ blocks) = do + term <- liftIO TI.setupTermFromEnv + st <- get + let cols = maybe 80 id $ TI.getCapability term TI.termColumns + rows = maybe 25 id (TI.getCapability term TI.termLines) - 1 + textLines = rights l + (shownLines, nextLines) = + if paginate (conf st) + then splitAt rows textLines + else (textLines, []) + l = runRenderer cols $ renderBlocks blocks + showLines shownLines + modify (\s -> s { links = lefts l + , display = ([], shownLines, nextLines )}) + +-- | Evaluates user commands. +command :: MonadIO m => Command -> StateT LoopState m () +command (GoTo u') = do + st <- get + let ddg = isPrefixOf "/l/?kh=-1&uddg=" $ uriToString id u' "" + u = case (ddg, uriIsAbsolute u', history st) of + -- fix DDG links (that's rather hacky, todo: improve) + (True, _, _) -> maybe u' id $ parseAbsoluteURI (unEscapeString $ drop 12 (uriQuery u')) + -- handle relative URIs + (_, False, (_, [(cur, _)], _)) -> relativeTo u' cur + _ -> u' + cmd = maybe (defaultCommand $ conf st) id (M.lookup (init $ uriScheme u) (commands $ conf st)) + d <- liftIO $ do + let ext = case takeExtension $ uriPath u of + "" -> "html" + x -> tail x + case M.lookup ext (externalViewers $ conf st) of + Nothing -> readDoc cmd u + Just ev -> do + d <- retrieve cmd u + dir <- getXdgDirectory XdgCache "pancake" + let tmpPath = dir (takeFileName $ uriPath u) + handle + (\(e :: SomeException) -> + putStrLn (concat ["Failed to open `", tmpPath, "` with `" , cmd, "`: ", show e])) $ do + createDirectoryIfMissing True dir + BS.writeFile tmpPath d + callCommand $ concat [ev, " ", tmpPath] + pure Nothing + case d of + Nothing -> pure () + Just doc@(P.Pandoc _ _) -> do + renderDoc doc + modify $ \s -> + let (prev, cur, _) = history s + in s { history = ( cur ++ prev, [(u, doc)], []) } +command (Follow i) = do + st <- get + if length (links st) > i + then command (GoTo $ links st !! i) + else liftIO $ putStrLn "No such link" +command Back = do + st <- get + case history st of + (p@(_, d):prev, cur, next) -> do + renderDoc d + modify $ \s -> s { history = (prev, [p], cur ++ next) } + _ -> liftIO $ putStrLn "There's nothing back there" +command Forward = do + st <- get + case history st of + (prev, cur, n@(_, d):next) -> do + renderDoc d + modify $ \s -> s { history = (cur ++ prev, [n], next) } + _ -> liftIO $ putStrLn "Nowhere to go" +command More = do + st <- get + case display st of + (_, _, []) -> pure () + (prev, cur, next) -> do + term <- liftIO TI.setupTermFromEnv + let lineCount' = maybe 25 id (TI.getCapability term TI.termLines) + lineCount = lineCount' - div lineCount' 3 + (newLines, next') = splitAt lineCount next + showLines newLines + modify (\s -> s { display = (reverse cur ++ prev, newLines, next') }) + pure () +command Reload = liftIO $ putStrLn "Not implemented yet (TODO)" +command Help = do + st <- get + liftIO $ do + putStrLn "[q]uit, [b]ack, [f]orward, [h]elp, [re]load config" + putStrLn "type a number to follow a link, \"?\" to print its URI" + putStrLn "type an URI (absolute or relative) to open it" + when (paginate $ conf st) $ putStrLn "RET to scroll" +command (Show n) = do + st <- get + liftIO . putStrLn $ if length (links st) > n + then show $ links st !! n + else "No such link" +command ShowCurrent = do + st <- get + case history st of + (_, [(u, _)], _) -> liftIO $ putStrLn $ show u + _ -> pure () +command (Shortcut u q) = command . GoTo . fromJust . parseURI $ + u ++ escapeURIString isReserved q +command ReloadConfig = loadConfig +command Quit = liftIO $ do + dir <- getXdgDirectory XdgCache "pancake" + exists <- doesDirectoryExist dir + when exists $ removeDirectoryRecursive dir + +-- | Reads commands, runs them. +eventLoop :: MonadIO m => StateT LoopState m () +eventLoop = do + cmd <- liftIO $ getLine + st <- get + let c = case cmd of + "q" -> Quit + "b" -> Back + "f" -> Forward + "r" -> Reload + "re" -> ReloadConfig + "h" -> Help + "?" -> ShowCurrent + _ -> case reads cmd of + [(n, "")] -> Follow n + [(n, "?")] -> Show n + _ -> case words cmd of + [] -> More + (s:q) -> case M.lookup s (shortcuts (conf st)) of + Just u -> Shortcut u $ unwords q + Nothing -> case parseURIReference cmd of + Just uri -> GoTo uri + Nothing -> Help + command c + when (c /= Quit) eventLoop + +-- | Loads configuration and runs 'eventLoop'. +main :: IO () +main = runStateT (loadConfig >> eventLoop) (LS ([],[],[]) ([],[],[]) [] def) + >> pure () diff --git a/README.org b/README.org new file mode 100644 index 0000000..82471af --- /dev/null +++ b/README.org @@ -0,0 +1,49 @@ +This is a CLI web/gopher/file browser inspired by [[https://en.wikipedia.org/wiki/Line_Mode_Browser][Line Mode Browser]]. + +It combines [[http://pandoc.org/][pandoc]] with external downloaders such as [[https://curl.haxx.se/][curl]], adding +support for Gopher directories and plaintext files, and invoking +external applications (e.g., image and PDF viewers) depending on its +configuration. + +It is intended to be used with ~rlwrap~ and ~tmux~ or ~screen~, and +doesn't duplicate their functionality. + +* Commands + +- [q]uit, [b]ack, [f]orward, [h]elp, [re]load config +- : follow a link (or open the referenced file) +- ?: show link/image URI +- ?: show current URI +- RET (empty): show the next 2/3 of a page, if pagination is enabled +- : follow an URI, possibly relative to the current one +- : run a query using a shortcut defined in the + configuration (e.g., search) + +* Sample configuration + +#+BEGIN_SRC yaml +externalViewers: + png: xdg-open + hs: emacsclient +commands: + gopher: torify curl "${URI}" + ssh: scp "${URI_REGNAME}:${URI_PATH}" /dev/stdout +defaultCommand: curl -4 -L "${URI}" +shortcuts: + ddg: https://duckduckgo.com/lite/?q= + wt: https://en.m.wiktionary.org/w/index.php?search= + wp: https://en.m.wikipedia.org/wiki/Special:Search?search= + gp: gopher://gopherpedia.com:70/7/lookup? + vs: gopher://gopher.floodgap.com/7/v2/vs? +paginate: true +#+END_SRC + +* Screenshots + +[[https://defanor.uberspace.net/projects/pancake/gopher.png]] + +[[https://defanor.uberspace.net/projects/pancake/web-gnu.png]] + +[[https://defanor.uberspace.net/projects/pancake/web-wikipedia.png]] + +[[https://defanor.uberspace.net/projects/pancake/local-org.png]] diff --git a/Text/Pandoc/Readers/Gopher.hs b/Text/Pandoc/Readers/Gopher.hs new file mode 100644 index 0000000..33dec3e --- /dev/null +++ b/Text/Pandoc/Readers/Gopher.hs @@ -0,0 +1,70 @@ +{- | +Module : Text.Pandoc.Readers.Gopher +Maintainer : defanor +Stability : unstable +Portability : portable + +Loosely based on , but +since the commonly found in the wild directories tend to differ from +that, there are some adjustments. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Text.Pandoc.Readers.Gopher ( readGopher ) where + +import Text.Pandoc.Definition +import Text.Pandoc.Error +import Text.Parsec +import Text.Parsec.String + +-- | Translates a text line into a list of 'Inline' elements suitable +-- for further processing. +lineToInlines :: String -> [Inline] +lineToInlines [] = [] +lineToInlines (' ':rest) = Space : lineToInlines rest +lineToInlines s = let (cur, next) = break (== ' ') s + in Str cur : lineToInlines next + +-- | UNASCII ::= ASCII - [Tab CR-LF NUL]. +unascii :: Parser Char +unascii = noneOf ['\t', '\n', '\r', '\0'] + +-- | An informational directory entry. +pInfo :: Parser [Inline] +pInfo = do + _ <- char 'i' + info <- manyTill unascii tab + _ <- manyTill unascii tab + _ <- manyTill unascii tab + _ <- many1 digit + pure $ lineToInlines info ++ [LineBreak] + +-- | A file\/link (i.e., any other than informational) directory +-- entry. +pLink :: Parser [Inline] +pLink = do + t <- alphaNum + name <- manyTill unascii tab + selector <- manyTill unascii tab + host <- manyTill unascii tab + port <- many1 digit + let uri = concat ["gopher://", host, ":", port, "/", [t], selector] + pure [Link (name, [], []) (lineToInlines name) (uri, ""), LineBreak] + +-- | Parses last line, with adjustments for what's used in the wild. +pLastLine :: Parser () +-- Sometimes there's additional newline, sometimes there's no dot, and +-- sometimes LF is used instead of CRLF. +pLastLine = optional (optional endOfLine *> char '.' *> endOfLine) *> eof + +pDirEntries :: Parser [Inline] +pDirEntries = concat <$> manyTill (choice [pInfo, pLink] <* endOfLine) pLastLine + +-- | Reads Gopher directory entries, falls back to plain text on +-- failure. +readGopher :: String -> Either PandocError Pandoc +readGopher s = Right . Pandoc mempty . pure . Plain $ + case parse pDirEntries "directory entry" s of + -- fallback to plain text + Left _ -> concatMap (\l -> (lineToInlines l) ++ [LineBreak]) $ lines s + Right r -> r diff --git a/Text/Pandoc/Readers/Plain.hs b/Text/Pandoc/Readers/Plain.hs new file mode 100644 index 0000000..600e5f8 --- /dev/null +++ b/Text/Pandoc/Readers/Plain.hs @@ -0,0 +1,20 @@ +{- | +Module : Text.Pandoc.Readers.Plain +Maintainer : defanor +Stability : unstable +Portability : portable +-} + +{-# LANGUAGE OverloadedStrings #-} +module Text.Pandoc.Readers.Plain ( readPlain ) where + +import Text.Pandoc.Definition +import Text.Pandoc.Error +import Data.List + +-- | Reads plain text, always succeeding and producing a single +-- 'Plain' block. +readPlain :: String -> Either PandocError Pandoc +readPlain = Right . Pandoc mempty . pure . Plain . + concatMap (\l -> (intersperse Space $ map Str $ words l) ++ [LineBreak]) . lines + -- or Right . Pandoc mempty . pure . RawBlock "plain" diff --git a/pancake.cabal b/pancake.cabal new file mode 100644 index 0000000..ad7068c --- /dev/null +++ b/pancake.cabal @@ -0,0 +1,39 @@ +name: pancake +version: 0.1.0.0 +synopsis: A CLI web/gopher/file browser +tested-with: GHC == 8.0.1 +license: BSD3 +license-file: LICENSE +author: defanor +maintainer: defanor@uberspace.net +homepage: https://defanor.uberspace.net/projects/pancake/ +bug-reports: https://github.com/defanor/pancake/issues +category: Web +build-type: Simple +extra-source-files: ChangeLog.md + , README.org +cabal-version: >=1.10 + +executable pancake + main-is: Pancake.hs + other-modules: Text.Pandoc.Readers.Plain + , Text.Pandoc.Readers.Gopher + build-depends: base >=4.9 && <5, + bytestring >= 0.10.8.1, + colorful-monoids >= 0.2.1.0, + containers >= 0.5.7.1, + data-default >= 0.7.1.1, + directory >= 1.2.6.2, + filepath >= 1.4.1.0, + mtl >= 2.2.1, + network-uri >= 2.6.1.0, + pandoc >= 1.19.2.2, + pandoc-types >= 1.17.0.5, + parsec >= 3.1.11, + process >= 1.6, + terminfo >= 0.4.0.2, + utf8-string >= 1.0.1.1, + yaml >= 0.8.23.3 + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -Wall -- cgit v1.2.3