roc-lang · rtfeldman · Aug 23, 2024 · Jul 18, 2024 · Aug 2, 2024 · Aug 4, 2024
diff --git a/.gitignore b/.gitignore
@@ -38,6 +38,11 @@ examples/env
 examples/command
 examples/sqlite3
 examples/hello-web
+examples/file-upload-form
+
+# for file-upload-form test
+red_test_image.png
+curl_file_output.txt
 
 .DS_Store
 

diff --git a/ci/expect_scripts/file-upload-curl.sh b/ci/expect_scripts/file-upload-curl.sh
@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+curl 'http://localhost:8000/' \
+  -H 'Content-Type: multipart/form-data; boundary=----WebKitFormBoundarykIHm2BDPibpfMOPG' \
+  --data-raw $'------WebKitFormBoundarykIHm2BDPibpfMOPG\r\nContent-Disposition: form-data; name="fileToUpload"; filename="red_test_image.png"\r\nContent-Type: image/png\r\n\r\n\r\n------WebKitFormBoundarykIHm2BDPibpfMOPG\r\nContent-Disposition: form-data; name="submit"\r\n\r\nUpload .png Image\r\n------WebKitFormBoundarykIHm2BDPibpfMOPG--\r\n' \
+  > curl_file_output.txt 2>&1
diff --git a/ci/expect_scripts/file-upload-form.exp b/ci/expect_scripts/file-upload-form.exp
@@ -0,0 +1,29 @@
+#!/usr/bin/expect
+
+# uncomment line below for debugging
+# exp_internal 1
+
+set timeout 7
+
+spawn $env(EXAMPLES_DIR)file-upload-form
+
+expect "Listening on <http://127.0.0.1:8000>\r\n" {
+
+    exec convert -size 100x100 xc:red red_test_image.png
+
+    set script_dir [file dirname [info script]]
+
+    exec bash $script_dir/file-upload-curl.sh
+
+    set curlOutput [exec cat curl_file_output.txt]
+
+    if { [string match "*You uploaded*" $curlOutput] } {
+        exit 0
+    } else {
+        puts "Error: curl output was different than expected: $curlOutput"
+        exit 1
+    }
+}
+
+puts stderr "\nError: output was different than expected."
+exit 1
diff --git a/examples/file-upload-form.roc b/examples/file-upload-form.roc
@@ -0,0 +1,98 @@
+app [Model, server] {
+    pf: platform "../platform/main.roc",
+    utils: "https://github.com/quelgar/roc-utils/releases/download/v0.1.0/keYHFjUG1pMAT8ECePEAIS-ncYxEV0DdhTvENUf0USs.tar.br",
+}
+
+import utils.Base64
+import pf.Task exposing [Task]
+import pf.Http exposing [Request, Response]
+
+# Model is produced by `init`.
+Model : {}
+
+# With `init` you can set up a database connection once at server startup,
+# generate css by running `tailwindcss`,...
+# In this case we don't have anything to initialize, so it is just `Task.ok {}`.
+
+server = { init: Task.ok {}, respond }
+
+respond : Request, Model -> Task Response [ServerErr Str]_
+respond = \req, _ ->
+
+    if req.method == Get then
+        body =
+            """
+            <!DOCTYPE html>
+            <html>
+            <head>
+                <title>Image Upload Form</title>
+            </head>
+            <body>
+
+            <h2>Upload an Image</h2>
+
+            <form action="/" method="post" enctype="multipart/form-data">
+                <label for="fileToUpload">Select image to upload:</label><br><br>
+                <input type="file" name="fileToUpload" id="fileToUpload" accept="image/*.png"><br><br>
+                <input type="submit" value="Upload .png Image" name="submit">
+            </form>
+
+            </body>
+            </html>
+            """
+            |> Str.toUtf8
+
+        Task.ok {
+            status: 200,
+            headers: [
+                { name: "Content-Type", value: "text/html" },
+            ],
+            body,
+        }
+    else if req.method == Post then
+        page = \src ->
+            """
+            <!DOCTYPE html>
+            <html lang="en">
+                <head>
+                    <meta charset="UTF-8">
+                    <title>Embedded Image</title>
+                    <meta name="viewport" content="width=device-width, initial-scale=1.0">
+                    <style>
+                        .image-container {
+                            height: 200px;
+                            background-image: url('data:image/png;base64,$(src)');
+                            background-repeat: no-repeat;
+                            background-size: contain; /*scales the image to fit within the container while maintaining its aspect ratio*/
+                            background-position: center;
+                        }
+                    </style>
+                </head>
+                <body>
+                    <h1>You uploaded:</h1>
+                    <div class="image-container"></div>
+                </body>
+            </html>
+            """
+            |> Str.toUtf8
+
+        maybeImage =
+            { headers: req.headers, body: req.body }
+            |> Http.parseMultipartFormData
+            |> Result.try List.first
+            |> Result.map .data
+            |> Result.map Base64.encode
+
+        when maybeImage is
+            Ok img ->
+                Task.ok {
+                    status: 200,
+                    headers: [
+                        { name: "Content-Type", value: "text/html" },
+                    ],
+                    body: page img,
+                }
+
+            Err err -> Task.ok { status: 500, headers: [], body: err |> Inspect.toStr |> Str.toUtf8 }
+    else
+        Task.ok { status: 500, headers: [], body: [] }
diff --git a/flake.nix b/flake.nix
@@ -9,7 +9,6 @@
     rust-overlay = {
       url = "github:oxalica/rust-overlay";
       inputs.nixpkgs.follows = "nixpkgs";
-      inputs.flake-utils.follows = "flake-utils";
     };
 
     # to easily make configs for multiple architectures
