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) -> sp db key) $ sp 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 sp db key = do
  40         s <- io $ getCurrent db key
  41         standardQuery key $ showPage db key s
  42
  43 savePage db key (F3 t a c) = do
  44         io $ update db key fulltext author comment
  45         s <- io $ getCurrent db key
  46         standardQuery key $ do
  47                 showPage db key s
  48   where
  49         fulltext = value t
  50         author = value a
  51         comment = value c
  52
  53 showPage db key s = do
  54                 case s of
  55                         Nothing -> text "No text added for this keyword"
  56                         Just (full, date) -> do
  57                                 case parse wikiParser "" full of
  58                                         Right n -> ex n
  59                                         Left e -> do
  60                                                 text "PARSE ERROR: "
  61                                                 text (show e)
  62                                                 p $ text full
  63                                 p $ text $ "Last edited: "++date
  64                 footer db key
  65
  66 footer db key = do
  67         hr empty
  68         table $ tr $ do
  69                 td $ submitLink0 (editPage db key) (text "Edit this page")
  70                 td $ text "Keyword: " >> activate (sp db) textInputField empty
  71
  72 ex [] = return ()
  73 ex ((Paragraph):xs) = do
  74         p empty
  75         ex xs
  76 ex ((Text s):xs) = do
  77         text s
  78         ex xs
  79 ex ((Link l d):xs) = do
  80         hlink (URL {unURL = ("wiki?"++l)}) (text d)
  81         ex xs
  82
  83 ex2 [] = []
  84 ex2 ((Paragraph):xs) = "<p>"++ex2 xs
  85 ex2 ((Text s):xs) = s++ex2 xs
  86 ex2 ((Link l d):xs) = "<link: "++l++" desc: "++d++">"++ex2 xs
  87
  88
  89 test s = case parse wikiParser "" s of
  90                                         Right n -> do
  91                                                 print (ex2 n)
  92                                         Left e -> do
  93                                                 print e