From c266f5133fb8da2d5f4ed0321675b06cc41755c0 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Wed, 12 Jul 2023 22:51:17 +0200 Subject: feat(users/Profpatsch): init httzip 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 Tested-by: BuildkiteCI --- users/Profpatsch/cabal.project | 1 + users/Profpatsch/hie.yaml | 2 + users/Profpatsch/httzip/Httzip.hs | 66 ++++++++++++++++++++++++++++++++ users/Profpatsch/httzip/default.nix | 40 ++++++++++++++++++++ users/Profpatsch/httzip/httzip.cabal | 73 ++++++++++++++++++++++++++++++++++++ users/Profpatsch/shell.nix | 2 + 6 files changed, 184 insertions(+) create mode 100644 users/Profpatsch/httzip/Httzip.hs create mode 100644 users/Profpatsch/httzip/default.nix create mode 100644 users/Profpatsch/httzip/httzip.cabal diff --git a/users/Profpatsch/cabal.project b/users/Profpatsch/cabal.project index cf2d7b1366cd..d05768a0088f 100644 --- a/users/Profpatsch/cabal.project +++ b/users/Profpatsch/cabal.project @@ -7,3 +7,4 @@ packages: ./cas-serve/cas-serve.cabal ./jbovlaste-sqlite/jbovlaste-sqlite.cabal ./whatcd-resolver/whatcd-resolver.cabal + ./httzip/httzip.cabal diff --git a/users/Profpatsch/hie.yaml b/users/Profpatsch/hie.yaml index cf5982d317ca..e22a383216ec 100644 --- a/users/Profpatsch/hie.yaml +++ b/users/Profpatsch/hie.yaml @@ -20,3 +20,5 @@ cradle: component: "jbovlaste-sqlite:exe:jbovlaste-sqlite" - path: "./whatcd-resolver/src" component: "lib:whatcd-resolver" + - path: "./httzip/Httzip.hs" + component: "httzip:exe:httzip" 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 diff --git a/users/Profpatsch/httzip/default.nix b/users/Profpatsch/httzip/default.nix new file mode 100644 index 000000000000..c4c00ffb457d --- /dev/null +++ b/users/Profpatsch/httzip/default.nix @@ -0,0 +1,40 @@ +{ depot, pkgs, lib, ... }: + +let + + httzip = pkgs.haskellPackages.mkDerivation { + pname = "httzip"; + version = "0.1.0"; + + src = depot.users.Profpatsch.exactSource ./. [ + ./httzip.cabal + ./Httzip.hs + ]; + + libraryHaskellDepends = [ + pkgs.haskellPackages.pa-prelude + pkgs.haskellPackages.warp + pkgs.haskellPackages.wai + pkgs.haskellPackages.wai-conduit + pkgs.haskellPackages.conduit-extra + pkgs.haskellPackages.conduit + ]; + + isExecutable = true; + isLibrary = false; + license = lib.licenses.mit; + }; + + bins = depot.nix.getBins httzip [ "httzip" ]; + +in +depot.nix.writeExecline "httzip-wrapped" { } [ + "importas" + "-ui" + "PATH" + "PATH" + "export" + "PATH" + "${pkgs.zip}/bin" + bins.httzip +] diff --git a/users/Profpatsch/httzip/httzip.cabal b/users/Profpatsch/httzip/httzip.cabal new file mode 100644 index 000000000000..c463a6a5feaf --- /dev/null +++ b/users/Profpatsch/httzip/httzip.cabal @@ -0,0 +1,73 @@ +cabal-version: 3.0 +name: httzip +version: 0.1.0.0 +author: Profpatsch +maintainer: mail@profpatsch.de + +common common-options + ghc-options: + -Wall + -Wno-type-defaults + -Wunused-packages + -Wredundant-constraints + -fwarn-missing-deriving-strategies + + -- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html + -- for a description of all these extensions + default-extensions: + -- Infer Applicative instead of Monad where possible + ApplicativeDo + + -- Allow literal strings to be Text + OverloadedStrings + + -- Syntactic sugar improvements + LambdaCase + MultiWayIf + + -- Makes the (deprecated) usage of * instead of Data.Kind.Type an error + NoStarIsType + + -- Convenient and crucial to deal with ambiguous field names, commonly + -- known as RecordDotSyntax + OverloadedRecordDot + + -- does not export record fields as functions, use OverloadedRecordDot to access instead + NoFieldSelectors + + -- Record punning + RecordWildCards + + -- Improved Deriving + DerivingStrategies + DerivingVia + + -- Type-level strings + DataKinds + + -- to enable the `type` keyword in import lists (ormolu uses this automatically) + ExplicitNamespaces + + default-language: GHC2021 + + +executable httzip + import: common-options + + main-is: Httzip.hs + + build-depends: + base >=4.15 && <5, + pa-prelude, + bytestring, + text, + warp, + wai, + http-types, + directory, + filepath, + unix, + wai-conduit, + conduit, + conduit-extra, + binary diff --git a/users/Profpatsch/shell.nix b/users/Profpatsch/shell.nix index 789f991ffab8..a3b924f0b9dc 100644 --- a/users/Profpatsch/shell.nix +++ b/users/Profpatsch/shell.nix @@ -38,6 +38,8 @@ pkgs.mkShell { h.sqlite-simple h.hedgehog h.http-conduit + h.http-conduit + h.wai-conduit h.nonempty-containers h.deriving-compat h.unix -- cgit 1.4.1