feat(users/Profpatsch): init httzip r/6425

A streaming webserver which serves directories as .zip recursively.
Because everything sucks and this is the best way to get dirs
delivered to people.

Change-Id: I451885cfc5082db12ac32eb0a4bfb04bc983d3c2
Reviewed-on: https://cl.tvl.fyi/c/depot/+/8953
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI

1 files changed, 66 insertions, 0 deletions

diff --git a/users/Profpatsch/httzip/Httzip.hs b/users/Profpatsch/httzip/Httzip.hs
new file mode 100644
index 000000000000..761cd1d2eaf6
--- /dev/null
+++ b/users/Profpatsch/httzip/Httzip.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Main where
+
+import Conduit ((.|))
+import Data.Binary.Builder qualified as Builder
+import Data.Conduit qualified as Cond
+import Data.Conduit.Combinators qualified as Cond
+import Data.Conduit.Process.Typed qualified as Cond
+import Data.Conduit.Process.Typed qualified as Proc
+import Data.List qualified as List
+import Data.Text qualified as Text
+import Network.HTTP.Types qualified as Http
+import Network.Wai qualified as Wai
+import Network.Wai.Conduit qualified as Wai.Conduit
+import Network.Wai.Handler.Warp qualified as Warp
+import PossehlAnalyticsPrelude
+import System.Directory qualified as Dir
+import System.FilePath ((</>))
+import System.FilePath qualified as File
+import System.Posix qualified as Unix
+
+-- Webserver that returns folders under CWD as .zip archives (recursively)
+main :: IO ()
+main = do
+  currentDirectory <- Dir.getCurrentDirectory >>= Dir.canonicalizePath
+  run currentDirectory
+
+run :: FilePath -> IO ()
+run dir = do
+  currentDirectory <- Dir.canonicalizePath dir
+  putStderrLn $ [fmt|current {show currentDirectory}|]
+  Warp.run 7070 $ \req respond -> do
+    let respondHtml status content = respond $ Wai.responseLBS status [("Content-Type", "text/html")] content
+    case req & Wai.pathInfo of
+      [] -> respond $ Wai.responseLBS Http.status200 [("Content-Type", "text/html")] "any directory will be returned as .zip!"
+      filePath -> do
+        absoluteWantedFilepath <- Dir.canonicalizePath (currentDirectory </> (File.joinPath (filePath <&> textToString)))
+        -- I hope this prevents any shenanigans lol
+        let noCurrentDirPrefix = List.stripPrefix (File.addTrailingPathSeparator currentDirectory) absoluteWantedFilepath
+        if
+            | (any (Text.elem '/') filePath) -> putStderrLn "tried %2F encoding" >> respondHtml Http.status400 "no"
+            | Nothing <- noCurrentDirPrefix -> putStderrLn "tried parent dir with .." >> respondHtml Http.status400 "no^2"
+            | Just wantedFilePath <- noCurrentDirPrefix -> do
+                putStderrLn $ [fmt|wanted {show wantedFilePath}|]
+                ex <- Unix.fileExist wantedFilePath
+                if ex
+                  then do
+                    status <- Unix.getFileStatus wantedFilePath
+                    if status & Unix.isDirectory
+                      then do
+                        zipDir <- zipDirectory wantedFilePath
+                        Proc.withProcessWait zipDir $ \process -> do
+                          let stream =
+                                Proc.getStdout process
+                                  .| Cond.map (\bytes -> Cond.Chunk $ Builder.fromByteString bytes)
+                          -- TODO: how to handle broken zip? Is it just gonna return a 500? But the stream is already starting, so hard!
+                          respond $ Wai.Conduit.responseSource Http.ok200 [("Content-Type", "application/zip")] stream
+                      else respondHtml Http.status404 "not found"
+                  else respondHtml Http.status404 "not found"
+  where
+    zipDirectory toZipDir = do
+      putStderrLn [fmt|running $ zip {show ["--recurse-paths", "-", toZipDir]}|]
+      pure $
+        Proc.proc "zip" ["--recurse-paths", "-", toZipDir]
+          & Proc.setStdout Cond.createSource