Wiki.hs

   1 module Wiki (
   2         Backend (getCurrent,getList,get,setCurrent,update,listKeys)
   3         ,PGB
   4         ,createPGB
   5         ,Markup (Text, Paragraph, Link, Bold, Emph, Heading, Url, Underline, Strike, Pre)
   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         | Heading Int [Markup]
  41         | Url String
  42         | Underline [Markup]
  43         | Strike [Markup]
  44         | Pre String
  45
  46 type Document = [Markup]
  47
  48 wikiParser :: GenParser Char st Document
  49 wikiParser = do
  50         s <- pMain
  51         ss <- (wikiParser <|> return [])
  52         return (s:ss)
  53
  54 pPara = do
  55         pEol
  56         pEol
  57         return (Paragraph)
  58
  59
  60 pSpace = do
  61         space
  62         return (Text " ")
  63
  64 pEol = char '\n' <|> do
  65         char '\r'
  66         char '\n'
  67
  68 pLinkParser = do try (string "]]" >> return ([],[]))
  69         <|> try (do
  70                 string " | "
  71                 d <- pString "]]"
  72                 return ([],d))
  73         <|> (do
  74                 c <- anyChar
  75                 (l,d) <- pLinkParser
  76                 return (c:l,d))
  77
  78 pLink = do
  79         string "[["
  80         (l,d) <- pLinkParser
  81         case d of
  82                 [] -> return (Link l l)
  83                 _ -> return (Link l d)
  84
  85 pBold = pS "**" (\s -> Bold s)
  86 pEmph = pS "//" (\s -> Emph s)
  87 pUnderline = pS "__" (\s -> Underline s)
  88 pStrike = pS "--" (\s -> Strike s)
  89
  90 pS s f = do
  91         string s
  92         s <- pStopAt s
  93         return (f s)
  94
  95 pStopAt xs = do
  96         try (string xs >> return []) <|> (do
  97                 s <- pMain
  98                 ss <- pStopAt xs
  99                 return (s:ss))
 100
 101 pString xs = do
 102         try (string xs >> return []) <|> (do
 103         s <- anyChar
 104         ss <- pString xs
 105         return (s:ss))
 106
 107 pHeading = do
 108         many1 pEol
 109         level <- many1 $ char '='
 110         char ' '
 111         s <- pStopAt (' ':level)
 112         return (Heading (length level) s)
 113
 114 pURL = do
 115         proto <- many1 letter
 116         string "://"
 117         s <- many1 (alphaNum <|> oneOf "?.:&-/")
 118         return (Url (proto++"://"++s))
 119
 120 pPre = do
 121         string "<pre>"
 122         s <- pString "</pre>"
 123         return (Pre s)
 124
 125 pMain = try (pHeading)
 126         <|> (try (pPara)
 127         <|> pSpace
 128         <|> try(pPre)
 129         <|> try(pBold)
 130         <|> try(pEmph)
 131         <|> try(pUnderline)
 132         <|> try(pStrike)
 133         <|> try (pLink)
 134         <|> try (pURL)
 135         <|> pOtherChar
 136         <|> pText)
 137
 138 pOtherChar = do
 139         c <- oneOf "*,;.:!?[]()'\"=-%$£<>/\\|"
 140         return (Text (c:[]))
 141
 142 pText = do
 143         t <- many1 alphaNum--(noneOf ['\n','\r','[',']'])
 144         return (Text t)
 145
 146
 147 newtype PGB = PGB DBService
 148
 149 createPGB :: String -> String -> String -> String -> IO PGB
 150 createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db)
 151
 152
 153 testDB = createPGB "wave" "wiki" "wiki" "12wiki34db"
 154
 155 instance Backend PGB where
 156
 157         getCurrent (PGB db) key = do
 158                 result <- selectReturnTuples db $ "SELECT fulltext,timestamp FROM curtexts WHERE keyword="++tov key
 159                 case result of
 160                         [text,date]:_ -> return (Just (text,date))
 161                         _ -> return Nothing
 162
 163         getList (PGB db) key = do
 164                 list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
 165                 case list of
 166                         [[]] -> return []
 167                         _ -> return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
 168
 169         get (PGB db) key id = do
 170                 list <- selectReturnTuples db $ "SELECT fulltext from fulltexts WHERE id = "++tov id
 171                 case list of
 172                         [s]:_ -> return (Just s)
 173                         _ -> return Nothing
 174
 175         setCurrent (PGB db) key id = do
 176                 full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"
 177                 cur <- selectReturnTuples db $ "SELECT keyword FROM curtexts WHERE keyword="++tov key
 178                 case full of
 179                         [[]] -> do
 180                                 return False
 181                         _  -> do
 182                                 rows <- case cur of
 183                                         [[]] -> do
 184                                                 execute db $ "INSERT INTO current (keyword, id) VALUES ("++tov key++","++tov id++")"
 185                                         _  -> do
 186                                                 execute db $ "UPDATE current SET id = "++tov id++" WHERE keyword = "++tov key
 187                                 if rows == 1 then return True
 188                                         else return False
 189
 190         update (PGB db) key text author comment = do
 191                 rows <- execute db $ "INSERT INTO fulltexts (keyword,fulltext, author, comment) VALUES ("++tov key++","++tov text++","++tov author++","++tov comment++")"
 192                 if rows == 0 then return ""
 193                         else do
 194                                 [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')"
 195                                 setCurrent (PGB db) key id
 196                                 return id
 197
 198         listKeys (PGB db) = do
 199                 list <- selectReturnTuples db $ "SELECT keyword FROM fulltexts GROUP BY keyword ORDER BY lower(keyword)"
 200                 case list of
 201                         [[]] -> return []
 202                         _ -> mapM (\[key] -> return key) list
 203
 204
 205
 206 tov :: String -> String
 207 tov s = '\'':escapeQuery s++"'"
 208
 209 toHtml :: [Markup] -> String
 210 toHtml [] = []
 211 toHtml ((Paragraph):xs) = "<p>\n"++toHtml xs
 212 toHtml ((Text s):xs) = s++toHtml xs
 213 toHtml ((Link l d):xs) = "<link: "++l++" desc: "++d++">"++toHtml xs
 214 toHtml ((Bold d):xs) = "<b>"++toHtml d++"</b>"++toHtml xs
 215 toHtml ((Emph d):xs) = "<em>"++toHtml d++"</em>"++toHtml xs
 216 toHtml ((Underline d):xs) = "<u>"++toHtml d++"</u>"++toHtml xs
 217 toHtml ((Strike d):xs) = "<strike>"++toHtml d++"</strike>"++toHtml xs
 218 toHtml ((Heading n d):xs) = "\n<h"++show n++">"++toHtml d++"</h"++show n++">\n"++toHtml xs
 219 toHtml ((Url l):xs) = "<link: "++l++">"++toHtml xs
 220 toHtml ((Pre s):xs) = "<pre>"++s++"</pre>"++toHtml xs
 221
 222
 223 htmlOutput s = case parse wikiParser "" s of
 224                                         Right n -> do
 225                                                 putStr (toHtml n)
 226                                         Left e -> do
 227                                                 print e