[Fencommits] fenserve: hierarchical directories

[Benja Fallenstein]

Fri Mar 16 05:34:28 EET 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * hierarchical directories
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs	2007-03-22 19:49:39.000000000 +0200
+++ new-fenserve/FenServe.hs	2007-03-22 19:49:40.000000000 +0200
@@ -27,6 +27,7 @@
 import Data.ByteString (ByteString)
 import qualified Data.Map as Map
 import Data.Map (Map)
+import Data.Maybe (fromMaybe)
 import Data.Typeable
 
 import Network.URI (uriToString)
@@ -43,18 +44,35 @@
 instance ToMessage ByteString where
     toMessageBodyM = return
 
-uriToString' uri = uriToString id uri ""
-
-just :: SURI -> Maybe String
-just = Just . uriToString' . suri
+just :: SURI -> Maybe [String]
+just = Just . splitPath . path
 
 main :: IO ()
 main = stdHTTP
-  [ h just GET $ ok $ \uri () -> do
-        Dir dir <- get
-        return $ Right $ body $ dir Map.! uri
+  [ h just GET $ ok $ \uri () -> get >>= return . Right . getURI uri
   , h just PUT $ ok $ \uri () -> do 
-        Request { rqBody=Body body } <- getEvent; Dir dir <- get
-        put $ Dir $ Map.insert uri (File body) dir
-        return $ Right "Ok, put"
+      Request { rqBody=Body body } <- getEvent
+      modify (putURI uri body); return $ Right "Ok."
   ]
+  
+getURI :: [String] -> Resource -> ByteString
+getURI []     (File s) = s
+getURI (x:xs) (Dir m)  = getURI xs (m Map.! x)
+
+putURI :: [String] -> ByteString -> Resource -> Resource
+putURI [x]    s (Dir m) = Dir $ Map.insert x (File s) m
+putURI (x:xs) s (Dir m) = Dir $ updateWithDefault (Dir Map.empty) (putURI xs s) x m
+
+updateWithDefault :: Ord k => a -> (a -> a) -> k -> Map k a -> Map k a
+updateWithDefault x f = Map.alter (Just . f . fromMaybe x)
+
+--------------------------------------------------------------------------
+-- Copied from HAppS.Protocols.SimpleHTTP2, which is BSD3-licensed
+--------------------------------------------------------------------------
+
+splitPath         :: String -> [String]
+splitPath ('/':x) = a : splitPath b where (a,b) = break (=='/') x
+splitPath []      = []
+splitPath _       = error "splitPath: malformed path"
+
+--------------------------------------------------------------------------