@@ -46,6 +45,7 @@
           expect
           rocPkgs.cli
           sqlite
+          imagemagick # for file-upload-form example
         ]);
       in {
 

diff --git a/platform/Base64.roc b/platform/Base64.roc
diff --git a/platform/Http.roc b/platform/Http.roc
@@ -15,12 +15,14 @@ module [
     getUtf8,
     methodToStr,
     parseFormUrlEncoded,
+    parseMultipartFormData,
 ]
 
 import Effect
 import InternalTask
 import Task exposing [Task]
 import InternalHttp exposing [errorBodyToUtf8, errorBodyFromUtf8]
+import MultipartFormData
 
 ## Represents an HTTP request.
 Request : InternalHttp.Request
@@ -290,3 +292,30 @@ hexToDec = \byte ->
 
 expect hexToDec '0' == 0
 expect hexToDec 'F' == 15
+
+## For HTML forms that include files or large amounts of text.
+##
+## See usage in examples/file-upload-form.roc
+parseMultipartFormData :
+    {
+        headers : List Header,
+        body : List U8,
+    }
+    -> Result (List MultipartFormData.FormData) [InvalidMultipartFormData, ExpectedContentTypeHeader, InvalidContentTypeHeader]
+parseMultipartFormData = \args ->
+    decodeMultipartFormDataBoundary args.headers
+    |> Result.try \boundary ->
+        { body: args.body, boundary }
+        |> MultipartFormData.parse
+        |> Result.mapErr \_ -> InvalidMultipartFormData
+
+decodeMultipartFormDataBoundary : List { name : Str, value : Str } -> Result (List U8) _
+decodeMultipartFormDataBoundary = \headers ->
+    headers
+    |> List.keepIf \{ name } -> name == "Content-Type" || name == "content-type"
+    |> List.first
+    |> Result.mapErr \ListWasEmpty -> ExpectedContentTypeHeader
+    |> Result.try \{ value } ->
+        when Str.splitLast value "=" is
+            Ok { after } -> Ok (Str.toUtf8 after)
+            Err NotFound -> Err InvalidContentTypeHeader