Main.hs

   1 module Main where
   2
   3 import CGI hiding (div, head, map, span, Text)
   4 import RawCGIInternal
   5 import CGIOutput
   6 import CGITypes
   7 import System
   8 import Wiki
   9
  10 import Text.ParserCombinators.Parsec
  11
  12 testDB = createPGB "wave" "wiki" "wiki" "12wiki34db"
  13
  14 --main = start [] cgi
  15
  16 main = do
  17         db <- testDB
  18         runWithHook [] (\(key:act) -> showPage db (filter (/= '\\') key)) $ showPage db "MainPage"
  19
  20 ps a = standardQuery "Hello" a
  21
  22 editPage db key = do
  23         s <- io $ getCurrent db key
  24         s' <- case s of
  25                 Nothing -> return ""
  26                 Just (x,_) -> return x
  27         standardQuery key $ do
  28                 t <- p $ makeTextarea s' (attr_SS "rows" "10" ## attr_SS "cols" "75" ## attr_SS "colspan" "2")
  29                 p empty
  30                 text "Author: "
  31                 a <- textInputField (fieldSIZE 20)
  32                 p empty
  33                 text "Comment: "
  34                 c <- textInputField (fieldSIZE 20)
  35                 --p $ submit (F2 t a) testing (attr "value" "Send")
  36                 p $ defaultSubmit (F3 t a c) (savePage db key) (attr "value" "Send")
  37                 --submit0 (sp db key []) (attr "value" "Send1")
  38
  39
  40 savePage db key (F3 t a c) = do
  41         io $ update db key fulltext author comment
  42         showPage db key
  43   where
  44         fulltext = value t
  45         author = value a
  46         comment = value c
  47
  48 showPage db key = do
  49         s <- io $ getCurrent db key
  50         standardQuery key $ do
  51                 case s of
  52                         Nothing -> text "No text added for this keyword"
  53                         Just (full, date) -> do
  54                                 parseText full
  55                                 p $ tt $ text $ "Last edited: "++date
  56                 footer db key
  57
  58 parseText full = case parse wikiParser "" full of
  59         Right n -> ex n
  60         Left e -> do
  61                 text "PARSE ERROR: "
  62                 text (show e)
  63                 p $ text full
  64
  65 footer db key = do
  66         hr empty
  67         table $ tr $ do
  68                 td $ submitLink0 (editPage db key) (text "Edit this keyword")
  69                 td $ submitLink0 (listRevs db key) (text "List old versions")
  70                 td $ text "Keyword: "
  71                 td $ activate (showPage db) textInputField empty
  72
  73 listRevs db key = do
  74         list <- io $ getList db key
  75         standardQuery key $ table $ do
  76                 tr $ mapM (\header -> th (text header))
  77                         ["Id", "Date", "Author", "Comment"]
  78                 mapM (revRow db key) list
  79
  80 linkKey db key = submitLink0 (showPage db key) (text key)
  81
  82 revRow db key (id, date, author, comment) = tr $ do
  83         td $ submitLink0 (showRev db key id) (text id)
  84         td $ text date
  85         td $ linkKey db author
  86         td $ text comment
  87
  88 showRev db key id = do
  89         s <- io $ get db key id
  90         standardQuery key $ do
  91                 case s of
  92                         Nothing -> text "No such revision"
  93                         Just s -> parseText s
  94                 p empty
  95                 submitLink0 (changeCurrent db key id) (text "Set this version as the current one")
  96                 footer db key
  97 changeCurrent db key id = do
  98         b <- io $ setCurrent db key id
  99         if b then showPage db key
 100                 else standardQuery key $ do
 101                         text "Could not set this revision as the current active one."
 102                         p empty
 103                         linkKey db key
 104
 105 ex [] = return ()
 106 ex ((Paragraph):xs) = do
 107         p empty
 108         ex xs
 109 ex ((Text s):xs) = do
 110         text s
 111         ex xs
 112 ex ((Link l d):xs) = do
 113         hlink (URL {unURL = ("wiki?"++l)}) (text d)
 114         ex xs
 115 ex ((Bold d):xs) = do
 116         b (ex d)
 117         ex xs
 118 ex ((Emph d):xs) = do
 119         em (ex d)
 120         ex xs
 121 ex ((Underline d):xs) = do
 122         u (ex d)
 123         ex xs
 124 ex ((Strike d):xs) = do
 125         strike (ex d)
 126         ex xs
 127 ex ((Heading n d):xs) = do
 128         heading n $ ex d
 129         ex xs
 130 ex ((Url l):xs) = do
 131         hlink (URL {unURL = (l)}) (text l)
 132         ex xs
 133 ex ((Pre s):xs) = do
 134         pre $ text s
 135         ex xs
 136
 137 heading 1 = h1
 138 heading 2 = h2
 139 heading 3 = h3
 140 heading 4 = h4
 141 heading 5 = h5
 142 heading 6 = h6
 143
 144 ex2 [] = []
 145 ex2 ((Paragraph):xs) = "<p>\n"++ex2 xs
 146 ex2 ((Text s):xs) = s++ex2 xs
 147 ex2 ((Link l d):xs) = "<link: "++l++" desc: "++d++">"++ex2 xs
 148 ex2 ((Bold d):xs) = "<b>"++ex2 d++"</b>"++ex2 xs
 149 ex2 ((Emph d):xs) = "<em>"++ex2 d++"</em>"++ex2 xs
 150 ex2 ((Underline d):xs) = "<u>"++ex2 d++"</u>"++ex2 xs
 151 ex2 ((Strike d):xs) = "<strike>"++ex2 d++"</strike>"++ex2 xs
 152 ex2 ((Heading n d):xs) = "\n<h"++show n++">"++ex2 d++"</h"++show n++">\n"++ex2 xs
 153 ex2 ((Url l):xs) = "<link: "++l++">"++ex2 xs
 154 ex2 ((Pre s):xs) = "<pre>"++s++"</pre>"++ex2 xs
 155
 156
 157 test s = case parse wikiParser "" s of
 158                                         Right n -> do
 159                                                 putStr (ex2 n)
 160                                         Left e -> do
 161                                                 print e