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 -> toWash 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 toWash [] = return ()
 106 toWash ((Paragraph):xs) = do
 107         p empty
 108         toWash xs
 109 toWash ((Text s):xs) = do
 110         text s
 111         toWash xs
 112 toWash ((Link l d):xs) = do
 113         hlink (URL {unURL = ("wiki?"++l)}) (text d)
 114         toWash xs
 115 toWash ((Bold d):xs) = do
 116         b (toWash d)
 117         toWash xs
 118 toWash ((Emph d):xs) = do
 119         em (toWash d)
 120         toWash xs
 121 toWash ((Underline d):xs) = do
 122         u (toWash d)
 123         toWash xs
 124 toWash ((Strike d):xs) = do
 125         strike (toWash d)
 126         toWash xs
 127 toWash ((Heading n d):xs) = do
 128         heading n $ toWash d
 129         toWash xs
 130 toWash ((Url l):xs) = do
 131         hlink (URL {unURL = (l)}) (text l)
 132         toWash xs
 133 toWash ((Pre s):xs) = do
 134         pre $ text s
 135         toWash 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