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