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