{-# 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 :: [Char] -> ([([Char], [Char])], [Char])
parseMetadata [Char]
raw =
  case forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse forall st. GenParser Char st ([([Char], [Char])], [Char])
pMetadataBlock [Char]
"" [Char]
raw of
    Left ParseError
_           -> ([], [Char]
raw)
    Right ([([Char], [Char])]
ls, [Char]
rest) -> ([([Char], [Char])]
ls, [Char]
rest)

pMetadataBlock :: GenParser Char st ([(String, String)], String)
pMetadataBlock :: forall st. GenParser Char st ([([Char], [Char])], [Char])
pMetadataBlock = forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ do
  [Char]
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"---"
  Char
_ <- forall st. GenParser Char st Char
pBlankline
  [([Char], [Char])]
ls <- 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 forall st. GenParser Char st ([Char], [Char])
pMetadataLine forall st. GenParser Char st Char
pMetaEnd
  forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany forall st. GenParser Char st Char
pBlankline
  [Char]
rest <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  forall (m :: * -> *) a. Monad m => a -> m a
return ([([Char], [Char])]
ls, [Char]
rest)

pMetaEnd :: GenParser Char st Char
pMetaEnd :: forall st. GenParser Char st Char
pMetaEnd = forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ do
  forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"..." forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"---"
  forall st. GenParser Char st Char
pBlankline

pBlankline :: GenParser Char st Char
pBlankline :: forall st. GenParser Char st Char
pBlankline = forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
" \t") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline

pMetadataLine :: GenParser Char st (String, String)
pMetadataLine :: forall st. GenParser Char st ([Char], [Char])
pMetadataLine = forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ do
  Char
first <- forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter
  [Char]
rest <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"-_")
  let ident :: [Char]
ident = Char
firstforall a. a -> [a] -> [a]
:[Char]
rest
  forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
" \t")
  Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
  [Char]
rawval <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
"\n\r"
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy forall st. GenParser Char st Char
pBlankline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                            forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
" \t") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Char
' ')
  Char
_ <- forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
ident, [Char] -> [Char]
trim [Char]
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 -> [Char] -> [Char] -> Page
stringToPage Config
conf [Char]
pagename [Char]
raw =
  let ([([Char], [Char])]
ls, [Char]
rest) = [Char] -> ([([Char], [Char])], [Char])
parseMetadata [Char]
raw
      page' :: Page
page' = Page { pageName :: [Char]
pageName        = [Char]
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 :: [Char]
pageTitle       = [Char]
pagename
                   , pageCategories :: [[Char]]
pageCategories  = []
                   , pageText :: [Char]
pageText        = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r') [Char]
rest
                   , pageMeta :: [([Char], [Char])]
pageMeta        = [([Char], [Char])]
ls }
  in  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Char], [Char]) -> Page -> Page
adjustPage Page
page' [([Char], [Char])]
ls

adjustPage :: (String, String) -> Page -> Page
adjustPage :: ([Char], [Char]) -> Page -> Page
adjustPage ([Char]
"title", [Char]
val) Page
page' = Page
page' { pageTitle :: [Char]
pageTitle = [Char]
val }
adjustPage ([Char]
"format", [Char]
val) Page
page' = Page
page' { pageFormat :: PageType
pageFormat = PageType
pt, pageLHS :: Bool
pageLHS = Bool
lhs }
    where (PageType
pt, Bool
lhs) = [Char] -> (PageType, Bool)
parsePageType [Char]
val
adjustPage ([Char]
"toc", [Char]
val) Page
page' = Page
page' {
  pageTOC :: Bool
pageTOC = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
val forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"yes",[Char]
"true"] }
adjustPage ([Char]
"categories", [Char]
val) Page
page' =
   Page
page' { pageCategories :: [[Char]]
pageCategories = [Char] -> [[Char]]
splitCategories [Char]
val forall a. [a] -> [a] -> [a]
++ Page -> [[Char]]
pageCategories Page
page' }
adjustPage ([Char]
_, [Char]
_) 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 -> [Char]
pageToString Config
conf Page
page' =
  let pagename :: [Char]
pagename   = Page -> [Char]
pageName Page
page'
      pagetitle :: [Char]
pagetitle  = Page -> [Char]
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 :: [[Char]]
pagecats   = Page -> [[Char]]
pageCategories Page
page'
      metadata :: [([Char], [Char])]
