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