summaryrefslogtreecommitdiffstats
path: root/Pancake.hs
blob: e854d13575045747cfe9be6097a42446fd983ae7 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
{-
Copyright (C) 2017  defanor <defanor@uberspace.net>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

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

A CLI\/Emacs web\/gopher\/file browser inspired by LMB.

-}

{-# 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 Text.Regex.TDFA

import Pancake.Common
import Pancake.Configuration
import Pancake.Command
import Pancake.Reading
import Pancake.Rendering
import Pancake.Printing
import Pancake.Unclutter
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
                    , unclutterRegexps :: [(Regex, String)]
                    , columns :: Maybe Int
                    }

-- | 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 $ columns st <|> 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
  u <- prepareUnclutter c
  modify $ \s -> s { conf = c, unclutterRegexps = u }

-- | A wrapper around 'retrieve' that adjusts the URI.
loadRaw :: MonadIO m => URI ->
  StateT LoopState m (URI, Maybe (BS.ByteString, Maybe URI, Maybe String))
loadRaw 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)
  doc <- liftIO $ retrieve cmd adjustedURI
  pure (adjustedURI, doc)

-- | 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
  (adjustedURI, docData) <- loadRaw rawURI
  case docData of
    Nothing -> pure (adjustedURI, mzero)
    Just (rawDoc, mdURI, mdType) -> liftIO $ 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
          uDoc <- tryUnclutter (unclutterRegexps st) effectiveURI rawDoc
          doc <- readDoc uDoc 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 (Save (RURI uri') p) = do
  (uri, mraw) <- loadRaw uri'
  st <- get
  case mraw of
    Nothing -> pure ()
    Just (raw, euri, _) -> liftIO $ do
      (targetDir, mTargetName) <- case p of
        Nothing -> do
          cacheDir <- getXdgDirectory XdgCache "pancake"
          pure (cacheDir, Nothing)
        Just fp -> do
          exists <- doesDirectoryExist fp
          pure $ case (exists, takeFileName fp) of
            (True, _) -> (fp, Nothing)
            (_, "") -> (fp, Nothing)
            (False, fn) -> (takeDirectory fp, pure fn)
      createDirectoryIfMissing True targetDir
      let remoteURI = fromMaybe uri euri
          remoteURIStr = uriToString id remoteURI ""
          remoteFileName' = takeFileName $ uriPath remoteURI
          remoteFileName = if remoteFileName' `elem` [".", "..", ""]
                           then map escapeURI remoteURIStr
                           else remoteFileName'
          targetFileName = fromMaybe remoteFileName mTargetName
          targetPath = targetDir </> targetFileName
      e <- try $ BS.writeFile targetPath raw
      case e of
        Left (err :: SomeException) ->
          putErrLn $ unwords ["Failed to write", targetPath ++ ":", show err]
        Right () -> do
          when (embedded st) $
            putSexpLn [ "saved"
                      , encodeSexpStr $ uriToString id uri' ""
                      , encodeSexpStr targetPath]
          putErrLn $ unwords ["Saved", remoteURIStr, "as", targetPath]
  where
    escapeURI c
      | isPathSeparator c = '-'
      | otherwise = c
command (Save (RNumber i) p) = do
  st <- get
  if length (rLinks $ rendered st) > i
    then command $ Save (RURI $ rLinks (rendered st) !! i) p
    else putErrLn "No such link"
command (Save RCurrent p) = do
  st <- get
  case history st of
    ((u, _):_, _) -> command $ Save (RURI u) p
    _ -> pure ()
command (GoTo t (RURI 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 (RURI u)) = goTo t u
command (GoTo t (RNumber i)) = do
  st <- get
  if length (rLinks $ rendered st) > i
    then command (GoTo t $ RURI $ 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 (GoTo t RCurrent) = do
  st <- get
  case history st of
    ((u, _):prev, next) -> do
      (uri, d) <- loadDocument t 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"
    [ "basic commands: [ and ] to go back or forward, ',' to reload"
    , "<URI> or [,]<number> to open a document" ]
  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 . RURI . 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."
command (SetWidth w) = modify $ \s -> s { columns = w }
command Redisplay = do
  st <- get
  case history st of
    ((uri, doc):_, _) -> printDoc uri doc
    _ -> putErrLn "There's nothing to redisplay"


-- | 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 [] Nothing)
              >> pure ()
  case getOpt Permute options args of
    ([], [], []) -> run False
    ([OEmbedded], [], []) -> run True
    ([OVersion], [], []) -> putStrLn $ "pancake " ++ showVersion version
    _ -> do
      p <- getProgName
      putStrLn $ usageInfo ("Usage: " ++ p ++ " [option ...]") options