{-# LANGUAGE CPP #-}
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- Functions for translating between Page structures and raw
-  text strings.  The strings may begin with a metadata block,
-  which looks like this (it is valid YAML):
-
-  > ---
-  > title: Custom Title
-  > format: markdown+lhs
-  > toc: yes
-  > categories: foo bar baz
-  > ...
-
-  This would tell gitit to use "Custom Title" as the displayed
-  page title (instead of the page name), to interpret the page
-  text as markdown with literate haskell, to include a table of
-  contents, and to include the page in the categories foo, bar,
-  and baz.
-
-  The metadata block may be omitted entirely, and any particular line
-  may be omitted. The categories in the @categories@ field should be
-  separated by spaces. Commas will be treated as spaces.
-
-  Metadata value fields may be continued on the next line, as long as
-  it is nonblank and starts with a space character.
-
-  Unrecognized metadata fields are simply ignored.
-}

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)

-- | Read a string (the contents of a page file) and produce a Page
-- object, using defaults except when overridden by metadata.
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'

-- | Write a string (the contents of a page file) corresponding to
-- a Page object, using explicit metadata only when needed.
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'

-- | Read categories from metadata strictly.
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 -- get rest of metadata
                     [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)