summaryrefslogtreecommitdiff
path: root/Pancake.hs
blob: f8b9d199309cb6a41381a59e517d97b116ae75c9 (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
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
{-
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.

-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}

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.Strict
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 Control.Applicative
import Data.Version
import System.Console.GetOpt
import Text.Regex.TDFA
import qualified System.Console.Haskeline as HL

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])

-- | A history entry.
data HistoryEntry = HE { hURI :: URI
                       , hDoc :: P.Pandoc
                       , hPos :: Int
                       }

-- | Main event loop's state.
data LoopState = LS { history :: Sliding HistoryEntry
                    , position :: Int
                    , rendered :: [RendererOutput]
                    , conf :: Config
                    , embedded :: Bool
                    , noWrap :: Bool
                    , interrupted :: Bool
                    , unclutterRegexps :: [(Regex, String)]
                    , columns :: Maybe Int
                    }

-- | Main event loop's type.
type Pancake a = forall m. HL.MonadException m => StateT LoopState m a

-- | Renders a parsed document.
printDoc :: URI -> P.Pandoc -> Pancake ()
printDoc uri doc = do
  term <- liftIO setupTermFromEnv
  st <- get
  let cols = fromMaybe 80 $ columns st <|> getCapability term termColumns
      l = renderDoc cols (noWrap st) (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 :: Maybe FilePath -> Pancake ()
updateConfig mp = do
  c <- loadConfig mp
  u <- prepareUnclutter c
  modify $ \s -> s { conf = c, unclutterRegexps = u }

-- | A wrapper around 'retrieve' that adjusts the URI.
loadRaw :: URI -> Pancake (URI, Maybe (BS.ByteString, Maybe URI, Maybe String))
loadRaw rawURI = do
  st <- get
  let ddg = isInfixOf "/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, (h:_, _)) -> relativeTo rawURI (hURI h)
        _ -> 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 :: Maybe String
             -- ^ Document type.
             -> URI
             -- ^ Document URI.
             -> Pancake (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 occurred. Exit code: " ++ show ec
          pure (effectiveURI, mzero)

-- | Visits an URI, updates history accordingly.
goTo :: Maybe String -> URI -> Pancake ()
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) $ HE uri doc 0:prev, [])}

