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 showLatex db key = do
  60         s <- io $ getCurrent db key
  61         standardQuery key $ do
  62                 case s of
  63                         Nothing -> text "No text added for this keyword"
  64                         Just (full, date) -> do
  65                                 parseLatex full
  66                                 p $ tt $ text $ "Last edited: "++date
  67                 footer db key
  68
  69 parseText full = case parse wikiParser "" full of
  70         Right n -> toWash n
  71         Left e -> do
  72                 text "PARSE ERROR: "
  73                 text (show e)
  74                 p $ text full
  75
  76 parseLatex full = case parse wikiParser "" full of
  77         Right n -> pre $ text $ toLatex n
  78         Left e -> do
  79                 text "PARSE ERROR: "
  80                 text (show e)
  81
  82 footer db key = do
  83         hr empty
  84         table $ tr $ do
  85                 td $ submitLink0 (showPage db "itproj3") (text "Back to main page")
  86                 when (e key) $ td $ submitLink0 (editPage db key) (text "Edit this keyword")
  87                 when (e key) $ td $ submitLink0 (listRevs db key) (text "List old versions")
  88                 when (e key) $ td $ submitLink0 (showLatex db key) (text "Output latex")
  89                 td $ submitLink0 (listKeywords db) (text "List all keywords")
  90                 td $ text "Keyword: "
  91                 td $ activate (showPage db) textInputField empty
  92
  93 e "" = False
  94 e _ = True
  95
  96 listRevs db key = do
  97         list <- io $ getList db key
  98         standardQuery key $ do
  99                 table $ do
 100                         tr $ mapM (\header -> th (text header))
 101                                 ["Id", "Date", "Author", "Comment"]
 102                         mapM (revRow db key) list
 103                 footer db key
 104
 105 listKeywords db = do
 106         list <- io $ listKeys db
 107         standardQuery "List of keywords" $ do
 108                 table (do
 109                         tr $ th (text "Keyword")
 110                         mapM (\key -> tr $ td $ linkKey db key) list)
 111                 footer db ""
 112
 113 linkKey db key = submitLink0 (showPage db key) (text key)
 114
 115 revRow db key (id, date, author, comment) = tr $ do
 116         td $ submitLink0 (showRev db key id) (text id)
 117         td $ text date
 118         td $ linkKey db author
 119         td $ text comment
 120
 121 showRev db key id = do
 122         s <- io $ get db key id
 123         standardQuery key $ do
 124                 case s of
 125                         Nothing -> text "No such revision"
 126                         Just s -> parseText s
 127                 p empty
 128                 submitLink0 (changeCurrent db key id) (text "Set this version as the current one")
 129                 footer db key
 130 changeCurrent db key id = do
 131         b <- io $ setCurrent db key id
 132         if b then showPage db key
 133                 else standardQuery key $ do
 134                         text "Could not set this revision as the current active one."
 135                         p empty
 136                         linkKey db key
 137
 138 toWash [] = return ()
 139 toWash ((Paragraph):xs) = do
 140         p empty
 141         toWash xs
 142 toWash ((Text s):xs) = do
 143         text s
 144         toWash xs
 145 toWash ((Link l d):xs) = do
 146         hlink (URL {unURL = ("wiki?"++l)}) (text d)
 147         toWash xs
 148 toWash ((Font o d):xs) = do
 149         fontOp o (toWash d)
 150         toWash xs
 151 toWash ((Heading n d):xs) = do
 152         heading n $ toWash d
 153         toWash xs
 154 toWash ((Url l):xs) = do
 155         hlink (URL {unURL = (l)}) (text $ stripMailto l)
 156         toWash xs
 157 toWash ((Pre s):xs) = do
 158         pre $ toWash s
 159         toWash xs
 160 toWash ((List o l):xs) = do
 161         listType o $ mapM (\s -> li $ toWash s) l
 162         toWash xs
 163
 164 listType True = ol
 165 listType False = ul
 166
 167 stripMailto ('m':'a':'i':'l':'t':'o':':':xs) = xs
 168 stripMailto xs = xs
 169
 170 fontOp Bold = b
 171 fontOp Emph = em
 172 fontOp Mono = tt
 173 fontOp Underline = u
 174 fontOp Strike = strike
 175
 176 heading 1 = h1
 177 heading 2 = h2
 178 heading 3 = h3
 179 heading 4 = h4
 180 heading 5 = h5
 181 heading 6 = h6