Wiki.hs

   1 module Wiki (
   2         Backend (getCurrent,getList,get,setCurrent,update,listKeys)
   3         ,PGB
   4         ,createPGB
   5         ,Markup (Text, Paragraph, Font, Link, Heading, Url, Pre,List)
   6         ,FontOp (Bold, Emph, Mono, Underline, Strike)
   7         ,Document
   8         ,wikiParser
   9         ,toHtml
  10         ,toLatex
  11
  12 ) where
  13
  14 import Dbconnect
  15 import Data.Char
  16 import Text.ParserCombinators.Parsec
  17
  18 class Backend a where
  19         --Keyword -> (Full text,date)
  20         getCurrent :: a -> String -> IO (Maybe (String,String))
  21
  22         --Keyword -> [(id,date,author,comment)]
  23         getList :: a -> String -> IO [(String, String, String, String)]
  24
  25         --Keyword -> id -> Full text
  26         get :: a -> String -> String -> IO (Maybe String)
  27
  28         --Keyword -> id -> ()
  29         setCurrent :: a -> String -> String -> IO Bool
  30
  31         --Keyword -> Full text -> id
  32         update :: a -> String -> String -> String -> String -> IO String
  33
  34         --[Keyword]
  35         listKeys :: a -> IO [String]
  36
  37 data Markup = Text String
  38         | Paragraph
  39         | Link String String
  40         | Font FontOp [Markup]
  41         | Heading Int [Markup]
  42         | Url String
  43         | Pre [Markup]
  44         | List Bool [[Markup]]
  45
  46 data FontOp = Bold | Emph | Mono | Underline | Strike
  47
  48 type Document = [Markup]
  49
  50 wikiParser :: Parser Document
  51 wikiParser = many1 pMain
  52
  53 pPara :: Parser Markup
  54 pPara = count 2 pEol >> return (Paragraph)
  55
  56 pLink :: Parser Markup
  57 pLink = do
  58         string "[["
  59         (l,d) <- pLinkContent
  60         case d of
  61                 [] -> return (Link l l)
  62                 _ -> return (Link l d)
  63
  64 pList :: Bool -> Parser Markup
  65 pList enum = do
  66         list <- many1 $ try $ pListItem enum
  67         return (List enum list)
  68
  69 pListItem :: Bool -> Parser [Markup]
  70 pListItem enum = do
  71         many1 pEol
  72         char $ listToken enum
  73         many pOneLine
  74
  75 listToken True = '#'
  76 listToken False = '*'
  77
  78 pHeading :: Parser Markup
  79 pHeading = do
  80         many1 pEol
  81         level <- many1 $ char '='
  82         s <- pStopAt level
  83         return (Heading (length level) s)
  84
  85 pURL :: Parser Markup
  86 pURL = do
  87         proto <- many1 letter
  88         string "://"
  89         s <- many1 (alphaNum <|> oneOf "?.:&-/~%=\\_")
  90         return (Url (proto++"://"++s))
  91
  92 pMail :: Parser Markup
  93 pMail = do
  94         user <- many1 (alphaNum <|> oneOf ".-_")
  95         char '@'
  96         server <- many1 (alphaNum <|> oneOf ".-_")
  97         return (Url ("mailto:"++user++"@"++server))
  98
  99
 100 pPre :: Parser Markup
 101 pPre = string "<pre>" >> do
 102         s <- pUntil (pOneLine <|> pEol) "</pre>"
 103         return (Pre s)
 104
 105 pBold,pEmph,pUnderline,pStrike :: Parser Markup
 106 pBold = pFont "**" Bold
 107 pEmph = pFont "//" Emph
 108 pUnderline = pFont "__" Underline
 109 pStrike = pFont "--" Strike
 110 pMono = pFont "||" Mono
 111
 112 pFont s o = string s >> do
 113         s <- pStopAt s
 114         return (Font o s)
 115
 116 pOtherChar :: Parser Markup
 117 pOtherChar = do
 118         c <- noneOf "\n\r"
 119         return (Text (c:[]))
 120
 121 pText :: Parser Markup
 122 pText = do
 123         t <- many1 alphaNum
 124         return (Text t)
 125
 126 pLinkContent :: Parser (String, String)
 127 pLinkContent = do try (string "]]" >> return ([],[]))
 128         <|> try (do
 129                 string " | "
 130                 d <- pString "]]"
 131                 return ([],d))
 132         <|> (do
 133                 c <- anyChar
 134                 (l,d) <- pLinkContent
 135                 return (c:l,d))
 136
 137 pStopAt :: String -> Parser Document
 138 pStopAt xs = pUntil pOneLine xs
 139
 140 pString :: String -> Parser String
 141 pString xs = pUntil anyChar xs
 142
 143 pEol :: Parser Markup
 144 pEol = do
 145         (string "\n" <|> string "\r\n")
 146         return (Text "\r\n")
 147
 148 pUntil :: Parser a -> String -> Parser [a]
 149 pUntil p xs = manyTill p (try $ string xs)
 150
 151 pMain :: Parser Markup
 152 pMain = choice [
 153         try (pHeading)
 154         ,try $ pList True
 155         ,try $ pList False
 156         ,try (pPara)
 157         ,try(pPre)
 158         ,try(pBold)
 159         ,try(pEmph)
 160         ,try(pUnderline)
 161         ,try(pStrike)
 162         ,try(pMono)
 163         ,try (pLink)
 164         ,try (pURL)
 165         ,try (pMail)
 166         ,pText
 167         ,pOtherChar
 168         ,pEol
 169         ]
 170
 171 pOneLine = choice [
 172         try pBold
 173         ,try pEmph
 174         ,try pUnderline
 175         ,try pStrike
 176         ,try pMono
 177         ,try pLink
 178         ,try pURL
 179         ,try pMail
 180         ,pText
 181         ,pOtherChar
 182         ]
 183
 184 newtype PGB = PGB DBService
 185
 186 createPGB :: String -> String -> String -> String -> IO PGB
 187 createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db)
 188
 189 instance Backend PGB where
 190
 191         getCurrent (PGB db) key = do
 192                 result <- selectReturnTuples db $ "SELECT fulltext,timestamp FROM curtexts WHERE keyword="++tov key
 193                 case result of
 194                         [text,date]:_ -> return (Just (text,date))
 195                         _ -> return Nothing
 196
 197         getList (PGB db) key = do
 198                 list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
 199                 case list of
 200                         [[]] -> return []
 201                         _ -> return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
 202
 203         get (PGB db) key id = do
 204                 list <- selectReturnTuples db $ "SELECT fulltext from fulltexts WHERE id = "++tov id
 205                 case list of
 206                         [s]:_ -> return (Just s)
 207                         _ -> return Nothing
 208
 209         setCurrent (PGB db) key id = do
 210                 full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"
 211                 cur <- selectReturnTuples db $ "SELECT keyword FROM curtexts WHERE keyword="++tov key
 212                 case full of
 213                         [[]] -> do
 214                                 return False
 215                         _  -> do
 216                                 rows <- case cur of
 217                                         [[]] -> do
 218                                                 execute db $ "INSERT INTO current (keyword, id) VALUES ("++tov key++","++tov id++")"
 219                                         _  -> do
 220                                                 execute db $ "UPDATE current SET id = "++tov id++" WHERE keyword = "++tov key
 221                                 if rows == 1 then return True
 222                                         else return False
 223
 224         update (PGB db) key text author comment = do
 225                 rows <- execute db $ "INSERT INTO fulltexts (keyword,fulltext, author, comment) VALUES ("++tov key++","++tov text++","++tov author++","++tov comment++")"
 226                 if rows == 0 then return ""
 227                         else do
 228                                 [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')"
 229                                 setCurrent (PGB db) key id
 230                                 return id
 231
 232         listKeys (PGB db) = do
 233                 list <- selectReturnTuples db $ "SELECT keyword FROM current keyword ORDER BY lower(keyword)"
 234                 case list of
 235                         [[]] -> return []
 236                         _ -> mapM (\[key] -> return key) list
 237
 238 tov :: String -> String
 239 tov s = '\'':escapeQuery s++"'"
 240
 241 toHtml :: [Markup] -> String
 242 toHtml [] = []
 243 toHtml ((Paragraph):xs) = "<p>\n"++toHtml xs
 244 toHtml ((Text s):xs) = s++toHtml xs
 245 toHtml ((Link l d):xs) = "<link: "++l++" desc: "++d++">"++toHtml xs
 246 toHtml ((Font o d):xs) = "<"++htmlFontOp o++">"++toHtml d++"</"++htmlFontOp o++">"++toHtml xs
 247 toHtml ((Heading n d):xs) = "\n<h"++show n++">"++toHtml d++"</h"++show n++">\n"++toHtml xs
 248 toHtml ((Url l):xs) = "<link: "++l++">"++toHtml xs
 249 toHtml ((Pre s):xs) = "<pre>"++toHtml s++"</pre>"++toHtml xs
 250 toHtml ((List o l):xs) = "<"++htmlListType o++">\n"++(unlines $ map (\s -> "<li>"++toHtml s++"</li>\n") l) ++ "</"++htmlListType o++">"++toHtml xs
 251
 252 htmlFontOp Bold = "b"
 253 htmlFontOp Emph = "em"
 254 htmlFontOp Mono = "tt"
 255 htmlFontOp Underline = "u"
 256 htmlFontOp Strike = "strike"
 257
 258 htmlListType True = "ol"
 259 htmlListType False = "ul"
 260
 261 toLatex :: [Markup] -> String
 262 toLatex [] = []
 263 toLatex ((Paragraph):xs) = "\n\n"++toLatex xs
 264 toLatex ((Text s):xs) = s++toLatex xs
 265 toLatex ((Link l d):xs) = "{\\em "++d++"}"++toLatex xs
 266 toLatex ((Font o d):xs) = "{\\"++latexFontOp o++" "++toLatex d++"}"++toHtml xs
 267 toLatex ((Heading n d):xs) = "\n\\"++(unwords $ take (n-1) $ repeat "sub")++"section{"++toLatex d++"}"++"\n\n"++toLatex xs
 268 toLatex ((Url l):xs) = "{\\bf "++l++"}"++toLatex xs
 269 toLatex ((Pre s):xs) = "<pre>"++toLatex s++"</pre>"++toLatex xs
 270 toLatex ((List o l):xs) = "\n\\begin{"++latexListType o++"}\n"++(unlines $ map (\s -> "\\item "++toLatex s++"\n") l) ++ "\\end{"++latexListType o++"}"++toLatex xs
 271
 272 latexFontOp Bold = "bf"
 273 latexFontOp Emph = "em"
 274 latexFontOp Mono = "tt"
 275 latexFontOp Underline = "u"
 276 latexFontOp Strike = "strike"
 277
 278 latexListType True = "enumeration"
 279 latexListType False = "itemize"
 280
 281 output s f = case parse wikiParser "" s of
 282                                         Right n -> putStr (f n)
 283                                         Left e -> print e
 284
 285 htmlOutput s = output s toHtml
 286 latexOutput s = output s toLatex