Possible to list and get old revisions

diff --git a/Main.hs b/Main.hs
index b261901b66d582807a39efe272dd658d9d40b4e2..ea9316b3f68dedc03091d24ce365ea1766cc0fc9 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -15,7 +15,7 @@ testDB = createPGB "wave" "wiki" "wiki" "12wiki34db"
 
 main = do 
        db <- testDB
-       runWithHook [] (\(key:act) -> sp db key) $ sp db "MainPage"
+       runWithHook [] (\(key:act) -> showPage db key) $ showPage db "MainPage"
 
 ps a = standardQuery "Hello" a
 
@@ -36,39 +36,64 @@ editPage db key = do
                p $ defaultSubmit (F3 t a c) (savePage db key) (attr "value" "Send")
                --submit0 (sp db key []) (attr "value" "Send1")
 
-sp db key = do
-       s <- io $ getCurrent db key 
-       standardQuery key $ showPage db key s
 
 savePage db key (F3 t a c) = do
        io $ update db key fulltext author comment
-       s <- io $ getCurrent db key 
-       standardQuery key $ do
-               showPage db key s
+       showPage db key 
   where
        fulltext = value t
        author = value a
        comment = value c 
 
-showPage db key s = do
+showPage db key = do
+       s <- io $ getCurrent db key 
+       standardQuery key $ do
                case s of
                        Nothing -> text "No text added for this keyword"
                        Just (full, date) -> do
-                               case parse wikiParser "" full of
-                                       Right n -> ex n 
-                                       Left e -> do
-                                               text "PARSE ERROR: "
-                                               text (show e)
-                                               p $ text full
+                               parseText full  
                                p $ text $ "Last edited: "++date
                footer db key
 
+parseText full = case parse wikiParser "" full of
+       Right n -> ex n 
+       Left e -> do
+               text "PARSE ERROR: "
+               text (show e)
+               p $ text full
+
 footer db key = do
        hr empty
        table $ tr $ do
                td $ submitLink0 (editPage db key) (text "Edit this page")
-               td $ text "Keyword: " >> activate (sp db) textInputField empty
+               td $ submitLink0 (listRevs db key) (text "List old versions")
+               td $ text "Keyword: " 
+               td $ activate (showPage db) textInputField empty
+
+listRevs db key = do 
+       list <- io $ getList db key 
+       standardQuery key $ table $ do
+               tr $ mapM (\header -> th (text header))
+                       ["Id", "Date", "Author", "Comment"]
+               mapM (revRow db key) list
+
+linkKey db key = submitLink0 (showPage db key) (text key)
+
+revRow db key (id, date, author, comment) = tr $ do
+       td $ submitLink0 (showRev db key id) (text id) 
+       td $ text date
+       td $ linkKey db author
+       td $ text comment
+
+showRev db key id = do
+       s <- io $ get db key id
+       standardQuery key $ do
+               case s of 
+                       Nothing -> text "No such revision"
+                       Just s -> parseText s
+               footer db key
 
+       
 ex [] = return ()
 ex ((Paragraph):xs) = do
        p empty

diff --git a/Wiki.hs b/Wiki.hs
index 337d715eb9160b83cd94e2fa2549de67e09fd6da..7d337c9f679b3b14ce01e1bf6716864a3390fb6d 100644 (file)
--- a/Wiki.hs
+++ b/Wiki.hs
@@ -20,7 +20,7 @@ class Backend a where
        getList :: a -> String -> IO [(String, String, String, String)]
 
        --Keyword -> id -> Full text
-       get :: a -> String -> String -> IO String
+       get :: a -> String -> String -> IO (Maybe String)
 
        --Keyword -> id -> ()
        setCurrent :: a -> String -> String -> IO Bool
@@ -100,7 +100,11 @@ instance Backend PGB where
                list <- selectReturnTuples db $ "SELECT id, timestamp, author, comment from fulltexts WHERE keyword = "++tov key
                return $ map (\[id,date,author,comment] -> (id,date,author,comment)) list
 
-       get (PGB db) key id = return ""
+       get (PGB db) key id = do
+               list <- selectReturnTuples db $ "SELECT fulltext from fulltexts WHERE id = "++tov id    
+               case list of
+                       [s]:_ -> return (Just s)
+                       _ -> return Nothing
 
        setCurrent (PGB db) key id = do
                full <- selectReturnTuples db $ "SELECT keyword FROM fulltexts WHERE keyword="++tov key++" AND id='"++id++"'"