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