Wiki.hs

   1 module Wiki (
   2         Backend (getCurrent,getList,get,setCurrent,update)
   3         ,PGB
   4         ,createPGB
   5         ,Markup (Text, Paragraph, Link)
   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 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
  35 type Document = [Markup]
  36
  37 wikiParser :: GenParser Char st Document
  38 wikiParser = do
  39         s <- (try (pPara)
  40                 <|> pSpace
  41                 <|> try (pLinkLong)
  42                 <|> try (pLink)
  43                 <|> pOtherChar
  44                 <|> pText)
  45         ss <- (wikiParser <|> return [])
  46         return (s:ss)
  47
  48 pPara = do
  49         pEol
  50         pEol
  51         return (Paragraph)
  52
  53
  54 pSpace = do
  55         space
  56         return (Text " ")
  57
  58 pEol = char '\n' <|> do
  59         char '\r'
  60         char '\n'
  61
  62 pLinkLong = do
  63         string "[["
  64         l <- many1 $ noneOf ['|']
  65         char '|'
  66         d <- many1 $ noneOf [']']
  67         string "]]"
  68         return (Link l d)
  69 pLink = do
  70         string "[["
  71         l <- many1 $ noneOf ['|','[',']']
  72         string "]]"
  73         return (Link l l)
  74 pOtherChar = do
  75         c <- satisfy validChar
  76         return (Text (c:[]))
  77
  78 pText = do
  79         t <- many1 alphaNum--(noneOf ['\n','\r','[',']'])
  80         return (Text t)
  81
  82 validChar ',' = True
  83 validChar '.' = True
  84 validChar '!' = True
  85 validChar '?' = True
  86 validChar '[' = True
  87 validChar ']' = True
  88 validChar '\'' = True
  89 validChar '"' = True
  90 validChar '=' = True
  91 validChar '-' = True
  92 validChar '%' = True
  93 validChar '$' = True
  94 validChar '£' = True
  95 validChar '<' = True
  96 validChar '>' = True
  97 validChar '/' = True
  98 validChar '\\' = True
  99 validChar '|' = True
 100 validChar _ = False
 101
 102
 103 newtype PGB = PGB DBService
 104
 105 createPGB :: String -> String -> String -> String -> IO PGB
 106 createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db)
 107
 108
 109 testDB = createPGB "wave" "wiki" "wiki" "12wiki34db"
 110
 111 instance Backend PGB where
 112
 113         getCurrent (PGB db) key = do
 114                 result <- selectReturnTuples db $ "SELECT fulltext,timestamp FROM curtexts WHERE keyword="++tov key
 115                 case result of
 116                         [text,date]:_ -> return (Just (text,date))
 117                         _ -> return Nothing
 118
 119         getList (PGB db) key = do
 120                 list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
 121                 return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
 122
 123         get (PGB db) key id = return ""
 124
 125         setCurrent (PGB db) key id = do
 126                 full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"
 127                 cur <- selectReturnTuples db $ "SELECT keyword FROM curtexts WHERE keyword="++tov key
 128                 case full of
 129                         [[]] -> do
 130                                 return False
 131                         _  -> do
 132                                 rows <- case cur of
 133                                         [[]] -> do
 134                                                 execute db $ "INSERT INTO current (keyword, id) VALUES ("++tov key++","++tov id++")"
 135                                         _  -> do
 136                                                 execute db $ "UPDATE current SET id = "++tov id++" WHERE keyword = "++tov key
 137                                 if rows == 1 then return True
 138                                         else return False
 139
 140         update (PGB db) key text author comment = do
 141                 rows <- execute db $ "INSERT INTO fulltexts (keyword,fulltext, author, comment) VALUES ("++tov key++","++tov text++","++tov author++","++tov comment++")"
 142                 if rows == 0 then return ""
 143                         else do
 144                                 [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')"
 145                                 setCurrent (PGB db) key id
 146                                 return id
 147
 148
 149 tov :: String -> String
 150 tov s = '\'':escapeQuery s++"'"
 151
 152