IPPrint 0.3 now provides pshow
[darcs-mirror-latutman.git] / haskell / Main.hs
1 {-# OPTIONS -fcontext-stack=30 -fglasgow-exts -fth -fallow-undecidable-instances #-}
2 import HAppS.Server
3 import HAppS.Server.SimpleHTTP
4 import HAppS.State
5 import HAppS.State.EventTH
6 import HAppS.Server.MessageWrap
7 import HAppS.Data
8
9 import Control.Monad.Reader
10
11 import State
12 import Types
13
14 import MyHAppS
15
16
17 main = putStrLn "Running..." >> stdMain (simpleHTTP http :*: stateFuns)
18   where http = [--debugFilter -- we want to see debug messages in the console
19                 xslt xsltproc "xslt/style.xsl" [
20                 --multi [
21                         method GET $ ok [Elem "index" []],
22                         dir "handins" [
23                                 method GET $ query ListHandIns >>= ok
24                         ],
25                         dir "assignment" [
26                                 method GET $ query ListAssignments >>= ok,
27                                 dir "add" [
28                                         method GET $ do
29                                                 let ass = Assignment (AssName "") (MaxPoints 4)
30                                                 ok $ toHTMLForm "add" "add" "POST" ass,
31                                         withData $ \ass -> [
32                                                 method POST $ do
33                                                         update (AddAssignment ass)
34                                                         redirect "."
35                                                 ]
36                                         ],
37                                 path $ \name -> [ require (query (GetAssignment name)) $ \ass -> [
38                                         dir "edit" [
39                                                 method GET $ ok $ toHTMLForm "edit" "edit" "POST" ass,
40                                                 withData $ \newass -> [ method POST $ do
41                                                         update (UpdateAssignment ass newass)
42                                                         let (AssName newname) = assName newass
43                                                         redirect $ "../"++newname++"/"
44                                                         ]
45                                                 ],
46                                         dir "delete" [
47                                                 method GET $ do
48                                                         update (DeleteAssignment ass)
49                                                         redirect ".."
50                                                 ],
51                                         method GET $ ok ass,
52                                         dir "add" [
53                                                 method GET $ do
54                                                         let hi = HandIn (StudentID "") (AssName "") (Points 0)
55                                                         ok $ toHTMLForm "add" "add" "POST" hi,
56                                                 withData $ \hi -> [
57                                                         method POST $ do
58                                                                 update (AddHandIn hi)
59                                                                 redirect "."
60                                                         ],
61                                                 method POST $ ok "Invalid data"
62                                                 ],
63                                         path $ \studentid -> [ require (query (GetHandIn ass studentid)) $ \hi -> [
64                                                 dir "edit" [
65                                                         method GET $ ok $ toHTMLForm "edit" "edit" "POST" hi,
66                                                         withData $ \newHi -> [ method POST $ do
67                                                                 update (UpdateHandIn hi newHi)
68                                                                 let (StudentID newID) = hiStudentID newHi
69                                                                 redirect $ "../"++newID++"/"
70                                                                 ]
71                                                         ],
72                                                 dir "delete" [
73                                                         method GET $ do
74                                                                 update (DeleteHandIn hi)
75                                                                 redirect ".."
76                                                         ],
77                                                 method GET $ ok hi
78                                                 ]]
79                                         ]]
80                                 ],
81                         dir "maintenance" (plainEdit GetCompleteState PutCompleteState),
82                         dir "student" [
83                                 method GET $ query ListStudents >>= ok . Students,
84                                 dir "add" [
85                                         method GET $ do
86                                                 let ass = defaultValue :: Student
87                                                 ok $ toHTMLForm "add" "add" "POST" ass,
88                                         withData $ \ass -> [
89                                                 method POST $ do
90                                                         update (AddStudent ass)
91                                                         redirect "."
92                                                 ],
93                                         Reader $ \rq -> print (rqInputs rq) >> return Nothing
94                                         ],
95                                 path $ \studentid -> [ require (query (GetStudent studentid)) $ \ass -> [
96                                         dir "edit" [
97                                                 method GET $ ok $ toHTMLForm "edit" "edit" "POST" ass,
98                                                 withData $ \newStud -> [ method POST $ do
99                                                         update (UpdateStudent ass newStud)
100                                                         let (StudentID newstudentid) = studentID newStud
101                                                         redirect $ "../"++newstudentid
102                                                         ]
103                                                 ],
104                                         dir "delete" [
105                                                 method GET $ do
106                                                         update (DeleteStudent studentid)
107                                                         redirect ".."
108                                                 ],
109                                         method GET $ query (GetStudent studentid) >>= ok
110                                         ]]
111                                 ]
112                         ]
113                 ]