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