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,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         | Heading Int [Markup]
  41         | Url String
  42         | Underline [Markup]
  43         | Strike [Markup]
  44         | Pre [Markup]
  45         | List Bool [[Markup]]
  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 = pS "**" (\s -> Bold s)
 106 pEmph = pS "//" (\s -> Emph s)
 107 pUnderline = pS "__" (\s -> Underline s)
 108 pStrike = pS "--" (\s -> Strike s)
 109 pS s f = string s >> do
 110         s <- pStopAt s
 111         return (f s)
 112
 113 pOtherChar :: Parser Markup
 114 pOtherChar = do
 115         c <- noneOf "\n\r"
 116         return (Text (c:[]))
 117
 118 pText :: Parser Markup
 119 pText = do
 120         t <- many1 alphaNum
 121         return (Text t)
 122
 123 pLinkContent :: Parser (String, String)
 124 pLinkContent = do try (string "]]" >> return ([],[]))
 125         <|> try (do
 126                 string " | "
 127                 d <- pString "]]"
 128                 return ([],d))
 129         <|> (do
 130                 c <- anyChar
 131                 (l,d) <- pLinkContent
 132                 return (c:l,d))
 133
 134 pStopAt :: String -> Parser Document
 135 pStopAt xs = pUntil pOneLine xs
 136
 137 pString :: String -> Parser String
 138 pString xs = pUntil anyChar xs
 139
 140 pEol :: Parser Markup
 141 pEol = do
 142         (string "\n" <|> string "\r\n")
 143         return (Text "\r\n")
 144
 145 pUntil :: Parser a -> String -> Parser [a]
 146 pUntil p xs = manyTill p (try $ string xs)
 147
 148 pMain :: Parser Markup
 149 pMain = choice [
 150         try (pHeading)
 151         ,try $ pList True
 152         ,try $ pList False
 153         ,try (pPara)
 154         ,try(pPre)
 155         ,try(pBold)
 156         ,try(pEmph)
 157         ,try(pUnderline)
 158         ,try(pStrike)
 159         ,try (pLink)
 160         ,try (pURL)
 161         ,try (pMail)
 162         ,pText
 163         ,pOtherChar
 164         ,pEol
 165         ]
 166
 167 pOneLine = choice [
 168         try pBold
 169         ,try pEmph
 170         ,try pUnderline
 171         ,try pStrike
 172         ,try pLink
 173         ,try pURL
 174         ,try pMail
 175         ,pText
 176         ,pOtherChar
 177         ]
 178
 179 newtype PGB = PGB DBService
 180
 181 createPGB :: String -> String -> String -> String -> IO PGB
 182 createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db)
 183
 184 instance Backend PGB where
 185
 186         getCurrent (PGB db) key = do
 187                 result <- selectReturnTuples db $ "SELECT fulltext,timestamp FROM curtexts WHERE keyword="++tov key
 188                 case result of
 189                         [text,date]:_ -> return (Just (text,date))
 190                         _ -> return Nothing
 191
 192         getList (PGB db) key = do
 193                 list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
 194                 case list of
 195                         [[]] -> return []
 196                         _ -> return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
 197
 198         get (PGB db) key id = do
 199                 list <- selectReturnTuples db $ "SELECT fulltext from fulltexts WHERE id = "++tov id
 200                 case list of
 201                         [s]:_ -> return (Just s)
 202                         _ -> return Nothing
 203
 204         setCurrent (PGB db) key id = do
 205                 full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"
 206                 cur <- selectReturnTuples db $ "SELECT keyword FROM curtexts WHERE keyword="++tov key
 207                 case full of
 208                         [[]] -> do
 209                                 return False
 210                         _  -> do
 211                                 rows <- case cur of
 212                                         [[]] -> do
 213                                                 execute db $ "INSERT INTO current (keyword, id) VALUES ("++tov key++","++tov id++")"
 214                                         _  -> do
 215                                                 execute db $ "UPDATE current SET id = "++tov id++" WHERE keyword = "++tov key
 216                                 if rows == 1 then return True
 217                                         else return False
 218
 219         update (PGB db) key text author comment = do
 220                 rows <- execute db $ "INSERT INTO fulltexts (keyword,fulltext, author, comment) VALUES ("++tov key++","++tov text++","++tov author++","++tov comment++")"
 221                 if rows == 0 then return ""
 222                         else do
 223                                 [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')"
 224                                 setCurrent (PGB db) key id
 225                                 return id
 226
 227         listKeys (PGB db) = do
 228                 list <- selectReturnTuples db $ "SELECT keyword FROM current keyword ORDER BY lower(keyword)"
 229                 case list of
 230                         [[]] -> return []
 231                         _ -> mapM (\[key] -> return key) list
 232
 233 tov :: String -> String
 234 tov s = '\'':escapeQuery s++"'"
 235
 236 toHtml :: [Markup] -> String
 237 toHtml [] = []
 238 toHtml ((Paragraph):xs) = "<p>\n"++toHtml xs
 239 toHtml ((Text s):xs) = s++toHtml xs
 240 toHtml ((Link l d):xs) = "<link: "++l++" desc: "++d++">"++toHtml xs
 241 toHtml ((Bold d):xs) = "<b>"++toHtml d++"</b>"++toHtml xs
 242 toHtml ((Emph d):xs) = "<em>"++toHtml d++"</em>"++toHtml xs
 243 toHtml ((Underline d):xs) = "<u>"++toHtml d++"</u>"++toHtml xs
 244 toHtml ((Strike d):xs) = "<strike>"++toHtml d++"</strike>"++toHtml xs
 245 toHtml ((Heading n d):xs) = "\n<h"++show n++">"++toHtml d++"</h"++show n++">\n"++toHtml xs
 246 toHtml ((Url l):xs) = "<link: "++l++">"++toHtml xs
 247 toHtml ((Pre s):xs) = "<pre>"++toHtml s++"</pre>"++toHtml xs
 248 toHtml ((List o l):xs) = "<"++listType o++">\n"++(unlines $ map (\s -> "<li>"++toHtml s++"</li>\n") l) ++ "</"++listType o++">"++toHtml xs
 249
 250 listType True = "ol"
 251 listType False = "ul"
 252
 253 htmlOutput s = case parse wikiParser "" s of
 254                                         Right n -> putStr (toHtml n)
 255                                         Left e -> print e