summaryrefslogtreecommitdiff
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
version 0.1.0.00.1.0.0
-rw-r--r--LICENSE26
-rw-r--r--README.md18
-rw-r--r--Setup.hs2
-rw-r--r--System/Pager.hs97
-rw-r--r--pager.cabal63
-rw-r--r--test/main.hs20
6 files changed, 226 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c38ee75
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,26 @@
+Copyright (c) 2015, Peter Harpending
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..39721ef
--- /dev/null
+++ b/README.md
@@ -0,0 +1,18 @@
+pager
+=====
+
+This is a Haskell library to open up the user's `$PAGER` with some
+text. On Linux, the pager is usually called `less`. On the various
+*BSD's, the pager is called `more`.
+
+The pager doesn't notify people or anything - it takes long output and
+presents it in pages.
+
+This library is licensed under the FreeBSD license (the 2-clause BSD
+license). Read the LICENSE file for details.
+
+Contact
+-------
+
+* Email: `peter@harpending.org`
+* IRC: `pharpend` on FreeNode and OFTC
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
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 ()
diff --git a/pager.cabal b/pager.cabal
new file mode 100644
index 0000000..b30a78e
--- /dev/null
+++ b/pager.cabal
@@ -0,0 +1,63 @@
+name: pager
+version: 0.1.0.0
+synopsis: Open up a pager, like 'less' or 'more'
+description:
+ This opens up the user's $PAGER. On Linux, this is usually called @less@. On
+ the various BSDs, this is usually @more@.
+homepage: https://github.com/pharpend/pager
+license: BSD2
+license-file: LICENSE
+author: Peter Harpending
+maintainer: peter@harpending.org
+bug-reports: https://github.com/pharpend/pager
+copyright: Copyright (c) 2015, Peter Harpending.
+category: Data, System, Text
+build-type: Simple
+cabal-version: >=1.10
+extra-source-files:
+ README.md
+ LICENSE
+data-files:
+ LICENSE
+
+source-repository head
+ type: git
+ location: https://github.com/pharpend/pager.git
+
+source-repository this
+ type: git
+ location: https://github.com/pharpend/pager.git
+ tag: 0.1.0.0
+
+library
+ other-extensions:
+ LambdaCase
+ MultiWayIf
+ OverloadedStrings
+ default-language: Haskell2010
+ exposed-modules:
+ System.Pager
+ build-depends:
+ base ==4.*
+ , bytestring
+ , conduit >=1.2.3
+ , conduit-extra
+ , directory
+ , process
+ , resourcet
+ , safe
+ , unix
+ , text
+ , transformers
+
+executable hs-pager-test-pager
+ default-language: Haskell2010
+ hs-source-dirs: test
+ other-modules: Paths_pager
+ main-is: main.hs
+ build-depends:
+ base ==4.*
+ , bytestring
+ , conduit-extra
+ , pager
+
diff --git a/test/main.hs b/test/main.hs
new file mode 100644
index 0000000..67ced70
--- /dev/null
+++ b/test/main.hs
@@ -0,0 +1,20 @@
+import qualified Data.ByteString.Lazy as B
+import Data.Conduit.Binary
+import Paths_pager
+import System.Pager
+
+testConduit :: FilePath -> IO ()
+testConduit fnom =
+ sendToPagerConduit (sourceFile fnom)
+
+test :: FilePath -> IO ()
+test fp = B.readFile fp >>= sendToPager
+
+main =
+ do fnom <- getDataFileName "LICENSE"
+ putStrLn "Hit Return to start the conduit-free test"
+ _ <- getLine
+ test fnom
+ putStrLn "Hit Return to start the conduit test"
+ _ <- getLine
+ testConduit fnom