Wiki.hs

   1 module Wiki (
   2         Backend (getCurrent,getList,get,setCurrent,update)
   3         ,PGB
   4         ,createPGB
   5         ,Markup (Text, Paragraph, Link, Bold, Emph, Heading, Url, Underline, Strike, Pre)
   6         ,Document
   7         ,wikiParser
   8
   9 ) where
  10
  11 import Dbconnect
  12 import Data.Char
  13 import Text.ParserCombinators.Parsec
  14
  15 class Backend a where
  16         --Keyword -> (Full text,date)
  17         getCurrent :: a -> String -> IO (Maybe (String,String))
  18
  19         --Keyword -> [(id,date,author,comment)]
  20         getList :: a -> String -> IO [(String, String, String, String)]
  21
  22         --Keyword -> id -> Full text
  23         get :: a -> String -> String -> IO (Maybe String)
  24
  25         --Keyword -> id -> ()
  26         setCurrent :: a -> String -> String -> IO Bool
  27
  28         --Keyword -> Full text -> id
  29         update :: a -> String -> String -> String -> String -> IO String
  30
  31 data Markup = Text String
  32         | Paragraph
  33         | Link String String
  34         | Bold [Markup]
  35         | Emph [Markup]
  36         | Heading Int [Markup]
  37         | Url String
  38         | Underline [Markup]
  39         | Strike [Markup]
  40         | Pre String
  41
  42 type Document = [Markup]
  43
  44 wikiParser :: GenParser Char st Document
  45 wikiParser = do
  46         s <- pMain
  47         ss <- (wikiParser <|> return [])
  48         return (s:ss)
  49
  50 pPara = do
  51         pEol
  52         pEol
  53         return (Paragraph)
  54
  55
  56 pSpace = do
  57         space
  58         return (Text " ")
  59
  60 pEol = char '\n' <|> do
  61         char '\r'
  62         char '\n'
  63
  64 pLinkParser = do try (string "]]" >> return ([],[]))
  65         <|> try (do
  66                 string " | "
  67                 d <- pString "]]"
  68                 return ([],d))
  69         <|> (do
  70                 c <- anyChar
  71                 (l,d) <- pLinkParser
  72                 return (c:l,d))
  73
  74 pLink = do
  75         string "[["
  76         (l,d) <- pLinkParser
  77         case d of
  78                 [] -> return (Link l l)
  79                 _ -> return (Link l d)
  80
  81 pBold = pS "**" (\s -> Bold s)
  82 pEmph = pS "//" (\s -> Emph s)
  83 pUnderline = pS "__" (\s -> Underline s)
  84 pStrike = pS "--" (\s -> Strike s)
  85
  86 pS s f = do
  87         string s
  88         s <- pStopAt s
  89         return (f s)
  90
  91 pStopAt xs = do
  92         try (string xs >> return []) <|> (do
  93                 s <- pMain
  94                 ss <- pStopAt xs
  95                 return (s:ss))
  96
  97 pString xs = do
  98         try (string xs >> return []) <|> (do
  99         s <- anyChar
 100         ss <- pString xs
 101         return (s:ss))
 102
 103 pHeading = do
 104         many1 pEol
 105         level <- many1 $ char '='
 106         char ' '
 107         s <- pStopAt (' ':level)
 108         return (Heading (length level) s)
 109
 110 pURL = do
 111         proto <- many1 letter
 112         string "://"
 113         s <- many1 (alphaNum <|> oneOf "?.:&-/")
 114         return (Url (proto++"://"++s))
 115
 116 pPre = do
 117         string "<pre>"
 118         s <- pString "</pre>"
 119         return (Pre s)
 120
 121 pMain = try (pHeading)
 122         <|> (try (pPara)
 123         <|> pSpace
 124         <|> try(pPre)
 125         <|> try(pBold)
 126         <|> try(pEmph)
 127         <|> try(pUnderline)
 128         <|> try(pStrike)
 129         <|> try (pLink)
 130         <|> try (pURL)
 131         <|> pOtherChar
 132         <|> pText)
 133
 134 pOtherChar = do
 135         c <- oneOf "*,;.:!?[]()'\"=-%$£<>/\\|"
 136         return (Text (c:[]))
 137
 138 pText = do
 139         t <- many1 alphaNum--(noneOf ['\n','\r','[',']'])
 140         return (Text t)
 141
 142
 143 newtype PGB = PGB DBService
 144
 145 createPGB :: String -> String -> String -> String -> IO PGB
 146 createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db)
 147
 148
 149 testDB = createPGB "wave" "wiki" "wiki" "12wiki34db"
 150
 151 instance Backend PGB where
 152
 153         getCurrent (PGB db) key = do
 154                 result <- selectReturnTuples db $ "SELECT fulltext,timestamp FROM curtexts WHERE keyword="++tov key
 155                 case result of
 156                         [text,date]:_ -> return (Just (text,date))
 157                         _ -> return Nothing
 158
 159         getList (PGB db) key = do
 160                 list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
 161                 case list of
 162                         [[]] -> return []
 163                         _ -> return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
 164
 165         get (PGB db) key id = do
 166                 list <- selectReturnTuples db $ "SELECT fulltext from fulltexts WHERE id = "++tov id
 167                 case list of
 168                         [s]:_ -> return (Just s)
 169                         _ -> return Nothing
 170
 171         setCurrent (PGB db) key id = do
 172                 full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"
 173                 cur <- selectReturnTuples db $ "SELECT keyword FROM curtexts WHERE keyword="++tov key
 174                 case full of
 175                         [[]] -> do
 176                                 return False
 177                         _  -> do
 178                                 rows <- case cur of
 179                                         [[]] -> do
 180                                                 execute db $ "INSERT INTO current (keyword, id) VALUES ("++tov key++","++tov id++")"
 181                                         _  -> do
 182                                                 execute db $ "UPDATE current SET id = "++tov id++" WHERE keyword = "++tov key
 183                                 if rows == 1 then return True
 184                                         else return False
 185
 186         update (PGB db) key text author comment = do
 187                 rows <- execute db $ "INSERT INTO fulltexts (keyword,fulltext, author, comment) VALUES ("++tov key++","++tov text++","++tov author++","++tov comment++")"
 188                 if rows == 0 then return ""
 189                         else do
 190                                 [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')"
 191                                 setCurrent (PGB db) key id
 192                                 return id
 193
 194
 195 tov :: String -> String
 196 tov s = '\'':escapeQuery s++"'"
 197
 198