metadata   = forall a. (a -> Bool) -> [a] -> [a]
filter
                       (\([Char]
k, [Char]
_) -> Bool -> Bool
not ([Char]
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
                           [[Char]
"title", [Char]
"format", [Char]
"toc", [Char]
"categories"]))
                       (Page -> [([Char], [Char])]
pageMeta Page
page')
      metadata' :: [Char]
metadata'  = (if [Char]
pagename forall a. Eq a => a -> a -> Bool
/= [Char]
pagetitle
                       then [Char]
"title: " forall a. [a] -> [a] -> [a]
++ [Char]
pagetitle forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                       else [Char]
"") forall a. [a] -> [a] -> [a]
++
                   (if PageType
pageformat forall a. Eq a => a -> a -> Bool
/= Config -> PageType
defaultPageType Config
conf Bool -> Bool -> Bool
||
                          Bool
pagelhs forall a. Eq a => a -> a -> Bool
/= Config -> Bool
defaultLHS Config
conf
                       then [Char]
"format: " forall a. [a] -> [a] -> [a]
++
                            forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (forall a. Show a => a -> [Char]
show PageType
pageformat) forall a. [a] -> [a] -> [a]
++
                            if Bool
pagelhs then [Char]
"+lhs\n" else [Char]
"\n"
                       else [Char]
"") forall a. [a] -> [a] -> [a]
++
                   (if Bool
pagetoc forall a. Eq a => a -> a -> Bool
/= Config -> Bool
tableOfContents Config
conf
                       then [Char]
"toc: " forall a. [a] -> [a] -> [a]
++
                            (if Bool
pagetoc then [Char]
"yes" else [Char]
"no") forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                       else [Char]
"") forall a. [a] -> [a] -> [a]
++
                   (if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
pagecats)
                       then [Char]
"categories: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
pagecats forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                       else [Char]
"") forall a. [a] -> [a] -> [a]
++
                   ([[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
k, [Char]
v) -> [Char]
k forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
v) [([Char], [Char])]
metadata))
  in (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
metadata' then [Char]
"" else [Char]
"---\n" forall a. [a] -> [a] -> [a]
++ [Char]
metadata' forall a. [a] -> [a] -> [a]
++ [Char]
"...\n\n")
        forall a. [a] -> [a] -> [a]
++ Page -> [Char]
pageText Page
page'

-- | Read categories from metadata strictly.
readCategories :: FilePath -> IO [String]
readCategories :: [Char] -> IO [[Char]]
readCategories [Char]
f =
  forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
f IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h ->
    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
                     [[Char]]
rest <- Handle -> (ByteString -> Bool) -> IO [[Char]]
hGetLinesTill Handle
h ByteString -> Bool
dotOrDashline
                     let ([([Char], [Char])]
md,[Char]
_) = [Char] -> ([([Char], [Char])], [Char])
parseMetadata forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ [Char]
"---"forall a. a -> [a] -> [a]
:[[Char]]
rest
                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
splitCategories forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [Char]
""
                            forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"categories" [([Char], [Char])]
md
                   else forall (m :: * -> *) a. Monad m => a -> m a
return [])
       (\IOError
e -> if IOError -> Bool
isEOFError IOError
e then forall (m :: * -> *) a. Monad m => a -> m a
return [] else forall e a. Exception e => e -> IO a
E.throwIO IOError
e)

dashline :: B.ByteString -> Bool
dashline :: ByteString -> Bool
dashline ByteString
x =
  case ByteString -> [Char]
BC.unpack ByteString
x of
       (Char
'-':Char
'-':Char
'-':[Char]
xs) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Char
' ') [Char]
xs -> Bool
True
       [Char]
_ -> Bool
False

dotOrDashline :: B.ByteString -> Bool
dotOrDashline :: ByteString -> Bool
dotOrDashline ByteString
x =
  case ByteString -> [Char]
BC.unpack ByteString
x of
       (Char
'-':Char
'-':Char
'-':[Char]
xs) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Char
' ') [Char]
xs -> Bool
True
       (Char
'.':Char
'.':Char
'.':[Char]
xs) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Char
' ') [Char]
xs -> Bool
True
       [Char]
_ -> Bool
False

hGetLinesTill :: Handle -> (B.ByteString -> Bool) -> IO [String]
hGetLinesTill :: Handle -> (ByteString -> Bool) -> IO [[Char]]
hGetLinesTill Handle
h ByteString -> Bool
end = do
  ByteString
next <- Handle -> IO ByteString
B.hGetLine Handle
h
  if ByteString -> Bool
end ByteString
next
     then forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString -> [Char]
toString ByteString
next]
     else do
       [[Char]]
rest <- Handle -> (ByteString -> Bool) -> IO [[Char]]
hGetLinesTill Handle
h ByteString -> Bool
end
       forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> [Char]
toString ByteString
nextforall a. a -> [a] -> [a]
:[[Char]]
rest)