2 Backend (getCurrent,getList,get,setCurrent,update,listKeys)
5 ,Markup (Text, Paragraph, Font, Link, Heading, Url, Pre,List)
6 ,FontOp (Bold, Emph, Mono, Underline, Strike)
16 import Text.ParserCombinators.Parsec
19 --Keyword -> (Full text,date)
20 getCurrent :: a -> String -> IO (Maybe (String,String))
22 --Keyword -> [(id,date,author,comment)]
23 getList :: a -> String -> IO [(String, String, String, String)]
25 --Keyword -> id -> Full text
26 get :: a -> String -> String -> IO (Maybe String)
29 setCurrent :: a -> String -> String -> IO Bool
31 --Keyword -> Full text -> id
32 update :: a -> String -> String -> String -> String -> IO String
35 listKeys :: a -> IO [String]
37 data Markup = Text String
40 | Font FontOp [Markup]
41 | Heading Int [Markup]
44 | List Bool [[Markup]]
46 data FontOp = Bold | Emph | Mono | Underline | Strike
48 type Document = [Markup]
50 wikiParser :: Parser Document
51 wikiParser = many1 pMain
53 firstInLineChars = "#*="
55 pPara :: Parser Markup
58 notFollowedBy $ oneOf firstInLineChars
61 pLink :: Parser Markup
66 [] -> return (Link l l)
67 _ -> return (Link l d)
69 pList :: Bool -> Parser Markup
71 list <- many1 $ try $ pListItem enum
72 return (List enum list)
74 pListItem :: Bool -> Parser [Markup]
78 many (pOneLine <|> try (pOneEol))
82 notFollowedBy (oneOf $ firstInLineChars++"\r\n")
88 pHeading :: Parser Markup
91 level <- many1 $ char '='
93 return (Heading (length level) s)
99 s <- many1 (alphaNum <|> oneOf "?.:&-/~%=\\_")
100 return (Url (proto++"://"++s))
102 pMail :: Parser Markup
104 user <- many1 (alphaNum <|> oneOf ".-_")
106 server <- many1 (alphaNum <|> oneOf ".-_")
107 return (Url ("mailto:"++user++"@"++server))
110 pPre :: Parser Markup
111 pPre = string "<pre>" >> do
112 s <- pUntil (pOneLine <|> pEol) "</pre>"
115 pBold,pEmph,pUnderline,pStrike :: Parser Markup
116 pBold = pFont "**" Bold
117 pEmph = pFont "//" Emph
118 pUnderline = pFont "__" Underline
119 pStrike = pFont "--" Strike
120 pMono = pFont "||" Mono
122 pFont s o = string s >> do
126 pOtherChar :: Parser Markup
131 pText :: Parser Markup
136 pLinkContent :: Parser (String, String)
137 pLinkContent = do try (string "]]" >> return ([],[]))
144 (l,d) <- pLinkContent
147 pStopAt :: String -> Parser Document
148 pStopAt xs = pUntil pOneLine xs
150 pString :: String -> Parser String
151 pString xs = pUntil anyChar xs
153 pEol :: Parser Markup
155 (string "\n" <|> string "\r\n")
158 pUntil :: Parser a -> String -> Parser [a]
159 pUntil p xs = manyTill p (try $ string xs)
161 pMain :: Parser Markup
194 newtype PGB = PGB DBService
196 createPGB :: String -> String -> String -> String -> IO PGB
197 createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db)
199 instance Backend PGB where
201 getCurrent (PGB db) key = do
202 result <- selectReturnTuples db $ "SELECT fulltext,timestamp FROM curtexts WHERE keyword="++tov key
204 [text,date]:_ -> return (Just (text,date))
207 getList (PGB db) key = do
208 list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
211 _ -> return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
213 get (PGB db) key id = do
214 list <- selectReturnTuples db $ "SELECT fulltext from fulltexts WHERE id = "++tov id
216 [s]:_ -> return (Just s)
219 setCurrent (PGB db) key id = do
220 full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"
221 cur <- selectReturnTuples db $ "SELECT keyword FROM curtexts WHERE keyword="++tov key
228 execute db $ "INSERT INTO current (keyword, id) VALUES ("++tov key++","++tov id++")"
230 execute db $ "UPDATE current SET id = "++tov id++" WHERE keyword = "++tov key
231 if rows == 1 then return True
234 update (PGB db) key text author comment = do
235 rows <- execute db $ "INSERT INTO fulltexts (keyword,fulltext, author, comment) VALUES ("++tov key++","++tov text++","++tov author++","++tov comment++")"
236 if rows == 0 then return ""
238 [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')"
239 setCurrent (PGB db) key id
242 listKeys (PGB db) = do
243 list <- selectReturnTuples db $ "SELECT keyword FROM current keyword ORDER BY lower(keyword)"
246 _ -> mapM (\[key] -> return key) list
248 tov :: String -> String
249 tov s = '\'':escapeQuery s++"'"
251 toHtml :: [Markup] -> String
253 toHtml ((Paragraph):xs) = "<p>\n"++toHtml xs
254 toHtml ((Text s):xs) = s++toHtml xs
255 toHtml ((Link l d):xs) = "<link: "++l++" desc: "++d++">"++toHtml xs
256 toHtml ((Font o d):xs) = "<"++htmlFontOp o++">"++toHtml d++"</"++htmlFontOp o++">"++toHtml xs
257 toHtml ((Heading n d):xs) = "\n<h"++show n++">"++toHtml d++"</h"++show n++">\n"++toHtml xs
258 toHtml ((Url l):xs) = "<link: "++l++">"++toHtml xs
259 toHtml ((Pre s):xs) = "<pre>"++toHtml s++"</pre>"++toHtml xs
260 toHtml ((List o l):xs) = "<"++htmlListType o++">\n"++(unlines $ map (\s -> "<li>"++toHtml s++"</li>\n") l) ++ "</"++htmlListType o++">"++toHtml xs
262 htmlFontOp Bold = "b"
263 htmlFontOp Emph = "em"
264 htmlFontOp Mono = "tt"
265 htmlFontOp Underline = "u"
266 htmlFontOp Strike = "strike"
268 htmlListType True = "ol"
269 htmlListType False = "ul"
271 toLatex :: [Markup] -> String
273 toLatex ((Paragraph):xs) = "\n\n"++toLatex xs
274 toLatex ((Text s):xs) = s++toLatex xs
275 toLatex ((Link l d):xs) = "{\\em "++d++"}"++toLatex xs
276 toLatex ((Font o d):xs) = "{\\"++latexFontOp o++" "++toLatex d++"}"++toHtml xs
277 toLatex ((Heading n d):xs) = "\n\\"++(unwords $ take (n-1) $ repeat "sub")++"section{"++toLatex d++"}"++"\n\n"++toLatex xs
278 toLatex ((Url l):xs) = "{\\bf "++l++"}"++toLatex xs
279 toLatex ((Pre s):xs) = "<pre>"++toLatex s++"</pre>"++toLatex xs
280 toLatex ((List o l):xs) = "\n\\begin{"++latexListType o++"}\n"++(unlines $ map (\s -> "\\item "++toLatex s++"\n") l) ++ "\\end{"++latexListType o++"}"++toLatex xs
282 latexFontOp Bold = "bf"
283 latexFontOp Emph = "em"
284 latexFontOp Mono = "tt"
285 latexFontOp Underline = "u"
286 latexFontOp Strike = "strike"
288 latexListType True = "enumeration"
289 latexListType False = "itemize"
291 output s f = case parse wikiParser "" s of
292 Right n -> putStr (f n)
295 htmlOutput s = output s toHtml
296 latexOutput s = output s toLatex