path: root/Pancake.hs

{- |
Description :  A CLI web\/gopher browser
Maintainer  :  defanor <defanor@uberspace.net>
Stability   :  unstable
Portability :  non-portable (uses GHC extensions)

A CLI web\/gopher\/file browser inspired by
<https://en.wikipedia.org/wiki/Line_Mode_Browser Line Mode Browser>.

-}

{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import qualified Text.Pandoc as P
import System.FilePath
import qualified Data.ByteString.Char8 as BS
import Data.Default
import Network.URI
import System.Process
import Control.Monad.Writer
import Control.Monad.State
import Data.Maybe
import Data.List
import System.Console.Terminfo
import System.Environment
import qualified Data.Map as M
import System.Directory
import System.Exit
import Control.Exception
import Data.Char
import System.IO.Error
import Control.Applicative
import Data.Version
import System.Console.GetOpt
import System.Posix.Signals
import Control.Concurrent

import Pancake.Common
import Pancake.Configuration
import Pancake.Command
import Pancake.Reading
import Pancake.Rendering
import Pancake.Printing
import Paths_pancake

-- | A zipper kind of thing, for scrolling and history traversal.
type Sliding a = ([a], [a])

-- | Main event loop's state.
data LoopState = LS { history :: Sliding (URI, P.Pandoc)
                    , position :: Int
                    , rendered :: [RendererOutput]
                    , conf :: Config
                    , embedded :: Bool
                    , interrupted :: Bool
                    } deriving (Show)

-- | Renders a parsed document.
printDoc :: MonadIO m => URI -> P.Pandoc -> StateT LoopState m ()
printDoc uri doc = do
  term <- liftIO setupTermFromEnv
  st <- get
  let cols = fromMaybe 80 $ getCapability term termColumns
      l = renderDoc cols (conf st) doc
      textLines = rLines l
  modify (\s -> s { rendered = l })
  if embedded st
    then showSexps uri l
    else do
    let rows = fromMaybe 25 (getCapability term termLines) - 1
    showLines $ if paginate (conf st)
                then take rows textLines
                else textLines
    modify (\s -> s { position = rows })

-- | Updates 'LoopState' with user configuration.
updateConfig :: MonadIO m => StateT LoopState m ()
updateConfig = do
  c <- loadConfig
  modify $ \s -> s { conf = c }

-- | Decides what to do with a given URI; either returns a document or
-- runs an external viewer. Used by both 'GoTo' and 'Reload'.
loadDocument :: MonadIO m
             => Maybe String
             -- ^ Document type.
             -> URI
             -- ^ Document URI.
             -> StateT LoopState m (URI, Maybe P.Pandoc)
loadDocument sType rawURI = do
  st <- get
  let ddg = isPrefixOf "/l/?kh=-1&uddg=" $ uriToString id rawURI ""
      adjustedURI = case (ddg, uriIsAbsolute rawURI, history st) of
        -- fix DDG links (that's rather hacky, todo: improve)
        (True, _, _) -> fromMaybe rawURI $
          parseAbsoluteURI (unEscapeString $ drop 12 (uriQuery rawURI))
        -- handle relative URIs
        (_, False, ((cur, _):_, _)) -> relativeTo rawURI cur
        _ -> rawURI
      uScheme = case uriScheme adjustedURI of
        [] -> "unknown"
        s -> init s
      cmd = fromMaybe (defaultCommand $ conf st) $
        M.lookup uScheme (commands $ conf st)
  liftIO $ do
    docData <- retrieve cmd adjustedURI
    case docData of
      Nothing -> pure (adjustedURI, mzero)
      Just (rawDoc, mdURI, mdType) -> do
        let effectiveURI = fromMaybe adjustedURI mdURI
            fType = sType <|> mdType
            ext = case (fType, takeExtension $ uriPath effectiveURI) of
              (Just x, _) -> x
              (_, '.':xs) -> map toLower xs
              (_, other) -> other
        case M.lookup ext (externalViewers $ conf st) of
          Nothing -> do
            doc <- readDoc rawDoc fType effectiveURI
            case doc of
              Left err -> do
                putErrLn $ show err
                pure (effectiveURI, mzero)
              Right r -> pure (effectiveURI, pure r)
          Just ev -> do
            dir <- getXdgDirectory XdgCache "pancake"
            let tmpPath = dir </> takeFileName (uriPath effectiveURI)
            handle
              (\(e :: SomeException) ->
                 putErrLn (concat ["Failed to open `", tmpPath, "` with `"
                                  , ev, "`: ", show e])) $ do
              createDirectoryIfMissing True dir
              BS.writeFile tmpPath rawDoc
              curEnv <- getEnvironment
              ec <- withCreateProcess
                ((shell ev) { env = Just (("FILE", tmpPath) : curEnv) }) $
                \_ _ _ p -> waitForProcess p
              when (ec /= ExitSuccess) $
                putErrLn $ "An error occured. Exit code: " ++ show ec
            pure (effectiveURI, mzero)

-- | Visits an URI, updates history accordingly.
goTo :: MonadIO m => Maybe String -> URI -> StateT LoopState m ()
goTo t u' = do
  (uri, d) <- loadDocument t u'
  case d of
    Nothing -> pure ()
    Just doc -> do
      printDoc uri doc
      modify $ \s ->
        let (prev, _) = history s
        in s {history = (take (historyDepth $ conf s) $ (uri, doc) : prev, [])}

-- | Evaluates user commands.
command :: MonadIO m => Command -> StateT LoopState m ()
command (GoTo t u@(URI _ _ _ _ ('#':xs))) = do
  -- follow an URI first, if it's not just a fragment
  case u of
    (URI "" Nothing "" "" _) -> pure ()
    _ -> goTo t u
  -- get to the fragment
  st <- get
  case (lookup xs (rIdentifiers $ rendered st), embedded st) of
    (Nothing, _) -> putErrLn $ "Unknown identifier: " ++ xs
    (Just x, False) -> do
      term <- liftIO setupTermFromEnv
      let lineCount = fromMaybe 25 (getCapability term termLines)
      when (x + lineCount - 2 > position st) $ do
        -- scroll to the given position without skipping anything
        showLines $ take (x - position st + lineCount - 2) $
          drop (position st) (rLines $ rendered st)
        modify (\s -> s { position = x + lineCount - 2 })
    (Just x, True) -> putSexpLn ["goto", show x]
command (GoTo t u) = goTo t u
command (Follow i) = do
  st <- get
  if length (rLinks $ rendered st) > i
    then command (GoTo Nothing $ rLinks (rendered st) !! i)
    else putErrLn "No such link"
command Back = do
  st <- get
  case history st of
    (cur:p@(uri, d):prev, next) -> do
      printDoc uri d
      modify $ \s ->
        s { history = (p:prev, take (historyDepth $ conf s) $ cur : next) }
    _ -> putErrLn "There's nothing back there"
command Forward = do
  st <- get
  case history st of
    (prev, n@(uri, d):next) -> do
      printDoc uri d
      modify $ \s ->
        s { history = (take (historyDepth $ conf s) $ n : prev, next) }
    _ -> putErrLn "Nowhere to go"
command More = do
  st <- get
  unless (embedded st) $ do
    term <- liftIO setupTermFromEnv
    let lineCount' = fromMaybe 25 (getCapability term termLines)
        lineCount = lineCount' - div lineCount' 3
    showLines $ take lineCount $ drop (position st) (rLines $ rendered st)
    modify (\s -> s { position = position st + lineCount })
command Reload = do
  st <- get
  case history st of
    ((u, _):prev, next) -> do
      (uri, d) <- loadDocument Nothing u
      case d of
        Nothing -> pure ()
        Just doc -> do
          printDoc uri doc
          modify $ \s -> s { history = ( (u, doc):prev, next ) }
    _ -> putErrLn "There's nothing to reload"
command Help = do
  st <- get
  putErrLn $ intercalate "\n"
    [ "[q]uit, [b]ack, [f]orward, [h]elp, [r]eload, [re]load config"
    , "\"[.]<number>\" to follow a link, \"?<number>\" to print its URI"
    , "type an URI (absolute or relative) to open it"
    , "prefix it with a type (html, txt, org, etc) to choose a reader"]
  when (paginate $ conf st) $ putErrLn "RET to scroll"
command (Show n) = do
  st <- get
  putErrLn $ if length (rLinks $ rendered st) > n
             then show $ rLinks (rendered st) !! n
             else "No such link"
command ShowCurrent = do
  st <- get
  case history st of
    ((u, _):_, _) -> putErrLn $ show u
    _ -> pure ()
command (Shortcut u q) = command . GoTo Nothing . fromJust . parseURI $
  u ++ escapeURIString isUnreserved q
command ReloadConfig = updateConfig
command Quit = liftIO $ do
  dir <- getXdgDirectory XdgCache "pancake"
  exists <- doesDirectoryExist dir
  when exists $ removeDirectoryRecursive dir
command Interrupt =
  putErrLn "Received SIGINT. Interrupt twice in a row to quit."

-- | Reads commands, runs them.
eventLoop :: MonadIO m => StateT LoopState m ()
eventLoop = do
  st <- get
  c <- liftIO $ catches (parseCommand (conf st) <$> getLine)
       [Handler handleIO, Handler handleAsync]
  unless (c == Interrupt && interrupted st) $ do
    command c
    modify $ \s -> s { interrupted = c == Interrupt }
    when (c /= Quit) eventLoop
  where
    handleIO :: IOException -> IO Command
    handleIO e = unless (isEOFError e)
                 (putErrLn ("Unexpected error: " ++ show e))
                 >> pure Quit
    handleAsync :: AsyncException -> IO Command
    handleAsync UserInterrupt = pure Interrupt
    handleAsync other = throw other

-- | Command-line options.
data Option = OVersion | OHelp | OEmbedded deriving (Show)

-- | Command-line option descriptions for 'getOpt'.
options :: [OptDescr Option]
options = [ Option [] ["version"] (NoArg OVersion) "show version number and exit"
          , Option [] ["help"] (NoArg OHelp) "show help message and exit"
          , Option ['e'] ["embedded"] (NoArg OEmbedded)
            "run in the embedded mode" ]

-- | Loads configuration and runs 'eventLoop'.
main :: IO ()
main = do
  args <- getArgs
  -- A hack to receive SIGINT reliably.
  tid <- myThreadId
  _ <- installHandler sigINT (Catch (throwTo tid UserInterrupt)) Nothing
  let run e = runStateT (updateConfig >> eventLoop)
              (LS ([],[]) 0 [] def e False)
              >> pure ()
  case getOpt Permute options args of
    ([], [], []) -> run False
    ([OEmbedded], [], []) -> run True
    ([OVersion], [], []) -> putStrLn $ "pancake " ++ showVersion version
    _ -> putStrLn $ usageInfo "Usage: pancake [option ...]" options