Wiki.hs

   1 module Wiki (
   2         Backend (getCurrent,getList,get,setCurrent,update,listKeys)
   3         ,PGB
   4         ,createPGB
   5         ,Markup (Text, Paragraph, Link, Bold, Emph, Mono, Heading, Url, Underline, Strike, Pre,List)
   6         ,Document
   7         ,wikiParser
   8         ,htmlOutput
   9
  10 ) where
  11
  12 import Dbconnect
  13 import Data.Char
  14 import Text.ParserCombinators.Parsec
  15
  16 class Backend a where
  17         --Keyword -> (Full text,date)
  18         getCurrent :: a -> String -> IO (Maybe (String,String))
  19
  20         --Keyword -> [(id,date,author,comment)]
  21         getList :: a -> String -> IO [(String, String, String, String)]
  22
  23         --Keyword -> id -> Full text
  24         get :: a -> String -> String -> IO (Maybe String)
  25
  26         --Keyword -> id -> ()
  27         setCurrent :: a -> String -> String -> IO Bool
  28
  29         --Keyword -> Full text -> id
  30         update :: a -> String -> String -> String -> String -> IO String
  31
  32         --[Keyword]
  33         listKeys :: a -> IO [String]
  34
  35 data Markup = Text String
  36         | Paragraph
  37         | Link String String
  38         | Bold [Markup]
  39         | Emph [Markup]
  40         | Mono [Markup]
  41         | Heading Int [Markup]
  42         | Url String
  43         | Underline [Markup]
  44         | Strike [Markup]
  45         | Pre [Markup]
  46         | List Bool [[Markup]]
  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 = pS "**" (\s -> Bold s)
 107 pEmph = pS "//" (\s -> Emph s)
 108 pUnderline = pS "__" (\s -> Underline s)
 109 pStrike = pS "--" (\s -> Strike s)
 110 pMono = pS "||" (\s -> Mono s)
 111 pS s f = string s >> do
 112         s <- pStopAt s
 113         return (f 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 ((Bold d):xs) = "<b>"++toHtml d++"</b>"++toHtml xs
 246 toHtml ((Emph d):xs) = "<em>"++toHtml d++"</em>"++toHtml xs
 247 toHtml ((Mono d):xs) = "<tt>"++toHtml d++"</tt>"++toHtml xs
 248 toHtml ((Underline d):xs) = "<u>"++toHtml d++"</u>"++toHtml xs
 249 toHtml ((Strike d):xs) = "<strike>"++toHtml d++"</strike>"++toHtml xs
 250 toHtml ((Heading n d):xs) = "\n<h"++show n++">"++toHtml d++"</h"++show n++">\n"++toHtml xs
 251 toHtml ((Url l):xs) = "<link: "++l++">"++toHtml xs
 252 toHtml ((Pre s):xs) = "<pre>"++toHtml s++"</pre>"++toHtml xs
 253 toHtml ((List o l):xs) = "<"++listType o++">\n"++(unlines $ map (\s -> "<li>"++toHtml s++"</li>\n") l) ++ "</"++listType o++">"++toHtml xs
 254
 255 listType True = "ol"
 256 listType False = "ul"
 257
 258 htmlOutput s = case parse wikiParser "" s of
 259                                         Right n -> putStr (toHtml n)
 260                                         Left e -> print e