summaryrefslogtreecommitdiff
path: root/System
diff options
context:
space:
mode:
authorpharpend <>2015-05-16 15:45:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-05-16 15:45:00 (GMT)
commit2bebe448d9f167367d5ef84de93affa781360a13 (patch)
tree7576c474630ca32bc205d9e118b8c9d09ea22b1f /System
version 0.1.0.00.1.0.0
Diffstat (limited to 'System')
-rw-r--r--System/Pager.hs97
1 files changed, 97 insertions, 0 deletions
diff --git a/System/Pager.hs b/System/Pager.hs
new file mode 100644
index 0000000..ca80e17
--- /dev/null
+++ b/System/Pager.hs
@@ -0,0 +1,97 @@
+{-# 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.Text (Text)
+import qualified Data.Monoid (mconcat, mempty)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Safe
+import System.Directory
+import System.Exit
+import System.IO
+import System.Posix.ByteString
+import System.Process
+
+-- |Send a lazy 'Bl.ByteString' to the user's @$PAGER@.
+sendToPager :: Bl.ByteString -> IO ()
+sendToPager bytes = sendToPagerConduit (sourceLbs 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 ()