wip, webroot

hbs2-peer/app/HttpWorker.hs

@@ -14,6 +14,7 @@ import HBS2.Net.Auth.Schema
 import HBS2.Data.Types.SignedBox
 import HBS2.Events
 import HBS2.Storage.Operations.ByteString
+import HBS2.Misc.PrettyStuff
 
 import PeerTypes
 import PeerConfig
@@ -206,42 +207,56 @@ httpWorker (PeerConfig syn) pmeta = do
 
 
 getTreeHash :: AnyStorage -> HashRef -> ActionM ()
-getTreeHash sto what' = void $ flip runContT pure do
+getTreeHash sto what'' = void $ flip runContT pure do
 
-  meta <- extractMetadataHash sto what'
+  flip fix (what'', 0) $ \again (what',i) -> do
-            >>= orElse (status status404)
 
-  let tp = headDef "application/octet-stream"
+    let what = fromHashRef what'
-           [ show (pretty w)
-           | ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta
-           ]
 
-  let fn = headMay
+    meta <- extractMetadataHash sto what'
-           [ show (pretty w)
+              >>= orElse (status status404)
-           | ListVal [SymbolVal "file-name:", LitStrVal w] <- meta
-           ]
 
-  -- liftIO $ print $ pretty meta
+    let tp = headDef "application/octet-stream"
+             [ show (pretty w)
+             | ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta
+             ]
 
-  case fn of
+    let fn = headMay
-    Just x | takeExtension x == ".html" -> pure  ()
+             [ show (pretty w)
-           | otherwise -> lift $ do
+             | ListVal [SymbolVal "file-name:", LitStrVal w] <- meta
-               addHeader "content-disposition" [qc|attachment; filename="{x}"|]
+             ]
 
-    _ -> pure ()
+    let webroot = headMay [ w
+                          | i < 2, ListVal [SymbolVal "webroot", HashLike w] <- meta
+                          ]
 
-  lift $ addHeader "content-type" (fromString tp)
+    case webroot of
+      Just x | i < 2 -> again (x, succ i)
 
-  elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey what)
+      _ -> do
 
-  case elbs of
+        for_ webroot $ \w -> do
-    Left{} -> lift $ status status404
+          warn $ green "HTTP:WEBROOT" <+> pretty w
-    Right lbs -> lift do
+
-      stream $ \write flush -> do
+        -- liftIO $ print $ pretty meta
-        for_ (LBS.toChunks lbs) $ \chunk -> do
+
-          write $ byteString chunk
+        case fn of
-        flush
+          Just x | takeExtension x == ".html" -> pure  ()
-  where
+                 | otherwise -> lift $ do
-    what = fromHashRef what'
+                     addHeader "content-disposition" [qc|attachment; filename="{x}"|]
+
+          _ -> pure ()
+
+        lift $ addHeader "content-type" (fromString tp)
+
+        elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey what)
+
+        case elbs of
+          Left{} -> lift $ status status404
+          Right lbs -> lift do
+            stream $ \write flush -> do
+              for_ (LBS.toChunks lbs) $ \chunk -> do
+                write $ byteString chunk
+              flush