]> ruin.nu Git - yawbih.git/blob - Wiki.hs
Parser instead of GenParser Char st
[yawbih.git] / Wiki.hs
1 module Wiki (
2         Backend (getCurrent,getList,get,setCurrent,update,listKeys)
3         ,PGB
4         ,createPGB
5         ,Markup (Text, Paragraph, Link, Bold, Emph, Heading, Url, Underline, Strike, Pre,List)
6         ,Document
7         ,wikiParser
8         ,htmlOutput
9
10 ) where
11
12 import Dbconnect
13 import Data.Char
14 import Text.ParserCombinators.Parsec
15
16 class Backend a where
17         --Keyword -> (Full text,date)
18         getCurrent :: a -> String -> IO (Maybe (String,String))
19
20         --Keyword -> [(id,date,author,comment)]
21         getList :: a -> String -> IO [(String, String, String, String)]
22
23         --Keyword -> id -> Full text
24         get :: a -> String -> String -> IO (Maybe String)
25
26         --Keyword -> id -> ()
27         setCurrent :: a -> String -> String -> IO Bool
28
29         --Keyword -> Full text -> id
30         update :: a -> String -> String -> String -> String -> IO String
31
32         --[Keyword]
33         listKeys :: a -> IO [String]
34
35 data Markup = Text String
36         | Paragraph 
37         | Link String String
38         | Bold [Markup]
39         | Emph [Markup]
40         | Heading Int [Markup]
41         | Url String
42         | Underline [Markup]
43         | Strike [Markup]
44         | Pre String
45         | List [[Markup]]
46
47 type Document = [Markup]
48
49 wikiParser :: Parser Document   
50 wikiParser = many1 pMain
51
52 pPara :: Parser Markup  
53 pPara = count 2 pEol >> return (Paragraph)
54
55 pLink :: Parser Markup  
56 pLink = do
57         string "[["
58         (l,d) <- pLinkContent
59         case d of
60                 [] -> return (Link l l)
61                 _ -> return (Link l d)
62
63 pList :: Parser Markup
64 pList = do
65         list <- many1 $ try pListItem 
66         return (List list)
67
68 pListItem :: Parser [Markup]
69 pListItem = do
70         many1 pEol
71         char '*'
72         many pOneLine
73         
74 pHeading :: Parser Markup       
75 pHeading = do
76         many1 pEol
77         level <- many1 $ char '='
78         char ' '
79         s <- pStopAt (' ':level)
80         return (Heading (length level) s)
81
82 pURL :: Parser Markup   
83 pURL = do
84         proto <- many1 letter
85         string "://"
86         s <- many1 (alphaNum <|> oneOf "?.:&-/")
87         return (Url (proto++"://"++s))
88
89 pMail :: Parser Markup
90 pMail = do
91         user <- many1 (alphaNum <|> oneOf ".-_")
92         char '@'
93         server <- many1 (alphaNum <|> oneOf ".-_")
94         return (Url ("mailto:"++user++"@"++server))
95         
96
97 pPre :: Parser Markup   
98 pPre = string "<pre>" >> do
99         s <- pString "</pre>"
100         return (Pre s)
101
102 pBold,pEmph,pUnderline,pStrike :: Parser Markup 
103 pBold = pS "**" (\s -> Bold s)
104 pEmph = pS "//" (\s -> Emph s)
105 pUnderline = pS "__" (\s -> Underline s)
106 pStrike = pS "--" (\s -> Strike s)
107 pS s f = string s >> do
108         s <- pStopAt s
109         return (f s)
110
111 pOtherChar :: Parser Markup     
112 pOtherChar = do
113         c <- noneOf "\n\r"
114         return (Text (c:[]))
115
116 pText :: Parser Markup  
117 pText = do
118         t <- many1 alphaNum
119         return (Text t)
120
121 pLinkContent :: Parser (String, String) 
122 pLinkContent = do try (string "]]" >> return ([],[])) 
123         <|> try (do
124                 string " | "
125                 d <- pString "]]"
126                 return ([],d))
127         <|> (do
128                 c <- anyChar
129                 (l,d) <- pLinkContent
130                 return (c:l,d))
131
132 pStopAt :: String -> Parser Document    
133 pStopAt xs = pUntil pOneLine xs
134
135 pString :: String -> Parser String      
136 pString xs = pUntil anyChar xs
137
138 pEol :: Parser Markup   
139 pEol = do
140         (string "\n" <|> string "\r\n")
141         return (Text "\r\n")
142
143 pUntil :: Parser a -> String -> Parser [a]      
144 pUntil p xs = manyTill p (try $ string xs)
145         
146 pMain :: Parser Markup  
147 pMain = choice [
148         try (pHeading)
149         ,try pList
150         ,try (pPara) 
151         ,try(pPre) 
152         ,try(pBold) 
153         ,try(pEmph) 
154         ,try(pUnderline) 
155         ,try(pStrike) 
156         ,try (pLink)
157         ,try (pURL)
158         ,try (pMail)
159         ,pText
160         ,pOtherChar
161         ,pEol
162         ]
163
164 pOneLine = choice [
165         try pBold
166         ,try pEmph
167         ,try pUnderline
168         ,try pStrike
169         ,try pLink
170         ,try pURL
171         ,try pMail
172         ,pText
173         ,pOtherChar
174         ]
175
176 newtype PGB = PGB DBService
177
178 createPGB :: String -> String -> String -> String -> IO PGB
179 createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db)
180
181 instance Backend PGB where
182
183         getCurrent (PGB db) key = do 
184                 result <- selectReturnTuples db $ "SELECT fulltext,timestamp FROM curtexts WHERE keyword="++tov key
185                 case result of
186                         [text,date]:_ -> return (Just (text,date))
187                         _ -> return Nothing
188
189         getList (PGB db) key = do
190                 list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
191                 case list of
192                         [[]] -> return []
193                         _ -> return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
194
195         get (PGB db) key id = do
196                 list <- selectReturnTuples db $ "SELECT fulltext from fulltexts WHERE id = "++tov id    
197                 case list of
198                         [s]:_ -> return (Just s)
199                         _ -> return Nothing
200
201         setCurrent (PGB db) key id = do
202                 full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"
203                 cur <- selectReturnTuples db $ "SELECT keyword FROM curtexts WHERE keyword="++tov key
204                 case full of
205                         [[]] -> do
206                                 return False
207                         _  -> do
208                                 rows <- case cur of
209                                         [[]] -> do
210                                                 execute db $ "INSERT INTO current (keyword, id) VALUES ("++tov key++","++tov id++")"
211                                         _  -> do
212                                                 execute db $ "UPDATE current SET id = "++tov id++" WHERE keyword = "++tov key
213                                 if rows == 1 then return True
214                                         else return False 
215
216         update (PGB db) key text author comment = do
217                 rows <- execute db $ "INSERT INTO fulltexts (keyword,fulltext, author, comment) VALUES ("++tov key++","++tov text++","++tov author++","++tov comment++")"
218                 if rows == 0 then return ""
219                         else do
220                                 [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')" 
221                                 setCurrent (PGB db) key id
222                                 return id
223
224         listKeys (PGB db) = do
225                 list <- selectReturnTuples db $ "SELECT keyword FROM current keyword ORDER BY lower(keyword)"
226                 case list of
227                         [[]] -> return []
228                         _ -> mapM (\[key] -> return key) list
229
230 tov :: String -> String
231 tov s = '\'':escapeQuery s++"'"
232                 
233 toHtml :: [Markup] -> String
234 toHtml [] = []
235 toHtml ((Paragraph):xs) = "<p>\n"++toHtml xs
236 toHtml ((Text s):xs) = s++toHtml xs
237 toHtml ((Link l d):xs) = "<link: "++l++" desc: "++d++">"++toHtml xs
238 toHtml ((Bold d):xs) = "<b>"++toHtml d++"</b>"++toHtml xs
239 toHtml ((Emph d):xs) = "<em>"++toHtml d++"</em>"++toHtml xs
240 toHtml ((Underline d):xs) = "<u>"++toHtml d++"</u>"++toHtml xs
241 toHtml ((Strike d):xs) = "<strike>"++toHtml d++"</strike>"++toHtml xs
242 toHtml ((Heading n d):xs) = "\n<h"++show n++">"++toHtml d++"</h"++show n++">\n"++toHtml xs
243 toHtml ((Url l):xs) = "<link: "++l++">"++toHtml xs
244 toHtml ((Pre s):xs) = "<pre>"++s++"</pre>"++toHtml xs
245 toHtml ((List l):xs) = "<ul>\n"++(unlines $ map (\s -> "<li>"++toHtml s++"</li>\n") l) ++ "</ul>"++toHtml xs
246
247 htmlOutput s = case parse wikiParser "" s of
248                                         Right n -> putStr (toHtml n)
249                                         Left e -> print e