{-# LANGUAGE CPP #-}
module Network.Gitit.Page ( stringToPage
, pageToString
, readCategories
)
where
import Network.Gitit.Types
import Network.Gitit.Util (trim, splitCategories, parsePageType)
import Text.ParserCombinators.Parsec
import Data.Char (toLower)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.ByteString.UTF8 (toString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import System.IO (withFile, Handle, IOMode(..))
import qualified Control.Exception as E
import System.IO.Error (isEOFError)
parseMetadata :: String -> ([(String, String)], String)
parseMetadata :: String -> ([(String, String)], String)
parseMetadata String
raw =
case Parsec String () ([(String, String)], String)
-> String
-> String
-> Either ParseError ([(String, String)], String)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () ([(String, String)], String)
forall st. GenParser Char st ([(String, String)], String)
pMetadataBlock String
"" String
raw of
Left ParseError
_ -> ([], String
raw)
Right ([(String, String)]
ls, String
rest) -> ([(String, String)]
ls, String
rest)
pMetadataBlock :: GenParser Char st ([(String, String)], String)
pMetadataBlock :: GenParser Char st ([(String, String)], String)
pMetadataBlock = GenParser Char st ([(String, String)], String)
-> GenParser Char st ([(String, String)], String)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (GenParser Char st ([(String, String)], String)
-> GenParser Char st ([(String, String)], String))
-> GenParser Char st ([(String, String)], String)
-> GenParser Char st ([(String, String)], String)
forall a b. (a -> b) -> a -> b
$ do
String
_ <- String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"---"
Char
_ <- GenParser Char st Char
forall st. GenParser Char st Char
pBlankline
[(String, String)]
ls <- ParsecT String st Identity (String, String)
-> GenParser Char st Char
-> ParsecT String st Identity [(String, String)]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String st Identity (String, String)
forall st. GenParser Char st (String, String)
pMetadataLine GenParser Char st Char
forall st. GenParser Char st Char
pMetaEnd
GenParser Char st Char -> ParsecT String st Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany GenParser Char st Char
forall st. GenParser Char st Char
pBlankline
String
rest <- ParsecT String st Identity String
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
([(String, String)], String)
-> GenParser Char st ([(String, String)], String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String)]
ls, String
rest)
pMetaEnd :: GenParser Char st Char
pMetaEnd :: GenParser Char st Char
pMetaEnd = GenParser Char st Char -> GenParser Char st Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (GenParser Char st Char -> GenParser Char st Char)
-> GenParser Char st Char -> GenParser Char st Char
forall a b. (a -> b) -> a -> b
$ do
String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"..." ParsecT String st Identity String
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"---"
GenParser Char st Char
forall st. GenParser Char st Char
pBlankline
pBlankline :: GenParser Char st Char
pBlankline :: GenParser Char st Char
pBlankline = GenParser Char st Char -> GenParser Char st Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (GenParser Char st Char -> GenParser Char st Char)
-> GenParser Char st Char -> GenParser Char st Char
forall a b. (a -> b) -> a -> b
$ GenParser Char st Char -> ParsecT String st Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> GenParser Char st Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" \t") ParsecT String st Identity String
-> GenParser Char st Char -> GenParser Char st Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenParser Char st Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
pMetadataLine :: GenParser Char st (String, String)
pMetadataLine :: GenParser Char st (String, String)
pMetadataLine = GenParser Char st (String, String)
-> GenParser Char st (String, String)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (GenParser Char st (String, String)
-> GenParser Char st (String, String))
-> GenParser Char st (String, String)
-> GenParser Char st (String, String)
forall a b. (a -> b) -> a -> b
$ do
Char
first <- ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter
String
rest <- ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-_")
let ident :: String
ident = Char
firstChar -> String -> String
forall a. a -> [a] -> [a]
:String
rest
ParsecT String st Identity Char -> ParsecT String st Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" \t")
Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
String
rawval <- ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String st Identity Char
-> ParsecT String st Identity String)
-> ParsecT String st Identity Char
-> ParsecT String st Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\n\r"
ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (ParsecT String st Identity Char -> ParsecT String st Identity Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String st Identity Char
-> ParsecT String st Identity Char)
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall a b. (a -> b) -> a -> b
$ ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline ParsecT String st Identity Char
-> ParsecT String st Identity () -> ParsecT String st Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String st Identity Char -> ParsecT String st Identity ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy ParsecT String st Identity Char
forall st. GenParser Char st Char
pBlankline ParsecT String st Identity ()
-> ParsecT String st Identity () -> ParsecT String st Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
ParsecT String st Identity Char -> ParsecT String st Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" \t") ParsecT String st Identity ()
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String st Identity Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
' ')
Char
_ <- ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
(String, String) -> GenParser Char st (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
ident, String -> String
trim String
rawval)
stringToPage :: Config -> String -> String -> Page
stringToPage :: Config -> String -> String -> Page
stringToPage Config
conf String
pagename String
raw =
let ([(String, String)]
ls, String
rest) = String -> ([(String, String)], String)
parseMetadata String
raw
page' :: Page
page' = Page :: String
-> PageType
-> Bool
-> Bool
-> String
-> [String]
-> String
-> [(String, String)]
-> Page
Page { pageName :: String
pageName = String
pagename
, pageFormat :: PageType
pageFormat = Config -> PageType
defaultPageType Config
conf
, pageLHS :: Bool
pageLHS = Config -> Bool
defaultLHS Config
conf
, pageTOC :: Bool
pageTOC = Config -> Bool
tableOfContents Config
conf
, pageTitle :: String
pageTitle = String
pagename
, pageCategories :: [String]
pageCategories = []
, pageText :: String
pageText = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') String
rest
, pageMeta :: [(String, String)]
pageMeta = [(String, String)]
ls }
in ((String, String) -> Page -> Page)
-> Page -> [(String, String)] -> Page
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, String) -> Page -> Page
adjustPage Page
page' [(String, String)]
ls
adjustPage :: (String, String) -> Page -> Page
adjustPage :: (String, String) -> Page -> Page
adjustPage (String
"title", String
val) Page
page' = Page
page' { pageTitle :: String
pageTitle = String
val }
adjustPage (String
"format", String
val) Page
page' = Page
page' { pageFormat :: PageType
pageFormat = PageType
pt, pageLHS :: Bool
pageLHS = Bool
lhs }
where (PageType
pt, Bool
lhs) = String -> (PageType, Bool)
parsePageType String
val
adjustPage (String
"toc", String
val) Page
page' = Page
page' {
pageTOC :: Bool
pageTOC = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
val String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"yes",String
"true"] }
adjustPage (String
"categories", String
val) Page
page' =
Page
page' { pageCategories :: [String]
pageCategories = String -> [String]
splitCategories String
val [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Page -> [String]
pageCategories Page
page' }
adjustPage (String
_, String
_) Page
page' = Page
page'
pageToString :: Config -> Page -> String
pageToString :: Config -> Page -> String
pageToString Config
conf Page
page' =
let pagename :: String
pagename = Page -> String
pageName Page
page'
pagetitle :: String
pagetitle = Page -> String
pageTitle Page
page'
pageformat :: PageType
pageformat = Page -> PageType
pageFormat Page
page'
pagelhs :: Bool
pagelhs = Page -> Bool
pageLHS Page
page'
pagetoc :: Bool
pagetoc = Page -> Bool
pageTOC Page
page'
pagecats :: [String]
pagecats = Page -> [String]
pageCategories Page
page'
metadata :: [(String, String)]
metadata = ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter
(\(String
k, String
_) -> Bool -> Bool
not (String
k String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
[String
"title", String
"format", String
"toc", String
"categories"]))
(Page -> [(String, String)]
pageMeta Page
page')
metadata' :: String
metadata' = (if String
pagename String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
pagetitle
then String
"title: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pagetitle String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
(if PageType
pageformat PageType -> PageType -> Bool
forall a. Eq a => a -> a -> Bool
/= Config -> PageType
defaultPageType Config
conf Bool -> Bool -> Bool
||
Bool
pagelhs Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Config -> Bool
defaultLHS Config
conf
then String
"format: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
(Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (PageType -> String
forall a. Show a => a -> String
show PageType
pageformat) String -> String -> String
forall a. [a] -> [a] -> [a]
++
if Bool
pagelhs then String
"+lhs\n" else String
"\n"
else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
(if Bool
pagetoc Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Config -> Bool
tableOfContents Config
conf
then String
"toc: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
(if Bool
pagetoc then String
"yes" else String
"no") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
(if Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
pagecats)
then String
"categories: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
pagecats String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
([String] -> String
unlines (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
k, String
v) -> String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v) [(String, String)]
metadata))
in (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
metadata' then String
"" else String
"---\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
metadata' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"...\n\n")
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Page -> String
pageText Page
page'
readCategories :: FilePath -> IO [String]
readCategories :: String -> IO [String]
readCategories String
f =
String -> IOMode -> (Handle -> IO [String]) -> IO [String]
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
ReadMode ((Handle -> IO [String]) -> IO [String])
-> (Handle -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
IO [String] -> (IOError -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (do ByteString
fl <- Handle -> IO ByteString
B.hGetLine Handle
h
if ByteString -> Bool
dashline ByteString
fl
then do
[String]
rest <- Handle -> (ByteString -> Bool) -> IO [String]
hGetLinesTill Handle
h ByteString -> Bool
dotOrDashline
let ([(String, String)]
md,String
_) = String -> ([(String, String)], String)
parseMetadata (String -> ([(String, String)], String))
-> String -> ([(String, String)], String)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"---"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rest
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitCategories (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
""
(Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"categories" [(String, String)]
md
else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
(\IOError
e -> if IOError -> Bool
isEOFError IOError
e then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else IOError -> IO [String]
forall e a. Exception e => e -> IO a
E.throwIO IOError
e)
dashline :: B.ByteString -> Bool
dashline :: ByteString -> Bool
dashline ByteString
x =
case ByteString -> String
BC.unpack ByteString
x of
(Char
'-':Char
'-':Char
'-':String
xs) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') String
xs -> Bool
True
String
_ -> Bool
False
dotOrDashline :: B.ByteString -> Bool
dotOrDashline :: ByteString -> Bool
dotOrDashline ByteString
x =
case ByteString -> String
BC.unpack ByteString
x of
(Char
'-':Char
'-':Char
'-':String
xs) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') String
xs -> Bool
True
(Char
'.':Char
'.':Char
'.':String
xs) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') String
xs -> Bool
True
String
_ -> Bool
False
hGetLinesTill :: Handle -> (B.ByteString -> Bool) -> IO [String]
hGetLinesTill :: Handle -> (ByteString -> Bool) -> IO [String]
hGetLinesTill Handle
h ByteString -> Bool
end = do
ByteString
next <- Handle -> IO ByteString
B.hGetLine Handle
h
if ByteString -> Bool
end ByteString
next
then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString -> String
toString ByteString
next]
else do
[String]
rest <- Handle -> (ByteString -> Bool) -> IO [String]
hGetLinesTill Handle
h ByteString -> Bool
end
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> String
toString ByteString
nextString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rest)