Wiki.hs

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