-- | Line number to a fixed block's number.
lineToBlockNumber :: [(Int, Int)] -> Int -> Int
lineToBlockNumber bs n =
  case filter (\(_, (f, l)) -> f <= n && n < l) (zip [0..] bs) of
    [] -> 0
    xs -> fst $ maximumBy (\(_, (l, _)) (_, (l', _)) -> compare l l') xs

-- | Fixed block's number to line number.
blockNumberToLine :: [(Int, Int)] -> Int -> Int
blockNumberToLine bs p
  | length bs <= p = 1
  | otherwise = fst $ bs !! p

-- | Scrolls to a line, which would be at the bottom for CLI.
scrollToLine :: Int -> Pancake ()
scrollToLine n = get >>= \st -> when (n > position st || embedded st) $ do
  -- update history entry's position
  case history st of
    (h : prev, next) -> modify $ \s ->
      s {history =
         (h {hPos = lineToBlockNumber (rBlocks $ rendered st) n}:prev, next)}
    _ -> pure ()
  -- go to line
  if embedded st
    then putSexpLn ["goto", show n]
    else do
    showLines $ take (n - position st) $
      drop (position st) (rLines $ rendered st)
    modify (\s -> s { position = n })

-- | Scrolls to a fixed block's position.
scrollToBlock :: Int -> Pancake ()
scrollToBlock b = get
  >>= \s -> scrollToLine $ blockNumberToLine (rBlocks $ rendered s) b

-- | Evaluates user commands.
command :: Command -> Pancake ()
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
    (h:_, _) -> command $ Save (RURI $ hURI h) 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
  term <- liftIO setupTermFromEnv
  let lineCount = fromMaybe 25 (getCapability term termLines)
  maybe (putErrLn $ "Unknown identifier: " ++ xs)
    (\pos -> scrollToLine $ if embedded st then pos else pos + lineCount - 2)
    (lookup xs (rIdentifiers $ rendered st))
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:h:prev, next) -> do
      printDoc (hURI h) (hDoc h)
      scrollToBlock (hPos h)
      modify $ \s ->
        s { history = (h:prev, take (historyDepth $ conf s) $ cur : next) }
    _ -> putErrLn "There's nothing back there"
command Forward = do
  st <- get
  case history st of
    (prev, h:next) -> do
      printDoc (hURI h) (hDoc h)
      scrollToBlock (hPos h)
      modify $ \s ->
        s { history = (take (historyDepth $ conf s) $ h: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)
    scrollToLine (position st + lineCount - 3)
command (GoTo t RCurrent) = do
  st <- get
  case history st of
    (h : prev, next) -> do
      (uri, d) <- loadDocument t (hURI h)
      case d of
        Nothing -> pure ()
        Just doc -> do
          printDoc uri doc
          scrollToBlock (hPos h)
          modify $ \s -> s {history = (HE (hURI h) doc (hPos h) : 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
    (h:_, _) -> putErrLn $ show (hURI h)
    _ -> pure ()
command (Shortcut u q) = command . GoTo Nothing . RURI . fromJust . parseURI $
  u ++ escapeURIString isUnreserved q
command (LoadConfig p) = updateConfig p
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 (SetPos mp) = let p = fromMaybe 0 mp in modify $ \s ->
  s { position = p
    , history =
      case history s of
        (h:prev, next) ->
          (h { hPos = lineToBlockNumber (rBlocks $ rendered s) p } : prev, next)
        other -> other}
command Redisplay = do
  st <- get
  case history st of
    (h:_, _) -> do
      printDoc (hURI h) (hDoc h)
      scrollToBlock (hPos h)
    _ -> putErrLn "There's nothing to redisplay"


-- | Reads commands, runs them with 'command'.
eventLoop :: HL.MonadException m => HL.InputT (StateT LoopState m) ()
eventLoop = do
  st <- lift get
  c <- HL.handleInterrupt (pure Interrupt) $
    maybe Quit (parseCommand (conf st))
    <$> HL.withInterrupt (HL.getInputLine "")
  unless (c == Interrupt && interrupted st) $ do
    lift $ command c
    lift $ modify $ \s -> s { interrupted = c == Interrupt }
    when (c /= Quit) eventLoop

-- | Extracts URI strings from history.
historyURIs :: Pancake [String]
historyURIs = do
  hist <- history <$> get
  pure $ map ((\u -> uriToString id u "") . hURI) $ uncurry (++) hist

-- | An input completion function.
complete :: HL.MonadException m => HL.CompletionFunc (StateT LoopState m)
complete (l, r) = do
  uriStrings <- historyURIs
  pure $ complete' (reverse l) r uriStrings
  where
    complete' ('*':str) "" us =
      ("", map (\s -> HL.Completion s s False) $ filter (isInfixOf str) us)
    complete' str "" us =
      ("", map (\s -> HL.Completion s s False) $ filter (isPrefixOf str) us)
    complete' s _ _ = (s, [])

-- | Command-line options.
data Option = OVersion
            | OHelp
            | OEmbedded
            | ONoWrap
            | OConfig FilePath
  deriving (Show, Eq)

-- | 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"
          , Option ['n'] ["no-wrap"] (NoArg ONoWrap)
            "leave line wrapping to UI when appropriate"
          , Option ['c'] ["config"] (ReqArg OConfig "FILE")
            "load configuration from a specified file"
          ]

-- | Loads configuration and runs 'eventLoop'.
main :: IO ()
main = do
  args <- getArgs
  let (opts, cmd, errors) = getOpt Permute options args
      run
        | OVersion `elem` opts = putStrLn $ "pancake " ++ showVersion version
        | OHelp `elem` opts || not (null errors) = do
            mapM_ putErrLn errors
            p <- getProgName
            putStrLn $ usageInfo
              ("Usage: " ++ p ++ " [option ...] [command ...]") options
        | otherwise = do
            let maybeCommand =
                  if null cmd
                  then pure ()
                  else get
                       >>= \st -> command (parseCommand (conf st) (unwords cmd))
            dir <- getXdgDirectory XdgConfig "pancake"
            let hfn = dir </> "command_history"
            _ <- runStateT
                 (HL.runInputT
                  (HL.setComplete complete HL.defaultSettings)
                  {HL.historyFile = Just hfn}
                  (lift (updateConfig (findConf opts))
                   >> lift maybeCommand
                   >> eventLoop))
                 LS { history = ([],[])
                    , position = 0
                    , rendered = []
                    , conf = def
                    , embedded = OEmbedded `elem` opts
                    , noWrap = ONoWrap `elem` opts
                    , interrupted = False
                    , unclutterRegexps = []
                    , columns = Nothing
                    }
            pure ()
  run
  where
    findConf :: [Option] -> Maybe FilePath
    findConf [] = Nothing
    findConf (OConfig fp:_) = Just fp
    findConf (_:xs) = findConf xs