General State Editor
authormail <mail@joachim-breitner.de>
Sat, 29 Sep 2007 18:52:33 +0000 (18:52 +0000)
committermail <mail@joachim-breitner.de>
Sat, 29 Sep 2007 18:52:33 +0000 (18:52 +0000)
haskell/Main.hs
haskell/MyHAppS.hs [new file with mode: 0644]
haskell/State.hs
xslt/style.xsl

index b49234e..66d454a 100644 (file)
@@ -11,6 +11,8 @@ import Control.Monad.Reader
 import State
 import Types
 
+import MyHAppS
+
 
 main = putStrLn "Running..." >> stdMain (simpleHTTP http :*: stateFuns)
   where http = [--debugFilter -- we want to see debug messages in the console
@@ -76,6 +78,7 @@ main = putStrLn "Running..." >> stdMain (simpleHTTP http :*: stateFuns)
                                                ]]
                                        ]]
                                ],
+                       dir "maintenance" (plainEdit GetCompleteState PutCompleteState),
                        dir "student" [
                                method GET $ query ListStudents >>= ok . Students,
                                dir "add" [
diff --git a/haskell/MyHAppS.hs b/haskell/MyHAppS.hs
new file mode 100644 (file)
index 0000000..5cbd240
--- /dev/null
@@ -0,0 +1,66 @@
+{-# OPTIONS -fcontext-stack=30 -fglasgow-exts -fth -fallow-undecidable-instances #-}
+module MyHAppS (
+       plainEdit
+       ) where
+
+import HAppS.Data
+import HAppS.Server
+import HAppS.State
+import HAppS.State.Transaction
+import HAppS.Server.SimpleHTTP
+
+
+import Language.Haskell.Parser
+import Language.Haskell.Pretty
+import Text.Read
+
+$( deriveAll [''Ord,''Eq,''Read,''Show,''Default] 
+   [d|
+     newtype FormData = FormData String 
+ |] )
+
+-- plainEdit :: (Read a, Show a) => IO a -> (a -> IO ()) -> [ServerPart]
+plainEdit :: ( UpdateEvent ue (),
+               Read a, Show a,
+               QueryEvent qe a) => qe -> (a -> ue) -> [ServerPart]
+
+plainEdit getter setter = [
+       method GET $ query getter >>= ok . toDataForm "." "POST" . pshow,
+       withData $ \(FormData fdat) -> [ method POST $ update (setter (read fdat)) >> redirect "." ]
+       ]
+
+
+-- Just a copy from HAppS/Data/Pairs.hs, with textfield instead of input
+toDataForm action method fdat
+ = [ Elem "form" (
+               Attr "xmlns" "http://www.w3.org/1999/xhtml" :
+               Attr "action" action :
+                Attr "method" method :
+               Elem "div" [
+                        Attr "class" "formEl"
+                       ,Elem "textarea" [
+                               Attr "name" "formData"
+                               ,Attr "cols" "120"
+                               ,Attr "rows" "20"
+                               ,CData fdat
+                               ]]:
+               Elem "input" [Attr "type" "submit"] :
+                [])]
+
+
+-- From ipprint
+
+pshow :: Show a => a -> String
+pshow v =  case parseModule ("value = "++s) of
+              ParseOk         m -> tidy $ prettyPrint m
+              ParseFailed _ _   -> s
+    where s = show v
+          tidy x = case readPrec_to_S skipBoring 0 x of
+                     [((), tail)] -> "   " ++ tail
+                     _            -> s
+
+skipBoring :: ReadPrec ()
+skipBoring = 
+    do { Ident "value" <- lexP; Punc  "=" <- lexP; return () } <++ 
+    do { lexP; skipBoring }
+
index beff784..ccb838d 100644 (file)
@@ -38,6 +38,11 @@ instance Migrate Old.Assignment Assignment where
 $(inferStartState ''State) 
 $(inferRecordUpdaters ''State) 
 
+getCompleteState :: Query State State
+getCompleteState = askState
+
+putCompleteState :: State -> Update State ()
+putCompleteState = putState
 
 listAssignments :: Query State AssignmentsWithHandIns
 listAssignments = do   s <- askState
@@ -58,7 +63,6 @@ listHandIns = do s <- askState
                     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
 
@@ -102,6 +106,7 @@ deleteHandIn hi = withHandIns $ modify (removeHandIn hi)
 
 $(expose ['listAssignments, 'getAssignment, 'addAssignment, 'updateAssignment, 'deleteAssignment,
           'listHandIns, 'getHandIn, 'addHandIn, 'updateHandIn, 'deleteHandIn,
-         'listStudents, 'getStudent, 'addStudent, 'updateStudent, 'deleteStudent
+         'listStudents, 'getStudent, 'addStudent, 'updateStudent, 'deleteStudent,
+         'getCompleteState, 'putCompleteState
          ])
 
index 5df7a3c..fa9ba4f 100644 (file)
@@ -4,7 +4,6 @@
  xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"
  xmlns="http://www.w3.org/1999/xhtml"
  >
-<!--  xmlns:html="http://www.w3.org/TR/REC-html40" -->
 
 <xsl:output method="xml"
   media-type="text/xml"
 
 <xsl:include href="libxslt/defaultStyle.xsl"/>
 
+<!-- Always copy html elements -->
+<xsl:template match="*[namespace-uri(.)='http://www.w3.org/1999/xhtml']|@*[namespace-uri(..)='http://www.w3.org/1999/xhtml']" mode="content">
+<!--   <xsl:copy-of select="." />  -->
+ <xsl:copy>
+  <xsl:apply-templates select="@*|node()" mode="content"/>
+ </xsl:copy>
+</xsl:template>
+
 <xsl:variable name="staticBaseURL">/</xsl:variable>
 
 <xsl:template match="*" mode="header">
@@ -49,6 +56,7 @@ This really needs nicer styling from css!
 <li><a href="handins/">HandIns</a></li>
 <li><a href="assignment/">Assignments</a></li>
 <li><a href="student/">Students</a></li>
+<li><a href="maintenance/">Maintenance</a></li>
 </ul>
 </xsl:template>