[Fencommits] fenserve: very simple interface for turning items into own pages
Benja Fallenstein
benja.fallenstein at gmail.com
Sat Apr 28 16:53:36 EEST 2007
Sat Apr 28 16:53:24 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* very simple interface for turning items into own pages
diff -rN -u old-fenserve/notetaker/Main.hs new-fenserve/notetaker/Main.hs
--- old-fenserve/notetaker/Main.hs 2007-04-28 16:53:36.000000000 +0300
+++ new-fenserve/notetaker/Main.hs 2007-04-28 16:53:36.000000000 +0300
@@ -1,6 +1,6 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
-import HAppS hiding (Body)
+import HAppS hiding (Body, getPath)
import Control.Monad.State
import Data.Generics (Typeable)
import Data.Binary hiding (get,put)
@@ -13,13 +13,14 @@
type Path = [Int]
data Body = Body String | Add Path String
| Edit Path String | DeleteOne Path | Delete Path
+ | MakeOwnPage Path | Unpage Path
deriving (Eq,Ord,Read,Show,Typeable)
data Line = Line { lineTime :: EpochTime, lineNick :: String,
lineBody :: Body } deriving (Eq,Ord,Read,Show,Typeable)
instance Binary Line where
-data Note = Note String [Note] deriving (Eq,Ord,Read,Show)
+data Note = Note String Bool [Note] deriving (Eq,Ord,Read,Show)
style = "<style type='text/css'>li, p.logline { margin-bottom: 0.3em; margin-top: 0.3em }</style>"
@@ -39,39 +40,57 @@
| otherwise = printf "<a href=%s?nick=%s>%s</a>" uri nick name
where (name,uri) = links !! i
-page nick = do
+page path nick = do
(lines :: [Line]) <- get
- let Note _ notes = foldl (flip execute) (Note "HOME" []) lines
- respond $ style ++ renderNotes notes ++ views 0 nick ++ form nick
+ let Note title _ notes =
+ getPath path $ foldl (flip execute) (Note "HOME" True []) lines
+ respond $ style ++ "<h2>" ++ renderPath path ++ " " ++ title ++ "</h2>"
+ ++ renderNotes path notes ++ views 0 nick ++ form nick
+
+getPath [] note = note
+getPath (i:is) (Note _ _ cs) = getPath is (cs !! i)
-renderNotes notes = "<ol>" ++ concatMap renderNote notes ++ "</ol>" where
- renderNote (Note title children) = "<li>" ++ title ++ renderNotes children
+renderNotes p notes =
+ "<ol>" ++ concat [renderNote (p++[i]) (notes !! i)
+ | i <- [0..length notes - 1]] ++ "</ol>" where
-readPath :: String -> Int -> (Path -> String -> a) -> a
-readPath s n f = f (segments a) (dropWhile isSpace b) where
+ renderNote p (Note title False cs) = "<li>" ++ title ++ renderNotes p cs
+ renderNote p (Note title True cs) =
+ "<li><a href='/item/"++renderPath p++"'><b>Page</b></a> ("
+ ++show (length cs)++"): "++title
+
+readPath :: String -> Path
+readPath s = readPath' s 0 (\p _ -> p)
+
+readPath' :: String -> Int -> (Path -> String -> a) -> a
+readPath' s n f = f (segments a) (dropWhile isSpace b) where
(a,b) = span (\c -> isNumber c || c == '.') $ dropWhile isSpace $ drop n s
segments "" = []
segments ('.':s) = segments s
segments s = (read x - 1) : segments y where (x,y) = span (/= '.') s
readBody :: String -> Body
-readBody s | ":add " `isPrefixOf` s = readPath s 5 $ \p l -> Add p l
- | ":edit " `isPrefixOf` s = readPath s 6 $ \p l -> Edit p l
- | ":del " `isPrefixOf` s = readPath s 5 $ \p "" -> DeleteOne p
- | ":deltree " `isPrefixOf` s = readPath s 5 $ \p "" -> Delete p
+readBody s | ":add " `isPrefixOf` s = readPath' s 5 $ \p l -> Add p l
+ | ":edit " `isPrefixOf` s = readPath' s 6 $ \p l -> Edit p l
+ | ":del " `isPrefixOf` s = readPath' s 5 $ \p "" -> DeleteOne p
+ | ":deltree " `isPrefixOf` s = readPath' s 9 $ \p "" -> Delete p
+ | ":page " `isPrefixOf` s = readPath' s 6 $ \p "" -> MakeOwnPage p
+ | ":unpage " `isPrefixOf` s = readPath' s 8 $ \p "" -> Unpage p
| otherwise = Body s
execute (Line _ _ (Body _)) = id
execute (Line _ _ body) =
- case body of Add p l -> on p $ \(Note t cs) -> [Note t (cs++[Note l []])]
- Edit p l -> on p $ \(Note _ cs) -> [Note l cs]
- DeleteOne p -> on p $ \(Note _ cs) -> cs
- Delete p -> on p $ \(Note _ cs) -> []
+ case body of Add p l -> on p $ \(Note t o cs) -> [Note t o (cs++[Note l False []])]
+ Edit p l -> on p $ \(Note _ o cs) -> [Note l o cs]
+ DeleteOne p -> on p $ \(Note _ _ cs) -> cs
+ Delete p -> on p $ \(Note _ _ cs) -> []
+ MakeOwnPage p -> on p $ \(Note t _ cs) -> [Note t True cs]
+ Unpage p -> on p $ \(Note t _ cs) -> [Note t False cs]
where on is f note = head $ on' is f note
on' [] f note = f note
- on' (i:is) f (Note t cs) =
- [Note t (take i cs ++ on' is f (cs !! i) ++ drop (i+1) cs)]
+ on' (i:is) f (Note t o cs) =
+ [Note t o (take i cs ++ on' is f (cs !! i) ++ drop (i+1) cs)]
getNick m = case lookM m "nick" of Nothing -> "(anon)"; Just "" -> "(anon)"
Just x -> x
@@ -94,13 +113,15 @@
renderBody nick (Body s) = printf "<<b>%s</b>> %s" nick s
renderBody nick body = printf "<i><b>%s</b> %s" nick (msg body) where
msg :: Body -> String
- msg (Add [] l) = printf "adds:</i> %s" l
- msg (Add p l) = printf "adds to '%s':</i> %s" (renderPath p) l
- msg (Edit p l) = printf "edits '%s':</i> %s" (renderPath p) l
- msg (DeleteOne p) = printf "deletes '%s.'</i>" (renderPath p)
- msg (Delete p) = printf "deletes subtree '%s.'</i>" (renderPath p)
+ msg (Add [] l) = printf "adds:</i> %s" l
+ msg (Add p l) = printf "adds to '%s':</i> %s" (renderPath p) l
+ msg (Edit p l) = printf "edits '%s':</i> %s" (renderPath p) l
+ msg (DeleteOne p) = printf "deletes '%s.'</i>" (renderPath p)
+ msg (Delete p) = printf "deletes subtree '%s.'</i>" (renderPath p)
+ msg (MakeOwnPage p) = printf "made '%s' its own page.</i>" (renderPath p)
+ msg (Unpage p) = printf "un-paged '%s.'</i>" (renderPath p)
- renderPath = concat . intersperse "." . map (show . (+1))
+renderPath = concat . intersperse "." . map (show . (+1))
renderTime :: EpochTime -> String
renderTime t0 = printf "%02u:%02u" (ctHour t) (ctMin t)
@@ -109,11 +130,13 @@
main = stdHTTP [ debugFilter
, h ["log"] GET $ ok $ \() nick -> renderLog nick False
, h ["lastlog"] GET $ ok $ \() nick -> renderLog nick True
- , h [""] GET $ ok $ \() nick -> page nick
+ , h [""] GET $ ok $ \() nick -> page [] nick
, h () POST $ ok $ \() (nick,line) -> do
time <- getTime; let body = readBody line
modify (++[Line time nick body])
- case body of Body _ -> renderLog nick True; _ -> page nick
+ case body of Body _ -> renderLog nick True
+ _ -> page [] nick
, h () POST $ ok $ \() () -> respond "Huh."
+ , h (Prefix ["item"]) GET $ ok $ \[p] n -> page (readPath p) n
]
More information about the Fencommits
mailing list