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
|
{- |
Module : Pancake.Reading
Maintainer : defanor <defanor@uberspace.net>
Stability : unstable
Portability : non-portable (GHC extensions are used)
Document retrieval and parsing.
-}
{-# LANGUAGE ScopedTypeVariables #-}
module Pancake.Reading ( retrieve
, readDoc
) where
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
import Network.URI
import qualified Text.Pandoc as P
import System.Process
import Control.Exception (handle, SomeException)
import Control.Applicative ((<|>))
import Data.Text.Encoding (decodeUtf8', decodeLatin1)
import Data.Default
import System.Console.Terminfo (setupTermFromEnv, getCapability, termColumns)
import System.FilePath
import Data.Char
import System.Exit
import System.Environment
import GHC.IO.Handle
import Text.Parsec hiding ((<|>))
import Text.Parsec.ByteString
import Data.Maybe
import Text.Pandoc.Readers.Plain
import Text.Pandoc.Readers.Gopher
import Pancake.Common
-- | Metadata (header, URI, document type) parser.
pMeta :: Parser (Maybe URI, Maybe String)
pMeta = do
_ <- newline
_ <- string "-pancake-"
_ <- newline
u <- optionMaybe $ do
_ <- string "uri: "
u <- manyTill anyToken newline
maybe (fail "Failed to parse URI") pure $ parseURI u
t <- option Nothing $ do
_ <- string "type: "
optional $ try $ manyTill alphaNum (char '/')
t <- optionMaybe $ many1 $ choice [alphaNum, char '-']
_ <- manyTill anyToken newline
pure t
eof
pure (u, t)
-- | Document body + metadata parser.
pWithMeta :: Parser (BS.ByteString, (Maybe URI, Maybe String))
pWithMeta = (,) . BS.pack <$> manyTill anyToken (try $ lookAhead pMeta)
<*> pMeta
-- | Retrieves a document. Prints an error message and returns an
-- empty string on failure.
retrieve :: String
-- ^ Shell command to use for retrieval.
-> URI
-- ^ Document URI.
-> IO (Maybe (BS.ByteString, Maybe URI, Maybe String))
-- ^ Document contents.
retrieve cmd uri = do
putErrLn $ "Retrieving " ++ show uri
curEnv <- getEnvironment
let envAuthority = maybe [] (\x -> [ ("URI_USERINFO", uriUserInfo x)
, ("URI_REGNAME", uriRegName x)
, ("URI_PORT", uriPort x) ])
(uriAuthority uri)
environment = ("URI", uriToString id uri "")
: ("URI_SCHEME", uriScheme uri)
: ("URI_PATH", uriPath uri)
: ("URI_QUERY", uriQuery uri)
: ("URI_FRAGMENT", uriFragment uri)
: curEnv
++ envAuthority
handle (\(e :: SomeException) ->
putErrLn (concat ["Failed to run `", cmd, "`: ", show e])
>> pure Nothing) $
withCreateProcess ((shell cmd) { env = Just environment
, std_out = CreatePipe
, std_err = CreatePipe
, delegate_ctlc = True }) $
\_ stdout stderr ph -> case stdout of
Nothing -> putErrLn "No stdout" >> pure Nothing
Just stdout' -> do
hSetBinaryMode stdout' True
out <- BS.hGetContents stdout'
ec <- waitForProcess ph
if ec /= ExitSuccess
then do
putErrLn $ "An error occured. Exit code: " ++ show ec
case stderr of
Nothing -> pure ()
Just stderr' -> do
err <- BS.hGetContents stderr'
putErrLn $ "stderr:\n" ++ BS.unpack err
else putErrLn $ show uri
case parse pWithMeta (uriToString id uri "") out of
Left _ -> pure $ Just (out, Nothing, Nothing)
Right (bs, (u, t)) -> pure $ Just (bs, u, t)
-- | An Emacs file variable parser. Extracts a mode if it's set.
pEmacsMode :: Parser String
pEmacsMode = do
_ <- manyTill (noneOf "\r\n") (string "-*-")
spaces
vs <- try fileVariable `sepEndBy` (char ';' >> spaces)
spaces
_ <- string "-*-"
maybe (fail "no mode variable found") pure (lookup "mode" vs)
where
fileVariable :: Parser (String, String)
fileVariable = do
-- this is restrictive, but should suffice for idiomatic names
name <- many1 (choice [alphaNum, char '-'])
char ':' >> spaces
val <- reverse . dropWhile isSpace . reverse <$> manyTill anyChar
(choice $ map (try . lookAhead . string) [";", "\n", "-*-"])
pure (name, val)
-- | Parses a document into a Pandoc structure. The parser is chosen
-- depending on the document type (if one is provided) or its URI.
readDoc :: BS.ByteString
-- ^ Raw document data.
-> Maybe String
-- ^ Document type.
-> URI
-- ^ Document URI.
-> IO (Either P.PandocError P.Pandoc)
-- ^ A parsed document.
readDoc out dt uri = do
term <- setupTermFromEnv
let (reader, exts) = either (const plain) id $
maybe (Left "no type suggestions") byExtension dt
<|> case (uriScheme uri, map toLower $ takeExtension $ uriPath uri) of
-- some exceptions and special cases (might be better to make
-- this configurable)
("http:", ext) -> http ext
("https:", ext) -> http ext
("gopher:", ext) -> case uriPath uri of
('/':'1':_) -> gopher
('/':'h':_) -> html
-- "0" should indicate plain text, but it's also the most
-- suitable option for non-html markup. Not sure about this
-- approach, but it's similar to ignoring HTTP content-type,
-- and will do for now: better to render documents nicely
-- when possible.
('/':'0':_) -> byExtension' ext
-- unknown or unrecognized item type
_ -> byExtension' ext <|> gopher
(_, ext) -> byExtension' ext
<|> either (Left . show) byExtension
(parse pEmacsMode (uriToString id uri "") out)
cols = fromMaybe 80 $ getCapability term termColumns
opts = def { P.readerColumns = cols, P.readerExtensions = exts }
case reader of
P.TextReader f -> case decodeUtf8' out of
Left err -> do
putErrLn $ show err
P.runIO $ f opts $ decodeLatin1 out
Right r -> P.runIO $ f opts r
P.ByteStringReader f -> P.runIO $ f opts $ BL.fromStrict out
where
http ext = byExtension' ext <|> html
html = P.getReader "html"
plain = (P.TextReader . const $ readPlain, P.emptyExtensions)
gopher = pure (P.TextReader . const $ readGopher, P.emptyExtensions)
byExtension' ext = byExtension $ dropWhile (== '.') ext
byExtension "md" = P.getReader "markdown"
byExtension "htm" = html
byExtension "ltx" = P.getReader "latex"
byExtension "tex" = P.getReader "latex"
byExtension "txt" = pure plain
byExtension "plain" = pure plain
byExtension ext = P.getReader ext
|
