1{-# LANGUAGE DeriveDataTypeable, CPP, MultiParamTypeClasses,
2 FlexibleContexts, ScopedTypeVariables, PatternGuards,
5Copyright (C) 2006-2016 John MacFarlane <jgm@berkeley.edu>
7This program is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2 of the License, or
10(at your option) any later version.
12This program is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
17You should have received a copy of the GNU General Public License
18along with this program; if not, write to the Free Software
19Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23 Module : Text.Pandoc.Shared
24 Copyright : Copyright (C) 2006-2016 John MacFarlane
25 License : GNU GPL, version 2 or above
27 Maintainer : John MacFarlane <jgm@berkeley.edu>
29 Portability : portable
31Utility functions and definitions used by the various Pandoc modules.
33module Text.Pandoc.Shared (
43 stripTrailingNewlines,
48 camelCaseToHyphenated,
54 -- * Pandoc block and inline list processing
67 inlineListToIdentifier,
73 -- * TagSoup HTML handling
77 getDefaultReferenceDocx,
78 getDefaultReferenceODT,
83 filteredFilesFromArchive,
87 -- * for squashing blocks
97import Text.Pandoc.Definition
98import Text.Pandoc.Walk
99import Text.Pandoc.Builder (Inlines, Blocks, ToMetaValue(..))
100import qualified Text.Pandoc.Builder as B
101import qualified Text.Pandoc.UTF8 as UTF8
102import System.Exit (exitWith, ExitCode(..))
103import Data.Char ( toLower, isLower, isUpper, isAlpha,
104 isLetter, isDigit, isSpace )
105import Data.List ( find, stripPrefix, intercalate )
106import Data.Maybe (mapMaybe)
107import Data.Version ( showVersion )
108import qualified Data.Map as M
109import Network.URI ( escapeURIString, unEscapeString )
110import qualified Data.Set as Set
111import System.Directory
112import System.FilePath (splitDirectories, isPathSeparator)
113import qualified System.FilePath.Posix as Posix
114import Text.Pandoc.MIME (MimeType)
115import System.FilePath ( (</>) )
116import Data.Generics (Typeable, Data)
117import qualified Control.Monad.State as S
118import Control.Monad.Trans (MonadIO (..))
119import qualified Control.Exception as E
120import Control.Monad (msum, unless, MonadPlus(..))
121import Text.Pandoc.Pretty (charWidth)
122import Text.Pandoc.Compat.Time
123import Data.Time.Clock.POSIX
124import System.IO (stderr)
125import System.IO.Error
127import Text.HTML.TagSoup (renderTagsOptions, RenderOptions(..), Tag(..),
129import Data.Monoid ((<>))
130import qualified Data.ByteString as BS
131import qualified Data.ByteString.Char8 as B8
132import Data.ByteString.Base64 (decodeLenient)
133import Data.Sequence (ViewR(..), ViewL(..), viewl, viewr)
134import qualified Data.Text as T (toUpper, pack, unpack)
135import Data.ByteString.Lazy (toChunks, fromChunks)
136import qualified Data.ByteString.Lazy as BL
137import Paths_pandoc (version)
139import Codec.Archive.Zip
141#ifdef EMBED_DATA_FILES
142import Text.Pandoc.Data (dataFiles)
144import Paths_pandoc (getDataFileName)
147import Network.HTTP.Client (httpLbs, responseBody, responseHeaders,
148 Request(port,host,requestHeaders))
149import Network.HTTP.Client (parseRequest)
150import Network.HTTP.Client (newManager)
151import Network.HTTP.Client.Internal (addProxy)
152import Network.HTTP.Client.TLS (tlsManagerSettings)
153import System.Environment (getEnv)
154import Network.HTTP.Types.Header ( hContentType, hUserAgent)
155import Network (withSocketsDo)
157import Network.URI (parseURI)
158import Network.HTTP (findHeader, rspBody,
159 RequestMethod(..), HeaderName(..), mkRequest)
160import Network.Browser (browse, setAllowRedirects, setOutHandler, request)
163-- | Version number of pandoc library.
164pandocVersion :: String
165pandocVersion = showVersion version
171-- | Split list by groups of one or more sep.
172splitBy :: (a -> Bool) -> [a] -> [[a]]
175 let (first, rest) = break isSep lst
176 rest' = dropWhile isSep rest
177 in first:(splitBy isSep rest')
179splitByIndices :: [Int] -> [a] -> [[a]]
180splitByIndices [] lst = [lst]
181splitByIndices (x:xs) lst = first:(splitByIndices (map (\y -> y - x) xs) rest)
182 where (first, rest) = splitAt x lst
184-- | Split string into chunks divided at specified indices.
185splitStringByIndices :: [Int] -> [Char] -> [[Char]]
186splitStringByIndices [] lst = [lst]
187splitStringByIndices (x:xs) lst =
188 let (first, rest) = splitAt' x lst in
189 first : (splitStringByIndices (map (\y -> y - x) xs) rest)
191splitAt' :: Int -> [Char] -> ([Char],[Char])
192splitAt' _ [] = ([],[])
193splitAt' n xs | n <= 0 = ([],xs)
194splitAt' n (x:xs) = (x:ys,zs)
195 where (ys,zs) = splitAt' (n - charWidth x) xs
197-- | Replace each occurrence of one sublist in a list with another.
198substitute :: (Eq a) => [a] -> [a] -> [a] -> [a]
199substitute _ _ [] = []
200substitute [] _ xs = xs
201substitute target replacement lst@(x:xs) =
202 case stripPrefix target lst of
203 Just lst' -> replacement ++ substitute target replacement lst'
204 Nothing -> x : substitute target replacement xs
206ordNub :: (Ord a) => [a] -> [a]
207ordNub l = go Set.empty l
210 go s (x:xs) = if x `Set.member` s then go s xs
211 else x : go (Set.insert x s) xs
217-- | Returns an association list of backslash escapes for the
218-- designated characters.
219backslashEscapes :: [Char] -- ^ list of special characters to escape
221backslashEscapes = map (\ch -> (ch, ['\\',ch]))
223-- | Escape a string of characters, using an association list of
224-- characters and strings.
225escapeStringUsing :: [(Char, String)] -> String -> String
226escapeStringUsing _ [] = ""
227escapeStringUsing escapeTable (x:xs) =
228 case (lookup x escapeTable) of
229 Just str -> str ++ rest
231 where rest = escapeStringUsing escapeTable xs
233-- | Strip trailing newlines from string.
234stripTrailingNewlines :: String -> String
235stripTrailingNewlines = reverse . dropWhile (== '\n') . reverse
237-- | Remove leading and trailing space (including newlines) from string.
238trim :: String -> String
241-- | Remove leading space (including newlines) from string.
242triml :: String -> String
243triml = dropWhile (`elem` " \r\n\t")
245-- | Remove trailing space (including newlines) from string.
246trimr :: String -> String
247trimr = reverse . triml . reverse
249-- | Strip leading and trailing characters from string
250stripFirstAndLast :: String -> String
251stripFirstAndLast str =
252 drop 1 $ take ((length str) - 1) str
254-- | Change CamelCase word to hyphenated lowercase (e.g., camel-case).
255camelCaseToHyphenated :: String -> String
256camelCaseToHyphenated [] = ""
257camelCaseToHyphenated (a:b:rest) | isLower a && isUpper b =
258 a:'-':(toLower b):(camelCaseToHyphenated rest)
259camelCaseToHyphenated (a:rest) = (toLower a):(camelCaseToHyphenated rest)
261-- | Convert number < 4000 to uppercase roman numeral.
262toRomanNumeral :: Int -> String
264 | x >= 4000 || x < 0 = "?"
265 | x >= 1000 = "M" ++ toRomanNumeral (x - 1000)
266 | x >= 900 = "CM" ++ toRomanNumeral (x - 900)
267 | x >= 500 = "D" ++ toRomanNumeral (x - 500)
268 | x >= 400 = "CD" ++ toRomanNumeral (x - 400)
269 | x >= 100 = "C" ++ toRomanNumeral (x - 100)
270 | x >= 90 = "XC" ++ toRomanNumeral (x - 90)
271 | x >= 50 = "L" ++ toRomanNumeral (x - 50)
272 | x >= 40 = "XL" ++ toRomanNumeral (x - 40)
273 | x >= 10 = "X" ++ toRomanNumeral (x - 10)
275 | x >= 5 = "V" ++ toRomanNumeral (x - 5)
277 | x >= 1 = "I" ++ toRomanNumeral (x - 1)
280-- | Escape whitespace and some punctuation characters in URI.
281escapeURI :: String -> String
282escapeURI = escapeURIString (not . needsEscaping)
283 where needsEscaping c = isSpace c || c `elem`
284 ['<','>','|','"','{','}','[',']','^', '`']
287-- | Convert tabs to spaces and filter out DOS line endings.
288-- Tabs will be preserved if tab stop is set to 0.
289tabFilter :: Int -- ^ Tab stop
294 go _ ('\n':xs) = '\n' : go tabStop xs
295 go _ ('\r':'\n':xs) = '\n' : go tabStop xs
296 go _ ('\r':xs) = '\n' : go tabStop xs
297 go spsToNextStop ('\t':xs) =
299 then '\t' : go tabStop xs
300 else replicate spsToNextStop ' ' ++ go tabStop xs
303 go spsToNextStop (x:xs) =
304 x : go (spsToNextStop - 1) xs
311-- | Parse a date and convert (if possible) to "YYYY-MM-DD" format. We
312-- limit years to the range 1601-9999 (ISO 8601 accepts greater than
313-- or equal to 1583, but MS Word only accepts dates starting 1601).
314normalizeDate :: String -> Maybe String
315normalizeDate s = fmap (formatTime defaultTimeLocale "%F")
316 (msum $ map (\fs -> parsetimeWith fs s >>= rejectBadYear) formats :: Maybe Day)
317 where rejectBadYear day = case toGregorian day of
318 (y, _, _) | y >= 1601 && y <= 9999 -> Just day
321#if MIN_VERSION_time(1,5,0)
322 parseTimeM True defaultTimeLocale
324 parseTime defaultTimeLocale
326 formats = ["%x","%m/%d/%Y", "%D","%F", "%d %b %Y",
327 "%d %B %Y", "%b. %d, %Y", "%B %d, %Y",
328 "%Y%m%d", "%Y%m", "%Y"]
331-- Pandoc block and inline list processing
334-- | Generate infinite lazy list of markers for an ordered list,
335-- depending on list attributes.
336orderedListMarkers :: (Int, ListNumberStyle, ListNumberDelim) -> [String]
337orderedListMarkers (start, numstyle, numdelim) =
338 let singleton c = [c]
339 nums = case numstyle of
340 DefaultStyle -> map show [start..]
341 Example -> map show [start..]
342 Decimal -> map show [start..]
343 UpperAlpha -> drop (start - 1) $ cycle $
344 map singleton ['A'..'Z']
345 LowerAlpha -> drop (start - 1) $ cycle $
346 map singleton ['a'..'z']
347 UpperRoman -> map toRomanNumeral [start..]
348 LowerRoman -> map (map toLower . toRomanNumeral) [start..]
349 inDelim str = case numdelim of
350 DefaultDelim -> str ++ "."
352 OneParen -> str ++ ")"
353 TwoParens -> "(" ++ str ++ ")"
356-- | Extract the leading and trailing spaces from inside an inline element
357-- and place them outside the element. SoftBreaks count as Spaces for
359extractSpaces :: (Inlines -> Inlines) -> Inlines -> Inlines
361 let contents = B.unMany is
362 left = case viewl contents of
363 (Space :< _) -> B.space
364 (SoftBreak :< _) -> B.softbreak
366 right = case viewr contents of
367 (_ :> Space) -> B.space
368 (_ :> SoftBreak) -> B.softbreak
370 (left <> f (B.trimInlines . B.Many $ contents) <> right)
372-- | Extract inlines, removing formatting.
373removeFormatting :: Walkable Inline a => a -> [Inline]
374removeFormatting = query go . walk deNote
375 where go :: Inline -> [Inline]
376 go (Str xs) = [Str xs]
378 go SoftBreak = [SoftBreak]
379 go (Code _ x) = [Str x]
380 go (Math _ x) = [Str x]
381 go LineBreak = [Space]
384deNote :: Inline -> Inline
385deNote (Note _) = Str ""
388-- | Convert pandoc structure to a string with formatting removed.
389-- Footnotes are skipped (since we don't want their contents in link
391stringify :: Walkable Inline a => a -> String
392stringify = query go . walk deNote
393 where go :: Inline -> [Char]
399 go (RawInline (Format "html") ('<':'b':'r':_)) = " " -- see #2105
403-- | Bring all regular text in a pandoc structure to uppercase.
405-- This function correctly handles cases where a lowercase character doesn't
406-- match to a single uppercase character – e.g. “Straße” would be converted
407-- to “STRASSE”, not “STRAßE”.
408capitalize :: Walkable Inline a => a -> a
410 where go :: Inline -> Inline
411 go (Str s) = Str (T.unpack $ T.toUpper $ T.pack s)
414-- | Change final list item from @Para@ to @Plain@ if the list contains
415-- no other @Para@ blocks. Like compactify, but operates on @Blocks@ rather
417compactify :: [Blocks] -- ^ List of list items (each a list of blocks)
421 let (others, final) = (init items, last items)
422 in case reverse (B.toList final) of
423 (Para a:xs) -> case [Para x | Para x <- concatMap B.toList items] of
424 -- if this is only Para, change to Plain
425 [_] -> others ++ [B.fromList (reverse $ Plain a : xs)]
429-- | Like @compactify@, but acts on items of definition lists.
430compactifyDL :: [(Inlines, [Blocks])] -> [(Inlines, [Blocks])]
432 let defs = concatMap snd items
433 in case reverse (concatMap B.toList defs) of
435 | not (any isPara xs) ->
436 let (t,ds) = last items
437 lastDef = B.toList $ last ds
440 then [B.fromList lastDef]
441 else [B.fromList $ init lastDef ++ [Plain x]]
442 in init items ++ [(t, ds')]
446-- | Combine a list of lines by adding hard linebreaks.
447combineLines :: [[Inline]] -> [Inline]
448combineLines = intercalate [LineBreak]
450-- | Convert a list of lines into a paragraph with hard line breaks. This is
451-- useful e.g. for rudimentary support of LineBlock elements in writers.
452linesToPara :: [[Inline]] -> Block
453linesToPara = Para . combineLines
455isPara :: Block -> Bool
456isPara (Para _) = True
459-- | Data structure for defining hierarchical Pandoc documents
460data Element = Blk Block
461 | Sec Int [Int] Attr [Inline] [Element]
462 -- lvl num attributes label contents
463 deriving (Eq, Read, Show, Typeable, Data)
465instance Walkable Inline Element where
466 walk f (Blk x) = Blk (walk f x)
467 walk f (Sec lev nums attr ils elts) = Sec lev nums attr (walk f ils) (walk f elts)
468 walkM f (Blk x) = Blk `fmap` walkM f x
469 walkM f (Sec lev nums attr ils elts) = do
471 elts' <- walkM f elts
472 return $ Sec lev nums attr ils' elts'
473 query f (Blk x) = query f x
474 query f (Sec _ _ _ ils elts) = query f ils <> query f elts
476instance Walkable Block Element where
477 walk f (Blk x) = Blk (walk f x)
478 walk f (Sec lev nums attr ils elts) = Sec lev nums attr (walk f ils) (walk f elts)
479 walkM f (Blk x) = Blk `fmap` walkM f x
480 walkM f (Sec lev nums attr ils elts) = do
482 elts' <- walkM f elts
483 return $ Sec lev nums attr ils' elts'
484 query f (Blk x) = query f x
485 query f (Sec _ _ _ ils elts) = query f ils <> query f elts
488-- | Convert Pandoc inline list to plain text identifier. HTML
489-- identifiers must start with a letter, and may contain only
490-- letters, digits, and the characters _-.
491inlineListToIdentifier :: [Inline] -> String
492inlineListToIdentifier =
493 dropWhile (not . isAlpha) . intercalate "-" . words .
494 map (nbspToSp . toLower) .
495 filter (\c -> isLetter c || isDigit c || c `elem` "_-. ") .
497 where nbspToSp '\160' = ' '
500-- | Convert list of Pandoc blocks into (hierarchical) list of Elements
501hierarchicalize :: [Block] -> [Element]
502hierarchicalize blocks = S.evalState (hierarchicalizeWithIds blocks) []
504hierarchicalizeWithIds :: [Block] -> S.State [Int] [Element]
505hierarchicalizeWithIds [] = return []
506hierarchicalizeWithIds ((Header level attr@(_,classes,_) title'):xs) = do
508 let lastnum' = take level lastnum
509 let newnum = case length lastnum' of
510 x | "unnumbered" `elem` classes -> []
511 | x >= level -> init lastnum' ++ [last lastnum' + 1]
512 | otherwise -> lastnum ++
513 replicate (level - length lastnum - 1) 0 ++ [1]
514 unless (null newnum) $ S.put newnum
515 let (sectionContents, rest) = break (headerLtEq level) xs
516 sectionContents' <- hierarchicalizeWithIds sectionContents
517 rest' <- hierarchicalizeWithIds rest
518 return $ Sec level newnum attr title' sectionContents' : rest'
519hierarchicalizeWithIds ((Div ("",["references"],[])
520 (Header level (ident,classes,kvs) title' : xs)):ys) =
521 hierarchicalizeWithIds ((Header level (ident,("references":classes),kvs)
522 title') : (xs ++ ys))
523hierarchicalizeWithIds (x:rest) = do
524 rest' <- hierarchicalizeWithIds rest
525 return $ (Blk x) : rest'
527headerLtEq :: Int -> Block -> Bool
528headerLtEq level (Header l _ _) = l <= level
529headerLtEq level (Div ("",["references"],[]) (Header l _ _ : _)) = l <= level
530headerLtEq _ _ = False
532-- | Generate a unique identifier from a list of inlines.
533-- Second argument is a list of already used identifiers.
534uniqueIdent :: [Inline] -> Set.Set String -> String
535uniqueIdent title' usedIdents
536 = let baseIdent = case inlineListToIdentifier title' of
539 numIdent n = baseIdent ++ "-" ++ show n
540 in if baseIdent `Set.member` usedIdents
541 then case find (\x -> not $ numIdent x `Set.member` usedIdents) ([1..60000] :: [Int]) of
543 Nothing -> baseIdent -- if we have more than 60,000, allow repeats
546-- | True if block is a Header block.
547isHeaderBlock :: Block -> Bool
548isHeaderBlock (Header _ _ _) = True
549isHeaderBlock _ = False
551-- | Shift header levels up or down.
552headerShift :: Int -> Pandoc -> Pandoc
553headerShift n = walk shift
554 where shift :: Block -> Block
555 shift (Header level attr inner) = Header (level + n) attr inner
558-- | Detect if a list is tight.
559isTightList :: [[Block]] -> Bool
560isTightList = all firstIsPlain
561 where firstIsPlain (Plain _ : _) = True
562 firstIsPlain _ = False
564-- | Set a field of a 'Meta' object. If the field already has a value,
565-- convert it into a list with the new value appended to the old value(s).
566addMetaField :: ToMetaValue a
571addMetaField key val (Meta meta) =
572 Meta $ M.insertWith combine key (toMetaValue val) meta
573 where combine newval (MetaList xs) = MetaList (xs ++ tolist newval)
574 combine newval x = MetaList [x, newval]
575 tolist (MetaList ys) = ys
578-- | Create 'Meta' from old-style title, authors, date. This is
579-- provided to ease the transition from the old API.
580makeMeta :: [Inline] -> [[Inline]] -> [Inline] -> Meta
581makeMeta title authors date =
582 addMetaField "title" (B.fromList title)
583 $ addMetaField "author" (map B.fromList authors)
584 $ addMetaField "date" (B.fromList date)
588-- TagSoup HTML handling
591-- | Render HTML tags.
592renderTags' :: [Tag String] -> String
593renderTags' = renderTagsOptions
594 renderOptions{ optMinimize = matchTags ["hr", "br", "img",
596 , optRawTag = matchTags ["script", "style"] }
597 where matchTags = \tags -> flip elem tags . map toLower
603-- | Perform an IO action in a directory, returning to starting directory.
604inDirectory :: FilePath -> IO a -> IO a
605inDirectory path action = E.bracket
608 (const $ setCurrentDirectory path >> action)
610getDefaultReferenceDocx :: Maybe FilePath -> IO Archive
611getDefaultReferenceDocx datadir = do
612 let paths = ["[Content_Types].xml",
617 "word/fontTable.xml",
618 "word/footnotes.xml",
619 "word/numbering.xml",
621 "word/webSettings.xml",
623 "word/_rels/document.xml.rels",
624 "word/_rels/footnotes.xml.rels",
625 "word/theme/theme1.xml"]
626 let toLazy = fromChunks . (:[])
627 let pathToEntry path = do epochtime <- (floor . utcTimeToPOSIXSeconds) <$>
629 contents <- toLazy <$> readDataFile datadir
631 return $ toEntry path epochtime contents
632 mbArchive <- case datadir of
633 Nothing -> return Nothing
635 exists <- doesFileExist (d </> "reference.docx")
637 then return (Just (d </> "reference.docx"))
640 Just arch -> toArchive <$> BL.readFile arch
641 Nothing -> foldr addEntryToArchive emptyArchive <$>
642 mapM pathToEntry paths
644getDefaultReferenceODT :: Maybe FilePath -> IO Archive
645getDefaultReferenceODT datadir = do
646 let paths = ["mimetype",
652 "Configurations2/accelerator/current.xml",
653 "Thumbnails/thumbnail.png",
654 "META-INF/manifest.xml"]
655 let pathToEntry path = do epochtime <- floor `fmap` getPOSIXTime
656 contents <- (fromChunks . (:[])) `fmap`
657 readDataFile datadir ("odt/" ++ path)
658 return $ toEntry path epochtime contents
659 mbArchive <- case datadir of
660 Nothing -> return Nothing
662 exists <- doesFileExist (d </> "reference.odt")
664 then return (Just (d </> "reference.odt"))
667 Just arch -> toArchive <$> BL.readFile arch
668 Nothing -> foldr addEntryToArchive emptyArchive <$>
669 mapM pathToEntry paths
672readDefaultDataFile :: FilePath -> IO BS.ByteString
673readDefaultDataFile "reference.docx" =
674 (BS.concat . toChunks . fromArchive) <$> getDefaultReferenceDocx Nothing
675readDefaultDataFile "reference.odt" =
676 (BS.concat . toChunks . fromArchive) <$> getDefaultReferenceODT Nothing
677readDefaultDataFile fname =
678#ifdef EMBED_DATA_FILES
679 case lookup (makeCanonical fname) dataFiles of
680 Nothing -> err 97 $ "Could not find data file " ++ fname
681 Just contents -> return contents
682 where makeCanonical = Posix.joinPath . transformPathParts . splitDirectories
683 transformPathParts = reverse . foldl go []
688 getDataFileName fname' >>= checkExistence >>= BS.readFile
689 where fname' = if fname == "MANUAL.txt" then fname else "data" </> fname
691checkExistence :: FilePath -> IO FilePath
692checkExistence fn = do
693 exists <- doesFileExist fn
696 else err 97 ("Could not find data file " ++ fn)
699-- | Read file from specified user data directory or, if not found there, from
700-- Cabal data directory.
701readDataFile :: Maybe FilePath -> FilePath -> IO BS.ByteString
702readDataFile Nothing fname = readDefaultDataFile fname
703readDataFile (Just userDir) fname = do
704 exists <- doesFileExist (userDir </> fname)
706 then BS.readFile (userDir </> fname)
707 else readDefaultDataFile fname
709-- | Same as 'readDataFile' but returns a String instead of a ByteString.
710readDataFileUTF8 :: Maybe FilePath -> FilePath -> IO String
711readDataFileUTF8 userDir fname =
712 UTF8.toString `fmap` readDataFile userDir fname
714-- | Read from a URL and return raw data and maybe mime type.
715openURL :: String -> IO (BS.ByteString, Maybe MimeType)
717 | Just u'' <- stripPrefix "data:" u =
718 let mime = takeWhile (/=',') u''
719 contents = B8.pack $ unEscapeString $ drop 1 $ dropWhile (/=',') u''
720 in return (decodeLenient contents, Just mime)
722 | otherwise = withSocketsDo $ do
723 let parseReq = parseRequest
724 (proxy :: Either IOError String) <-
725 tryIOError $ getEnv "http_proxy"
726 (useragent :: Either IOError String) <-
727 tryIOError $ getEnv "USER_AGENT"
729 req' <- case proxy of
731 Right pr -> (parseReq pr >>= \r ->
732 return $ addProxy (host r) (port r) req)
734 req'' <- case useragent of
735 Left _ -> return req'
737 let headers = requestHeaders req'
738 let useragentheader = (hUserAgent, B8.pack ua)
739 let headers' = useragentheader:headers
740 return $ req' {requestHeaders = headers'}
741 resp <- newManager tlsManagerSettings >>= httpLbs req''
742 return (BS.concat $ toChunks $ responseBody resp,
743 UTF8.toString `fmap` lookup hContentType (responseHeaders resp))
745 | otherwise = getBodyAndMimeType `fmap` browse
746 (do liftIO $ UTF8.hPutStrLn stderr $ "Fetching " ++ u ++ "..."
747 setOutHandler $ const (return ())
748 setAllowRedirects True
749 request (getRequest' u'))
750 where getBodyAndMimeType (_, r) = (rspBody r, findHeader HdrContentType r)
751 getRequest' uriString = case parseURI uriString of
752 Nothing -> error ("Not a valid URL: " ++
754 Just v -> mkRequest GET v
755 u' = escapeURIString (/= '|') u -- pipes are rejected by Network.URI
762err :: MonadIO m => Int -> String -> m a
763err exitCode msg = liftIO $ do
764 UTF8.hPutStrLn stderr msg
765 exitWith $ ExitFailure exitCode
768mapLeft :: (a -> b) -> Either a c -> Either b c
769mapLeft f (Left x) = Left (f x)
770mapLeft _ (Right x) = Right x
772-- | Remove intermediate "." and ".." directories from a path.
774-- > collapseFilePath "./foo" == "foo"
775-- > collapseFilePath "/bar/../baz" == "/baz"
776-- > collapseFilePath "/../baz" == "/../baz"
777-- > collapseFilePath "parent/foo/baz/../bar" == "parent/foo/bar"
778-- > collapseFilePath "parent/foo/baz/../../bar" == "parent/bar"
779-- > collapseFilePath "parent/foo/.." == "parent"
780-- > collapseFilePath "/parent/foo/../../bar" == "/bar"
781collapseFilePath :: FilePath -> FilePath
782collapseFilePath = Posix.joinPath . reverse . foldl go [] . splitDirectories
785 go r@(p:rs) ".." = case p of
787 (checkPathSeperator -> Just True) -> ("..":r)
789 go _ (checkPathSeperator -> Just True) = [[Posix.pathSeparator]]
791 isSingleton [] = Nothing
792 isSingleton [x] = Just x
793 isSingleton _ = Nothing
794 checkPathSeperator = fmap isPathSeparator . isSingleton
797-- File selection from the archive
799filteredFilesFromArchive :: Archive -> (FilePath -> Bool) -> [(FilePath, BL.ByteString)]
800filteredFilesFromArchive zf f =
801 mapMaybe (fileAndBinary zf) (filter f (filesInArchive zf))
803 fileAndBinary :: Archive -> FilePath -> Maybe (FilePath, BL.ByteString)
804 fileAndBinary a fp = findEntryByPath fp a >>= \e -> Just (fp, fromEntry e)
807--- Squash blocks into inlines
810blockToInlines :: Block -> [Inline]
811blockToInlines (Plain ils) = ils
812blockToInlines (Para ils) = ils
813blockToInlines (LineBlock lns) = combineLines lns
814blockToInlines (CodeBlock attr str) = [Code attr str]
815blockToInlines (RawBlock fmt str) = [RawInline fmt str]
816blockToInlines (BlockQuote blks) = blocksToInlines blks
817blockToInlines (OrderedList _ blkslst) =
818 concatMap blocksToInlines blkslst
819blockToInlines (BulletList blkslst) =
820 concatMap blocksToInlines blkslst
821blockToInlines (DefinitionList pairslst) =
824 f (ils, blkslst) = ils ++
826 (concatMap blocksToInlines blkslst)
827blockToInlines (Header _ _ ils) = ils
828blockToInlines (HorizontalRule) = []
829blockToInlines (Table _ _ _ headers rows) =
830 intercalate [LineBreak] $ map (concatMap blocksToInlines) tbl
833blockToInlines (Div _ blks) = blocksToInlines blks
834blockToInlines Null = []
836blocksToInlinesWithSep :: [Inline] -> [Block] -> [Inline]
837blocksToInlinesWithSep sep blks = intercalate sep $ map blockToInlines blks
839blocksToInlines :: [Block] -> [Inline]
840blocksToInlines = blocksToInlinesWithSep [Space, Str "¶", Space]
847safeRead :: (MonadPlus m, Read a) => String -> m a
848safeRead s = case reads s of
850 | all isSpace x -> return d
857withTempDir :: String -> (FilePath -> IO a) -> IO a
860 withTempDirectory "."
862 withSystemTempDirectory
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list