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 Backend
  10 import Control.Monad
  11
  12 import Text.ParserCombinators.Parsec
  13
  14 --backend = createPGB "hostname" "database" "user" "password"
  15 --If you want to implement this function here, then remove the import of Backend
  16
  17 main = do
  18         db <- backend
  19         runWithHook [] (\(key:act) -> showPage db (filter (/= '\\') key)) $ showPage db "itproj3"
  20
  21 editPage db key = do
  22         s <- io $ getCurrent db key
  23         s' <- case s of
  24                 Nothing -> return ""
  25                 Just (x,_) -> return x
  26         standardQuery key $ do
  27                 t <- p $ makeTextarea s' (attr_SS "rows" "25" ## attr_SS "cols" "120" ## attr_SS "colspan" "2")
  28                 p empty
  29                 text "Author: "
  30                 a <- textInputField (fieldSIZE 20)
  31                 p empty
  32                 text "Comment: "
  33                 c <- textInputField (fieldSIZE 20)
  34                 p $ defaultSubmit (F3 t a c) (savePage db key) (attr "value" "Send")
  35
  36 savePage db key (F3 t a c) = do
  37         io $ update db key fulltext author comment
  38         showPage db key
  39   where
  40         fulltext = value t
  41         author = value a
  42         comment = value c
  43
  44 showPage db key = do
  45         s <- io $ getCurrent db key
  46         standardQuery key $ do
  47                 case s of
  48                         Nothing -> text "No text added for this keyword"
  49                         Just (full, date) -> do
  50                                 parseText full
  51                                 p $ tt $ text $ "Last edited: "++date
  52                 footer db key
  53
  54 showLatex db key = do
  55         s <- io $ getCurrent db key
  56         standardQuery key $ do
  57                 case s of
  58                         Nothing -> text "No text added for this keyword"
  59                         Just (full, date) -> do
  60                                 parseLatex full
  61                                 p $ tt $ text $ "Last edited: "++date
  62                 footer db key
  63
  64 parseText full = case parse wikiParser "" full of
  65         Right n -> toWash n
  66         Left e -> do
  67                 text "PARSE ERROR: "
  68                 text (show e)
  69                 p $ text full
  70
  71 parseLatex full = case parse wikiParser "" full of
  72         Right n -> pre $ text $ toLatex n
  73         Left e -> do
  74                 text "PARSE ERROR: "
  75                 text (show e)
  76
  77 footer db key = do
  78         hr empty
  79         table $ do
  80         tr $ do
  81                 td $ text "Keyword: "
  82                 searchKey <- td $  textInputField empty
  83                 td $ defaultSubmit (F1 searchKey) (\(F1 sk) -> showPage db (value sk)) (attr "value" "Go")
  84         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 $ activate (showPage db) textInputField empty
  91
  92 e "" = False
  93 e _ = True
  94
  95 listRevs db key = do
  96         list <- io $ getList db key
  97         standardQuery key $ do
  98                 table $ do
  99                         tr $ mapM (\header -> th (text header))
 100                                 ["Id", "Date", "Author", "Comment"]
 101                         mapM (revRow db key) list
 102                 footer db key
 103
 104 listKeywords db = do
 105         list <- io $ listKeys db
 106         standardQuery "List of keywords" $ do
 107                 table (do
 108                         tr $ th (text "Keyword")
 109                         mapM (\key -> tr $ td $ linkKey db key) list)
 110                 footer db ""
 111
 112 linkKey db key = submitLink0 (showPage db key) (text key)
 113
 114 revRow db key (id, date, author, comment) = tr $ do
 115         td $ submitLink0 (showRev db key id) (text id)
 116         td $ text date
 117         td $ linkKey db author
 118         td $ text comment
 119
 120 showRev db key id = do
 121         s <- io $ get db key id
 122         standardQuery key $ do
 123                 case s of
 124                         Nothing -> text "No such revision"
 125                         Just s -> parseText s
 126                 p empty
 127                 submitLink0 (changeCurrent db key id) (text "Set this version as the current one")
 128                 footer db key
 129 changeCurrent db key id = do
 130         b <- io $ setCurrent db key id
 131         if b then showPage db key
 132                 else standardQuery key $ do
 133                         text "Could not set this revision as the current active one."
 134                         p empty
 135                         linkKey db key
 136
 137 toWash [] = return ()
 138 toWash ((Paragraph):xs) = do
 139         p empty
 140         toWash xs
 141 toWash ((Text s):xs) = do
 142         text s
 143         toWash xs
 144 toWash ((Link l d):xs) = do
 145         hlink (URL {unURL = ("wiki?"++l)}) (text d)
 146         toWash xs
 147 toWash ((Font o d):xs) = do
 148         fontOp o (toWash d)
 149         toWash xs
 150 toWash ((Heading n d):xs) = do
 151         heading n $ toWash d
 152         toWash xs
 153 toWash ((Url l):xs) = do
 154         hlink (URL {unURL = (l)}) (text $ stripMailto l)
 155         toWash xs
 156 toWash ((Pre s):xs) = do
 157         pre $ toWash s
 158         toWash xs
 159 toWash ((List o l):xs) = do
 160         listType o $ mapM (\s -> li $ toWash s) l
 161         toWash xs
 162
 163 listType True = ol
 164 listType False = ul
 165
 166 stripMailto ('m':'a':'i':'l':'t':'o':':':xs) = xs
 167 stripMailto xs = xs
 168
 169 fontOp Bold = b
 170 fontOp Emph = em
 171 fontOp Mono = tt
 172 fontOp Underline = u
 173 fontOp Strike = strike
 174
 175 heading 1 = h1
 176 heading 2 = h2
 177 heading 3 = h3
 178 heading 4 = h4
 179 heading 5 = h5
 180 heading 6 = h6