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 "localhost" "wiki" "wiki" "12wiki34db"
  14
  15 test key = do
  16         db <- testDB
  17         s <- getCurrent db key
  18         print s
  19
  20 --main = start [] cgi
  21
  22 main = do
  23         db <- testDB
  24         runWithHook [] (\(key:act) -> showPage db (filter (/= '\\') key)) $ showPage db "itproj3"
  25
  26 editPage db key = do
  27         s <- io $ getCurrent db key
  28         s' <- case s of
  29                 Nothing -> return ""
  30                 Just (x,_) -> return x
  31         standardQuery key $ do
  32                 t <- p $ makeTextarea s' (attr_SS "rows" "25" ## attr_SS "cols" "120" ## attr_SS "colspan" "2")
  33                 p empty
  34                 text "Author: "
  35                 a <- textInputField (fieldSIZE 20)
  36                 p empty
  37                 text "Comment: "
  38                 c <- textInputField (fieldSIZE 20)
  39                 p $ defaultSubmit (F3 t a c) (savePage db key) (attr "value" "Send")
  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 "itproj3") (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 $ do
  82                 table $ do
  83                         tr $ mapM (\header -> th (text header))
  84                                 ["Id", "Date", "Author", "Comment"]
  85                         mapM (revRow db key) list
  86                 footer db key
  87
  88 listKeywords db = do
  89         list <- io $ listKeys db
  90         standardQuery "List of keywords" $ do
  91                 table (do
  92                         tr $ th (text "Keyword")
  93                         mapM (\key -> tr $ td $ linkKey db key) list)
  94                 footer db ""
  95
  96 linkKey db key = submitLink0 (showPage db key) (text key)
  97
  98 revRow db key (id, date, author, comment) = tr $ do
  99         td $ submitLink0 (showRev db key id) (text id)
 100         td $ text date
 101         td $ linkKey db author
 102         td $ text comment
 103
 104 showRev db key id = do
 105         s <- io $ get db key id
 106         standardQuery key $ do
 107                 case s of
 108                         Nothing -> text "No such revision"
 109                         Just s -> parseText s
 110                 p empty
 111                 submitLink0 (changeCurrent db key id) (text "Set this version as the current one")
 112                 footer db key
 113 changeCurrent db key id = do
 114         b <- io $ setCurrent db key id
 115         if b then showPage db key
 116                 else standardQuery key $ do
 117                         text "Could not set this revision as the current active one."
 118                         p empty
 119                         linkKey db key
 120
 121 toWash [] = return ()
 122 toWash ((Paragraph):xs) = do
 123         p empty
 124         toWash xs
 125 toWash ((Text s):xs) = do
 126         text s
 127         toWash xs
 128 toWash ((Link l d):xs) = do
 129         hlink (URL {unURL = ("wiki?"++l)}) (text d)
 130         toWash xs
 131 toWash ((Bold d):xs) = do
 132         b (toWash d)
 133         toWash xs
 134 toWash ((Emph d):xs) = do
 135         em (toWash d)
 136         toWash xs
 137 toWash ((Underline d):xs) = do
 138         u (toWash d)
 139         toWash xs
 140 toWash ((Strike d):xs) = do
 141         strike (toWash d)
 142         toWash xs
 143 toWash ((Heading n d):xs) = do
 144         heading n $ toWash d
 145         toWash xs
 146 toWash ((Url l):xs) = do
 147         hlink (URL {unURL = (l)}) (text $ stripMailto l)
 148         toWash xs
 149 toWash ((Pre s):xs) = do
 150         pre $ toWash s
 151         toWash xs
 152 toWash ((List o l):xs) = do
 153         listType o $ mapM (\s -> li $ toWash s) l
 154         toWash xs
 155
 156 listType True = ol
 157 listType False = ul
 158
 159 stripMailto ('m':'a':'i':'l':'t':'o':':':xs) = xs
 160 stripMailto xs = xs
 161
 162 heading 1 = h1
 163 heading 2 = h2
 164 heading 3 = h3
 165 heading 4 = h4
 166 heading 5 = h5
 167 heading 6 = h6