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