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 = do
  81         string "**"
  82         s <- pStringParser "**"
  83         return (Bold s)
  84
  85 pEmph = do
  86         string "//"
  87         s <- pStringParser "//"
  88         return (Emph s)
  89
  90 pUnderline = do
  91         string "__"
  92         s <- pStringParser "__"
  93         return (Underline s)
  94
  95 pStrike = do
  96         string "--"
  97         s <- pStringParser "--"
  98         return (Strike s)
  99
 100 pStringParser xs = do
 101         try (string xs >> return []) <|> (do
 102                 s <- pMain
 103                 ss <- pStringParser xs
 104                 return (s:ss))
 105
 106 pString xs = do
 107         try (string xs >> return []) <|> (do
 108         s <- anyChar
 109         ss <- pString xs
 110         return (s:ss))
 111
 112 pHeading = do
 113         many1 pEol
 114         level <- many1 $ char '='
 115         char ' '
 116         s <- pStringParser (' ':level)
 117         return (Heading (length level) s)
 118
 119 pURL = do
 120         proto <- many1 letter
 121         string "://"
 122         s <- many1 (alphaNum <|> oneOf "?.:&-/")
 123         return (Url (proto++"://"++s))
 124
 125 pMain = try (pHeading)
 126         <|> (try (pPara)
 127         <|> pSpace
 128         <|> try(pBold)
 129         <|> try(pEmph)
 130         <|> try(pUnderline)
 131         <|> try(pStrike)
 132         <|> try (pLink)
 133         <|> try (pURL)
 134         <|> pOtherChar
 135         <|> pText)
 136
 137 pOtherChar = do
 138         c <- oneOf "*,;.:!?[]()'\"=-%$£<>/\\|"
 139         return (Text (c:[]))
 140
 141 pText = do
 142         t <- many1 alphaNum--(noneOf ['\n','\r','[',']'])
 143         return (Text t)
 144
 145
 146 newtype PGB = PGB DBService
 147
 148 createPGB :: String -> String -> String -> String -> IO PGB
 149 createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db)
 150
 151
 152 testDB = createPGB "wave" "wiki" "wiki" "12wiki34db"
 153
 154 instance Backend PGB where
 155
 156         getCurrent (PGB db) key = do
 157                 result <- selectReturnTuples db $ "SELECT fulltext,timestamp FROM curtexts WHERE keyword="++tov key
 158                 case result of
 159                         [text,date]:_ -> return (Just (text,date))
 160                         _ -> return Nothing
 161
 162         getList (PGB db) key = do
 163                 list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
 164                 case list of
 165                         [[]] -> return []
 166                         _ -> return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
 167
 168         get (PGB db) key id = do
 169                 list <- selectReturnTuples db $ "SELECT fulltext from fulltexts WHERE id = "++tov id
 170                 case list of
 171                         [s]:_ -> return (Just s)
 172                         _ -> return Nothing
 173
 174         setCurrent (PGB db) key id = do
 175                 full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"
 176                 cur <- selectReturnTuples db $ "SELECT keyword FROM curtexts WHERE keyword="++tov key
 177                 case full of
 178                         [[]] -> do
 179                                 return False
 180                         _  -> do
 181                                 rows <- case cur of
 182                                         [[]] -> do
 183                                                 execute db $ "INSERT INTO current (keyword, id) VALUES ("++tov key++","++tov id++")"
 184                                         _  -> do
 185                                                 execute db $ "UPDATE current SET id = "++tov id++" WHERE keyword = "++tov key
 186                                 if rows == 1 then return True
 187                                         else return False
 188
 189         update (PGB db) key text author comment = do
 190                 rows <- execute db $ "INSERT INTO fulltexts (keyword,fulltext, author, comment) VALUES ("++tov key++","++tov text++","++tov author++","++tov comment++")"
 191                 if rows == 0 then return ""
 192                         else do
 193                                 [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')"
 194                                 setCurrent (PGB db) key id
 195                                 return id
 196
 197
 198 tov :: String -> String
 199 tov s = '\'':escapeQuery s++"'"
 200
 201