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