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
|
{-# LANGUAGE MultiWayIf, LambdaCase, OverloadedStrings, RankNTypes #-}
-- |
-- Module : System.Pager
-- Description : Send stuff to the user's $PAGER.
-- Copyright : Copyright (c) 2015, Peter Harpending.
-- License : BSD2
-- Maintainer : Peter Harpending <peter@harpending.org>
-- Stability : experimental
-- Portability : Tested with GHC on Linux and FreeBSD
--
module System.Pager where
import Control.Monad (forM)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Char8 (unpack)
import qualified Data.ByteString.Lazy as Bl
import Data.Conduit
import Data.Conduit.Binary
import Data.List
import qualified Data.Monoid (mconcat, mempty)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO
import Safe
import System.Directory
import System.Exit
import System.IO
import System.Posix.ByteString
import System.Process
import System.Console.Terminfo
-- |If the user's terminal is long enough to display the (strict)
-- 'Text', just print it. Else, send it to the pager.
--
-- The text needs to be strict, because the function counts the number
-- of lines in the text. (This is also why it needs to be text, and not
-- a bytestring, because Text has stuff like line-counting).
printOrPage :: Text -> IO ()
printOrPage text =
do terminal <- setupTermFromEnv
let linesInTerminal =
getCapability terminal termLines
columnsInTerminal =
getCapability terminal termColumns
linesInText = length (T.lines text)
columnsInText =
last (sort (fmap T.length (T.lines text)))
usePager =
case (columnsInTerminal,linesInTerminal) of
(Nothing,_) -> True
(_,Nothing) -> True
(Just x,Just y)
| or [x <= columnsInText,y <= linesInText] -> True
| otherwise -> False
if usePager
then sendToPagerStrict (TE.encodeUtf8 text)
else TIO.putStr text
-- |Send a lazy 'Bl.ByteString' to the user's @$PAGER@.
sendToPager :: Bl.ByteString -> IO ()
sendToPager bytes =
sendToPagerConduit (sourceLbs bytes)
-- |Send a strict 'B.ByteString' to the user's @$PAGER@.
sendToPagerStrict :: B.ByteString -> IO ()
sendToPagerStrict bytes =
sendToPagerConduit (sourceLbs (Bl.fromStrict bytes))
-- |This finds the user's @$PAGER@. This will fail if:
--
-- * There is no @$PATH@ variable
-- * The user doesn't have a @less@ or @more@ installed, and hasn't
-- specified an alternate program via @$PAGER@.
--
findPager :: IO ByteString
findPager =
getEnv "PAGER" >>=
\case
Just x -> return x
Nothing ->
getEnv "PATH" >>=
\case
Nothing ->
fail "There is no $PATH, so I can't see if 'less' or 'more' is installed."
Just p ->
do let pathText = TE.decodeUtf8 p
pathPieces =
T.splitOn ":" pathText
searchForLess <-
fmap mconcat
(forM pathPieces
(\pathPiece ->
do dirExists <-
doesDirectoryExist (T.unpack pathPiece)
filesInDir <-
if | dirExists ->
getDirectoryContents (T.unpack pathPiece)
| otherwise -> return mempty
return (filter (\x ->
(x == "less") ||
(x == "more"))
filesInDir)))
if | searchForLess == mempty ->
fail "There doesn't appear to be any pager installed."
| elem "less" searchForLess ->
return "less"
| otherwise -> return "more"
-- |This is what 'sendToPager' uses on the back end. It takes a
-- 'Producer', from "Data.Conduit", and then sends the produced bytes to
-- the pager's stdin.
sendToPagerConduit :: Producer (ResourceT IO) ByteString -> IO ()
sendToPagerConduit producer =
do pager <- fmap unpack findPager
((Just stdinH),_,(Just stderrH),ph) <-
createProcess
((shell pager) {std_in = CreatePipe
,std_err = CreatePipe})
runResourceT (connect producer (sinkHandle stdinH))
hClose stdinH
exitCode <- waitForProcess ph
case exitCode of
ExitFailure i ->
do errContents <- hGetContents stderrH
fail (unlines [mappend "Pager exited with exit code " (show i)
,errContents])
ExitSuccess -> return ()
|
