{-# OPTIONS -fglasgow-exts -fth #-}
{-
Copyright (C) 2007 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
-}

{- |
   Module      : PandocWiki
   Copyright   : Copyright (C) 2007 John MacFarlane
   License     : GNU GPL, version 2 or above 

   Maintainer  : John MacFarlane <jgm@berkeley@edu>
   Stability   : alpha 
   Portability : portable

Simple wiki program using HAppS and pandoc.
-}
import HAppS
import Diff
import Text.Regex
import Text.XHtml
import System.Time
import Text.Pandoc
import Data.List (sort, intersperse)
import Control.Monad.State (get, put)
import HAppS.Agents.Users
import Data.Maybe (fromMaybe)

-- Data structures for Wiki

data Wiki = Wiki WikiData Pages deriving (Read, Show)

data WikiData = WikiData
    { wikiTitle      :: String } deriving (Read, Show)

type Pages = [(String, Page)]

data PageOption = UseAsciiMathML deriving (Read, Show, Eq) 

data Page = Page
    { pageContents   :: String
    , pageCached     :: String
    , pageHistory    :: [PageHistory]
    , pageLockedBy   :: Maybe SessionKey
    , pageOptions    :: [PageOption] } deriving (Read, Show)

data PageHistory = PageHistory
    { pageTimeStamp  :: String
    , pageEditedBy   :: Username
    , pageChanges    :: [Change String]
    , pageChangeDesc :: String } deriving (Read, Show)

type Button = (String -> Html)

defaultWikiData = WikiData
    { wikiTitle       = "PandocWiki" }

instance StartState Wiki where
  startStateM = return $ Wiki defaultWikiData 
                         [("WelcomePage", newPage {pageContents = "Welcome to !PandocWiki!"})]
 
instance Serialize Wiki where
  typeString _ = "Wiki"
  encodeBinary  = encodeBinary
  decodeBinary  = decodeBinary
  encodeStringM = defaultEncodeStringM
  decodeStringM = defaultDecodeStringM

camelCase = "([A-Z][a-z]+[A-Z][A-Za-z]+)"

main :: IO ()
main = (stdHTTP :: [ServerPart (Ev Wiki Request) Request IO Result] -> IO ()) $ 
       debugFilter : -- we want to see debug messages in the console

       [ h ["Index"] GET $ ok $ displayIndex
       , h (re [camelCase, "changes", "([0-9]+)"]) GET $ ok $ displayDiff 
       , h (re [camelCase, "edit"]) GET $ ok $ displayEdit
       , h (re [camelCase, "changes"]) GET $ ok $ displayHistory
       , h (re [camelCase]) GET $ ok $ displayPage
       , h (re ["^()$"]) GET $ ok $ displayPage
       , h (re [camelCase]) POST $ savePage  
       , hs (Prefix ["static"]) GET $ basicFileServe staticPath
       , h () GET $ notFound $ \() () -> displayNotFound
       ]

-- Functions for making and rendering pages

frontPage :: String
frontPage = "WelcomePage"

newPage :: Page
newPage = Page  { pageContents = ""
                , pageCached   = ""
                , pageHistory  = []
                , pageLockedBy = Nothing
                , pageOptions  = [] } 

convertToHtml :: String -> Html
convertToHtml contents =
  let reader = (readMarkdown defaultParserState) . (filter (/='\r'))
  in  writeHtml (defaultWriterOptions { writerStandalone = False }) $ wikify $ reader contents

wikify :: Pandoc -> Pandoc
wikify (Pandoc meta blocks) =
  Pandoc meta $ map wikifyBlock blocks
  -- TODO:  check against pages, diff CSS for new pages

wikifyBlock :: Block -> Block
wikifyBlock block = 
  case block of
       (Para x) -> Para $ wikifyInlines x
       (Plain x) -> Plain $ wikifyInlines x
       (BlockQuote blks) -> BlockQuote $ map wikifyBlock blks
       (OrderedList attribs items) -> OrderedList attribs $ 
                                      map (map wikifyBlock) items
       (BulletList items) -> BulletList $ map (map wikifyBlock) items
       (DefinitionList items) -> DefinitionList $ 
                  map (\(term, def) -> (term, map wikifyBlock def)) items
       (Header lvl txt) -> Header lvl $ wikifyInlines txt
       (Table caption aligns widths heads rows) ->
                 Table (wikifyInlines caption) aligns widths
                 (map (map wikifyBlock) heads) 
                 (map (map (map wikifyBlock)) rows)
       x        -> x

wikifyInlines :: [Inline] -> [Inline]
wikifyInlines ((Str "!"):(Str x):rest) | isWikiWord x =
  (Str x):(wikifyInlines rest)  
wikifyInlines ((Str x):rest) | isWikiWord x = 
  Link [Str x] ("/" ++ x, ""):(wikifyInlines rest)
wikifyInlines ((Emph x):rest) = Emph (wikifyInlines x):(wikifyInlines rest)
wikifyInlines ((Strong x):rest) = Strong (wikifyInlines x):(wikifyInlines rest)
wikifyInlines ((Superscript x):rest) =
  Superscript (wikifyInlines x):(wikifyInlines rest)
wikifyInlines ((Subscript x):rest) = 
  Subscript (wikifyInlines x):(wikifyInlines rest)
wikifyInlines ((Strikeout x):rest) = 
  Strikeout (wikifyInlines x):(wikifyInlines rest)
wikifyInlines ((Quoted typ x):rest) = 
  Quoted typ (wikifyInlines x):(wikifyInlines rest)
wikifyInlines ((Link x target):rest) = 
  Link (wikifyInlines x) target:(wikifyInlines rest)
wikifyInlines ((Image x target):rest) = 
  Image (wikifyInlines x) target:(wikifyInlines rest)
wikifyInlines ((Note blks):rest) =
  Note (map wikifyBlock blks):(wikifyInlines rest)
wikifyInlines (x:rest) = x:(wikifyInlines rest)
wikifyInlines [] = []

isWikiWord :: String -> Bool
isWikiWord [] = False
isWikiWord [x] = False
isWikiWord (x:y:z) = x `elem` ['A'..'Z'] &&
                     y `elem` ['a'..'z'] &&
                     any (`elem` ['A'..'Z']) z

displayPage :: [String] -> () -> Ev Wiki Request (Either request String)
displayPage [""] () = displayPage [frontPage] ()
displayPage [pagename] () = do
  (Wiki wikidata pages) <- get
  case lookup pagename pages of
       Nothing   -> displayEdit [pagename] ()
       Just page -> respond $ if null (pageCached page)
                                 then makePage pagename (wikiTitle wikidata)
                                      (pageContents page)
                                 else pageCached page

makePage :: String -> String -> String -> String
makePage pagename wikiname contents = 
  let buttons  = [editButton, historyButton, indexButton, homeButton]
      htmlContents = convertToHtml contents
  in  renderWikiPage wikiname pagename htmlContents buttons

displayEdit :: [String] -> () -> Ev Wiki Request (Either request String)
displayEdit [pagename] () = do
  (Wiki wikidata pages) <- get
  let page       = fromMaybe newPage $ lookup pagename pages
  let buttons    = [cancelButton]
  let contents   = gui ("/" ++ pagename) $ 
                   textarea ! [name "text", rows "18", cols "80"] 
                   << (pageContents page) +++ br +++ 
                   label ! [strAttr "for" "description", size "60", 
                   maxlength 80] << "Description of changes: " +++ 
                   textfield "description" ! [size "35", maxlength 60] +++ 
                   br +++ submit "Save" "Save"
      -- TODO: build in locking
  respond $ renderWikiPage (wikiTitle wikidata) pagename contents buttons

savePage :: [String] -> Request -> Ev Wiki Request (Either request (IO Result))
savePage [pagename] req = do
  (Wiki wikidata pages) <- get
  newcontent <- lookM req "text" 
  description <- lookM req "description"
  let (oldcontent, oldhistory) = case lookup pagename pages of
                                   Just page -> (pageContents page,
                                                 pageHistory page)
                                   Nothing   -> ("",[])
  let changes = diffsFrom (lines newcontent) (lines oldcontent)
  rawtime <- getTime
  let timestamp = calendarTimeToString $
                  toUTCTime $ TOD (fromIntegral rawtime) 0
  let change = PageHistory { pageTimeStamp  = timestamp
                           , pageEditedBy   = "User"
                           , pageChanges    = changes 
                           , pageChangeDesc = description } 
  let newpage = Page { pageContents = newcontent
                     , pageCached   = makePage pagename (wikiTitle wikidata)
                                      newcontent
                     , pageHistory  = change:oldhistory
                     , pageLockedBy = Nothing
                     , pageOptions = [] } 
  put $ Wiki wikidata $ updatePage pages pagename newpage 
  respond $ redirect ("/" ++ pagename)

displayNotFound :: Ev Wiki Request (Either request String)
displayNotFound =
  let contents = p << "Sorry, that page was not found."
  in  respond $ renderWikiPage (wikiTitle defaultWikiData) "Not Found" contents [homeButton, indexButton]

displayIndex :: () -> () -> Ev Wiki Request (Either request String)
displayIndex _ _ = do
  (Wiki wikidata pages) <- get
  let contents = ulist << 
                 (map (\name -> li << anchor ! [href name] << name) $
                 sort $ map fst pages)
  respond $ renderWikiPage (wikiTitle wikidata) "Index" contents [homeButton]

displayHistory :: [String] -> () -> Ev Wiki Request (Either request String)
displayHistory [pagename] () = do
  (Wiki wikidata pages) <- get
  case lookup pagename pages of
        Nothing     -> displayNotFound
        Just page   -> do let history = pageHistory page
                          let contents = h2 << "Changes" +++
                                         ulist << zipWith (renderChange pagename)
                                         (reverse [1..(length history)]) history
                          respond $ renderWikiPage (wikiTitle wikidata) pagename
                                    contents [backButton]

renderChange :: String -> Int -> PageHistory -> Html
renderChange pagename num change =
  let timestamp = pageTimeStamp change 
      number    = show num
  in  li << (anchor ! [href ("/" ++ pagename ++ "/changes/" ++ number)] << 
      (timestamp ++ " " ++ pageEditedBy change) +++ primHtmlChar "nbsp" +++ 
      thespan ! [theclass "changeDescription"] << pageChangeDesc change)

displayDiff :: [String] -> () -> Ev Wiki Request (Either request String)
displayDiff [pagename, numberString] () = do
  let number = read numberString
  (Wiki wikidata pages) <- get
  let (content, history) = case lookup pagename pages of
                             Just page -> (lines (pageContents page),
                                           pageHistory page)
                             Nothing   -> ([],[])
  let histLength = length history
  let history' = take (histLength - (number - 1)) history
  let changes = map (\change -> pageChanges change) history'
  let newcontent = foldl (\cont chg -> applyChanges chg cont) content (init changes)
  let oldcontent = applyChanges (last changes) newcontent
  let diffs = diffsFrom oldcontent newcontent
  let markdel str = del << str +++ br  
  let markins str = ins << str +++ br
  let marknone str = primHtml str +++ br
  let prettyDiff (old, new) change = 
        case change of
             (Keep n) -> (drop n old, new ++ map marknone (take n old))
             (Del n)  -> (drop n old, new ++ map markdel (take n old))
             (Ins xs) -> (old, new ++ map markins xs)
  let next = if histLength > number
                then anchor ! [href ("/" ++ pagename ++ "/changes/" ++ show (number + 1))] << "-->"
                else stringToHtml "-->"
  let prev = if number > 1
                then anchor ! [href ("/" ++ pagename ++ "/changes/" ++ show (number - 1))] << "<--"
                else stringToHtml "<--"
  let htmlDiff = h3 << (prev +++ pageTimeStamp (last history') +++ next) +++
                 pre << (snd $ foldl prettyDiff (oldcontent, []) diffs)
  respond $ renderWikiPage (wikiTitle wikidata) pagename htmlDiff [historyButton]

renderWikiPage :: String -> String -> Html -> [Button] -> String
renderWikiPage pagename name contents buttons = renderHtml $
  (header << thetitle << (pagename ++ " - " ++ name) +++
  thelink ! [href "/static/stylesheets/wiki.css", rel "stylesheet", strAttr "media" "all", 
             thetype "text/css"] << noHtml +++
  thelink ! [href "/static/stylesheets/wikiprint.css", rel "stylesheet", 
             strAttr "media" "print", thetype "text/css"] << noHtml) +++ 
  body << ((h1 << name) +++
  (thediv ! [identifier "wikicontent"] << contents) +++
  (thediv ! [identifier "wikibuttons"] $ renderButtons name buttons))

-- Functions for making and rendering navigation buttons

renderButtons :: String -> [Button] -> Html
renderButtons pagename buttons = unordList $ map ($ pagename) buttons

mkButton :: String -> String -> Html
mkButton url caption = 
  anchor ! [href url, theclass "button"] << caption
 
editButton :: Button
editButton pagename = mkButton ("/" ++ pagename ++ "/edit") "Edit"

historyButton :: Button
historyButton pagename = mkButton ("/" ++ pagename ++ "/changes") "History"

indexButton :: Button
indexButton _ = mkButton "/Index" "Index"

homeButton :: Button
homeButton _ = mkButton "/" "Home"

cancelButton :: Button
cancelButton pagename = mkButton ("/" ++ pagename) "Cancel"

backButton :: Button
backButton pagename = mkButton ("/" ++ pagename) "Back"

-- Functions for updating, deleting pages

updatePage :: Pages -> String -> Page -> Pages
updatePage pages name page = (name,page):(deletePage pages name)

deletePage :: Pages -> String -> Pages
deletePage pages page = filter (\(p,c) -> p /= page) pages