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