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