initial check in of what stuff I tried so far, not looking very good
[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
15 main = putStrLn "Running..." >> stdMain (simpleHTTP http :*: stateFuns)
16   where http = [--debugFilter -- we want to see debug messages in the console
17                 xslt xsltproc "xslt/style.xsl" [
18                 --multi [
19                         method GET $ ok [Elem "index" []],
20                         dir "handins" [
21                                 method GET $ query ListHandIns >>= ok
22                         ],
23                         dir "assignment" [
24                                 method GET $ query ListAssignments >>= ok,
25                                 dir "add" [
26                                         method GET $ do
27                                                 let ass = Assignment (AssName "") (MaxPoints 4)
28                                                 ok $ toHTMLForm "add" "add" "POST" ass,
29                                         withData $ \ass -> [
30                                                 method POST $ do
31                                                         update (AddAssignment ass)
32                                                         redirect "."
33                                                 ]
34                                         ],
35                                 path $ \name -> [ require (query (GetAssignment name)) $ \ass -> [
36                                         dir "edit" [
37                                                 method GET $ ok $ toHTMLForm "edit" "edit" "POST" ass,
38                                                 withData $ \newass -> [ method POST $ do
39                                                         update (UpdateAssignment ass newass)
40                                                         let (AssName newname) = assName newass
41                                                         redirect $ "../"++newname++"/"
42                                                         ]
43                                                 ],
44                                         dir "delete" [
45                                                 method GET $ do
46                                                         update (DeleteAssignment ass)
47                                                         redirect ".."
48                                                 ],
49                                         method GET $ ok ass,
50                                         dir "add" [
51                                                 method GET $ do
52                                                         let hi = HandIn (StudentID "") (AssName "") (Points 0)
53                                                         ok $ toHTMLForm "add" "add" "POST" hi,
54                                                 withData $ \hi -> [
55                                                         method POST $ do
56                                                                 update (AddHandIn hi)
57                                                                 redirect "."
58                                                         ],
59                                                 method POST $ ok "Invalid data"
60                                                 ],
61                                         path $ \studentid -> [ require (query (GetHandIn ass studentid)) $ \hi -> [
62                                                 dir "edit" [
63                                                         method GET $ ok $ toHTMLForm "edit" "edit" "POST" hi,
64                                                         withData $ \newHi -> [ method POST $ do
65                                                                 update (UpdateHandIn hi newHi)
66                                                                 let (StudentID newID) = hiStudentID newHi
67                                                                 redirect $ "../"++newID++"/"
68                                                                 ]
69                                                         ],
70                                                 dir "delete" [
71                                                         method GET $ do
72                                                                 update (DeleteHandIn hi)
73                                                                 redirect ".."
74                                                         ],
75                                                 method GET $ ok hi
76                                                 ]]
77                                         ]]
78                                 ],
79                         dir "student" [
80                                 method GET $ query ListStudents >>= ok . Students,
81                                 dir "add" [
82                                         method GET $ do
83                                                 let ass = defaultValue :: Student
84                                                 ok $ toHTMLForm "add" "add" "POST" ass,
85                                         withData $ \ass -> [
86                                                 method POST $ do
87                                                         update (AddStudent ass)
88                                                         redirect "."
89                                                 ],
90                                         Reader $ \rq -> print (rqInputs rq) >> return Nothing
91                                         ],
92                                 path $ \studentid -> [ require (query (GetStudent studentid)) $ \ass -> [
93                                         dir "edit" [
94                                                 method GET $ ok $ toHTMLForm "edit" "edit" "POST" ass,
95                                                 withData $ \newStud -> [ method POST $ do
96                                                         update (UpdateStudent ass newStud)
97                                                         let (StudentID newstudentid) = studentID newStud
98                                                         redirect $ "../"++newstudentid
99                                                         ]
100                                                 ],
101                                         dir "delete" [
102                                                 method GET $ do
103                                                         update (DeleteStudent studentid)
104                                                         redirect ".."
105                                                 ],
106                                         method GET $ query (GetStudent studentid) >>= ok
107                                         ]]
108                                 ]
109                         ]
110                 ]