initial check in of what stuff I tried so far, not looking very good
authormail <mail@joachim-breitner.de>
Fri, 28 Sep 2007 19:03:43 +0000 (19:03 +0000)
committermail <mail@joachim-breitner.de>
Fri, 28 Sep 2007 19:03:43 +0000 (19:03 +0000)
haskell/Main.hs [new file with mode: 0644]
haskell/State.hs [new file with mode: 0644]
haskell/State/State_000.hs [new file with mode: 0644]
haskell/Types.hs [new file with mode: 0644]

diff --git a/haskell/Main.hs b/haskell/Main.hs
new file mode 100644 (file)
index 0000000..b49234e
--- /dev/null
@@ -0,0 +1,110 @@
+{-# OPTIONS -fcontext-stack=30 -fglasgow-exts -fth -fallow-undecidable-instances #-}
+import HAppS.Server
+import HAppS.Server.SimpleHTTP
+import HAppS.State
+import HAppS.State.EventTH
+import HAppS.Server.MessageWrap
+import HAppS.Data
+
+import Control.Monad.Reader
+
+import State
+import Types
+
+
+main = putStrLn "Running..." >> stdMain (simpleHTTP http :*: stateFuns)
+  where http = [--debugFilter -- we want to see debug messages in the console
+               xslt xsltproc "xslt/style.xsl" [
+               --multi [
+                       method GET $ ok [Elem "index" []],
+                       dir "handins" [
+                               method GET $ query ListHandIns >>= ok
+                       ],
+                       dir "assignment" [
+                               method GET $ query ListAssignments >>= ok,
+                               dir "add" [
+                                       method GET $ do
+                                               let ass = Assignment (AssName "") (MaxPoints 4)
+                                               ok $ toHTMLForm "add" "add" "POST" ass,
+                                       withData $ \ass -> [
+                                               method POST $ do
+                                                       update (AddAssignment ass)
+                                                       redirect "."
+                                               ]
+                                       ],
+                               path $ \name -> [ require (query (GetAssignment name)) $ \ass -> [
+                                       dir "edit" [
+                                               method GET $ ok $ toHTMLForm "edit" "edit" "POST" ass,
+                                               withData $ \newass -> [ method POST $ do
+                                                       update (UpdateAssignment ass newass)
+                                                       let (AssName newname) = assName newass
+                                                       redirect $ "../"++newname++"/"
+                                                       ]
+                                               ],
+                                       dir "delete" [
+                                               method GET $ do
+                                                       update (DeleteAssignment ass)
+                                                       redirect ".."
+                                               ],
+                                       method GET $ ok ass,
+                                       dir "add" [
+                                               method GET $ do
+                                                       let hi = HandIn (StudentID "") (AssName "") (Points 0)
+                                                       ok $ toHTMLForm "add" "add" "POST" hi,
+                                               withData $ \hi -> [
+                                                       method POST $ do
+                                                               update (AddHandIn hi)
+                                                               redirect "."
+                                                       ],
+                                               method POST $ ok "Invalid data"
+                                               ],
+                                       path $ \studentid -> [ require (query (GetHandIn ass studentid)) $ \hi -> [
+                                               dir "edit" [
+                                                       method GET $ ok $ toHTMLForm "edit" "edit" "POST" hi,
+                                                       withData $ \newHi -> [ method POST $ do
+                                                               update (UpdateHandIn hi newHi)
+                                                               let (StudentID newID) = hiStudentID newHi
+                                                               redirect $ "../"++newID++"/"
+                                                               ]
+                                                       ],
+                                               dir "delete" [
+                                                       method GET $ do
+                                                               update (DeleteHandIn hi)
+                                                               redirect ".."
+                                                       ],
+                                               method GET $ ok hi
+                                               ]]
+                                       ]]
+                               ],
+                       dir "student" [
+                               method GET $ query ListStudents >>= ok . Students,
+                               dir "add" [
+                                       method GET $ do
+                                               let ass = defaultValue :: Student
+                                               ok $ toHTMLForm "add" "add" "POST" ass,
+                                       withData $ \ass -> [
+                                               method POST $ do
+                                                       update (AddStudent ass)
+                                                       redirect "."
+                                               ],
+                                       Reader $ \rq -> print (rqInputs rq) >> return Nothing
+                                       ],
+                               path $ \studentid -> [ require (query (GetStudent studentid)) $ \ass -> [
+                                       dir "edit" [
+                                               method GET $ ok $ toHTMLForm "edit" "edit" "POST" ass,
+                                               withData $ \newStud -> [ method POST $ do
+                                                       update (UpdateStudent ass newStud)
+                                                       let (StudentID newstudentid) = studentID newStud
+                                                       redirect $ "../"++newstudentid
+                                                       ]
+                                               ],
+                                       dir "delete" [
+                                               method GET $ do
+                                                       update (DeleteStudent studentid)
+                                                       redirect ".."
+                                               ],
+                                       method GET $ query (GetStudent studentid) >>= ok
+                                       ]]
+                               ]
+                       ]
+               ]
diff --git a/haskell/State.hs b/haskell/State.hs
new file mode 100644 (file)
index 0000000..beff784
--- /dev/null
@@ -0,0 +1,107 @@
+{-# OPTIONS -fglasgow-exts -fth -fallow-undecidable-instances #-}
+
+module State where
+
+import Types
+import HAppS.Data
+import HAppS.State
+import HAppS.State.EventTH
+import HAppS.Server
+import Data.Maybe
+import Data.List
+import Control.Monad.State (modify)
+
+import qualified State.State_000 as Old
+
+$(deriveAll [''Read,''Show,''Default]
+  [d|
+      data State = State {assignments :: [Assignment],
+                         students    :: [Student],
+                         handIns     :: [HandIn] }
+   |]
+ )
+
+instance Xml State where
+    version _ = Just "001"
+    otherVersion _ = Other (error "Other" :: Old.State)
+
+instance Migrate Old.State State where
+    migrate os = State ass stud hi
+     where     ass = map migrate (Old.assignments os)
+               stud = Old.students os
+               hi = concatMap extr (Old.assignments os)
+               extr oas = map (\(Old.HandIn s p) -> HandIn s (Old.assName oas) p) (Old.handIns oas)
+
+instance Migrate Old.Assignment Assignment where
+    migrate (Old.Assignment n p _) = Assignment n p
+
+$(inferStartState ''State) 
+$(inferRecordUpdaters ''State) 
+
+
+listAssignments :: Query State AssignmentsWithHandIns
+listAssignments = do   s <- askState
+                       let perAss ass = AssignmentWithHandIns ass (filter ((== assName ass) . hiAssName) (handIns s))
+                       return . AssignmentsWithHandIns $ map perAss (assignments s)
+
+
+listStudents :: Query State [Student]
+listStudents = students `fmap` askState
+
+listHandIns :: Query State (Table AssName StudentID HandIn)
+listHandIns = do s <- askState
+                 let colHeads = sort $ map assName $ assignments s
+                    rowHeads = sort $ map studentID $ students s
+                    his  = handIns s
+                    rows = map mkRow rowHeads
+                    mkRow id = TableRow (TableHead id) (map (mkCell id) colHeads)
+                    mkCell id name = TableCell $ listToMaybe $ filter (selectHandIn name id) his
+                return $ Table (map TableHead colHeads) rows
+
+
+getAssignment :: AssName ->  Query State (Maybe Assignment)
+getAssignment name = return . findAssignment name . assignments =<< askState
+
+getStudent :: StudentID ->  Query State (Maybe Student)
+getStudent id = return . findStudent id =<< listStudents
+
+deleteAssignment :: Assignment ->  Update State ()
+deleteAssignment ass = withAssignments $ modify (removeAssignment ass) 
+
+deleteStudent :: StudentID ->  Update State ()
+deleteStudent id = withStudents $ modify (removeStudent id)    
+
+updateAssignment :: Assignment -> Assignment -> Update State ()
+updateAssignment ass newAss = withAssignments $ modify (map replace)
+  where replace a = if assName a /= assName ass then a else newAss
+
+updateStudent :: Student ->Student -> Update State ()
+updateStudent stud newStud = withStudents $ modify (map replace)
+  where replace s = if studentID s /= studentID stud then s else newStud
+
+addAssignment :: Assignment -> Update State ()
+addAssignment ass = withAssignments $ modify (ass :)
+
+addStudent :: Student -> Update State ()
+addStudent stud = withStudents $ modify (stud :)
+
+getHandIn :: Assignment -> StudentID -> Query State (Maybe HandIn)
+getHandIn ass studentid = return . find check . handIns =<< askState
+  where check hi = hiStudentID hi == studentid && hiAssName hi == assName ass
+
+updateHandIn :: HandIn -> HandIn -> Update State ()
+updateHandIn hi newHi = withHandIns $ modify (map replace)
+  where replace h = if hiAssName h /= hiAssName hi then h else
+                       if hiStudentID h /= hiStudentID hi then h else newHi
+
+addHandIn :: HandIn -> Update State ()
+addHandIn hi = withHandIns $ modify (hi :)
+
+deleteHandIn :: HandIn -> Update State ()
+deleteHandIn hi = withHandIns $ modify (removeHandIn hi)
+
+$(expose ['listAssignments, 'getAssignment, 'addAssignment, 'updateAssignment, 'deleteAssignment,
+          'listHandIns, 'getHandIn, 'addHandIn, 'updateHandIn, 'deleteHandIn,
+         'listStudents, 'getStudent, 'addStudent, 'updateStudent, 'deleteStudent
+         ])
+
diff --git a/haskell/State/State_000.hs b/haskell/State/State_000.hs
new file mode 100644 (file)
index 0000000..1cd3814
--- /dev/null
@@ -0,0 +1,40 @@
+{-# OPTIONS -fglasgow-exts -fth -fallow-undecidable-instances #-}
+
+module State.State_000 where
+
+import Types hiding (HandIn(..), handinDataType, handinDataType1Constr,
+                   Assignment(..), assignmentDataType, assignmentDataType1Constr)
+import HAppS.Data
+import HAppS.State
+import HAppS.State.EventTH
+import HAppS.Server
+import Data.Maybe
+import Control.Monad.State (modify)
+
+$( deriveAll [''Ord,''Eq,''Read,''Show,''Default] 
+   [d|
+       data HandIn = HandIn {
+               hiStudentID :: StudentID,
+               hiPoints :: Points
+       }
+
+       data Assignment = Assignment {
+               assName :: AssName,
+               maxPoints :: MaxPoints,
+               handIns :: [HandIn]
+       }
+   |]
+ )
+
+$(deriveAll [''Read,''Show,''Default]
+  [d|
+      data State = State {assignments :: [Assignment],
+                         students    :: [Student] }
+   |]
+ )
+
+instance Xml State where
+    version _ = Just "000"
+--    otherVersion _ = Other (error "Other" :: Old.State)
+
+
diff --git a/haskell/Types.hs b/haskell/Types.hs
new file mode 100644 (file)
index 0000000..60f0553
--- /dev/null
@@ -0,0 +1,59 @@
+{-# OPTIONS -fglasgow-exts -fth -fallow-undecidable-instances #-}
+
+module Types where 
+
+import HAppS.Data
+import HAppS.Server.SimpleHTTP
+import Data.List
+
+$( deriveAll [''Ord,''Eq,''Read,''Show,''Default] 
+   [d|
+      
+      newtype Points    = Points Int
+      newtype StudentID = StudentID String deriving (FromReqURI)
+      newtype MaxPoints = MaxPoints Int
+      newtype AssName   = AssName String deriving (FromReqURI)
+      newtype Password  = Password String
+      newtype EMail     = EMail String
+
+      data HandIn = HandIn {
+       hiStudentID :: StudentID,
+       hiAssName :: AssName,
+       hiPoints :: Points
+       }
+      newtype HandIns = HandIns [HandIn]
+
+      data Assignment = Assignment {
+       assName :: AssName,
+       maxPoints :: MaxPoints
+       }
+      newtype Assignments = Assignments [Assignment]
+
+      data Student = Student {
+        studentID :: StudentID,
+       password :: Password,
+       email :: EMail
+       }
+      newtype Students = Students [Student]
+      
+      -- Views
+      data AssignmentWithHandIns = AssignmentWithHandIns Assignment [HandIn]
+      newtype AssignmentsWithHandIns = AssignmentsWithHandIns [AssignmentWithHandIns]
+
+      newtype TableHead r = TableHead r
+      data TableCell a = TableCell (Maybe a)
+      data TableRow r a = TableRow (TableHead r) [TableCell a]
+      data Table c r a = Table [TableHead c] [TableRow r a]
+
+ |] )
+
+
+findAssignment name  = find ((==name) . assName)
+removeAssignment ass  = filter ((/=assName ass) . assName)
+
+findStudent name  = find ((==name) . studentID)
+removeStudent name  = filter ((/=name) . studentID)
+
+selectHandIn name id hi = hiAssName hi == name && hiStudentID hi == id
+removeHandIn hi = filter (not . selectHandIn (hiAssName hi) (hiStudentID hi))
+