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