multi-part file upload and Progress

index.js

app.ports.uploadFile.subscribe(function (data) {

  const elementId = data.elementId;
  const req = data.request;

  const node = document.getElementById(elementId);
  if (node === null || node.files[0] === undefined) {
    return;
  };

  const updateProgress = function updateProgress(oEvent){
    if (oEvent.lengthComputable) {
      const some = {
        type: "Some",
        bytes: oEvent.loaded,
        bytesExpected: oEvent.total
      };
      app.ports.uploadProgress.send(some);
    } else {
      // Unable to compute progress information since the total size is unknown
    };
  };

  const transferComplete = function transferComplete(evt){
    app.ports.uploadProgress.send({ type : "Completed" });
  };

  const transferFailed = function transferFailed(evt){
    app.ports.uploadProgress.send({ type : "Fail", error : { type : "NetworkError" } });
  };

  const timeout = function timeout(evt){
    app.ports.uploadProgress.send({ type : "Fail", error : { type : "Timeout" } });
  };

  const transferCanceled = function transferCanceled(evt){
    app.ports.uploadProgress.send({ type : "Canceled"});
  };

  var formData = new FormData();
  formData.append(req.part[0], req.part[1]);
  formData.append(req.filePartName, node.files[0]);

  var xhr = new XMLHttpRequest();

  xhr.upload.addEventListener("progress", updateProgress);
  xhr.upload.addEventListener("load", transferComplete);
  xhr.upload.addEventListener("error", transferFailed);
  xhr.upload.addEventListener("abort", transferCanceled);
  xhr.onreadystatechange = function() {
    if (xhr.readyState === 4) {
      if (xhr.status < 200 || 300 <= xhr.status)
      {
        const response =
          {
            url : req.url,
            status : { code : xhr.status, message : xhr.statusText },
            // todo: parse headers
            headers : [],
            body : xhr.responseText
          };
        app.ports.uploadProgress.send({ type : "Fail", error : { type : "BadStatus", response : response } });
      }
      else
      {
        app.ports.uploadProgress.send({ type : "Done", value : JSON.parse(xhr.response) });
      }
    }
  };

  try
  {
    xhr.open(req.method, req.url);
  }
  catch (e)
  {
    app.ports.uploadProgress.send({ type : "Fail", error : { type : "BadUrl", url : req.url } });
  }

  req.headers.forEach(function(header){
    xhr.setRequestHeader(header[0], header[1]);
  });

  xhr.send(formData);
});

Ports.elm

port module Ports exposing (Header, Part, FileUploadRequest, uploadProgress, uploadFile)

import Json.Decode exposing (Value)


port uploadFile : { elementId : ElementId, request : FileUploadRequest } -> Cmd msg


port uploadProgress : (Value -> msg) -> Sub msg


type alias ElementId =
    String


type alias Part =
    ( String, String )


type alias Header =
    ( String, String )


type alias FileUploadRequest =
    { url : String
    , method : String
    , headers : List Header
    , filePartName : String
    , part : Part
    }

Progress.elm

module Progress exposing (Progress(..), decode, progressInPercent, toMaybe)

import Json.Decode as Decode exposing (field)
import Json.Decode.Pipeline as Pipeline exposing (required)
import Http exposing (Error(..))
import Result.Extra
import Dict exposing (Dict(..))
import Maybe.Extra


type Progress a
    = None
    | Some { bytes : Int, bytesExpected : Int }
    | Canceled
    | Completed
    | Fail Http.Error
    | InternalError String
    | Done a


toMaybe : Progress a -> Maybe a
toMaybe progress =
    case progress of
        Done a ->
            Just a

        _ ->
            Nothing


progressInPercent : Progress a -> Int
progressInPercent progress =
    case progress of
        Some { bytes, bytesExpected } ->
            round <|
                (*) 100 <|
                    toFloat bytes
                        / toFloat bytesExpected

        Done _ ->
            100

        Completed ->
            100

        None ->
            0

        Fail _ ->
            0

        InternalError _ ->
            0

        Canceled ->
            0


decode : Decode.Decoder a -> (Progress a -> msg) -> Decode.Value -> msg
decode d toMsg value =
    value
        |> Decode.decodeValue (progressDecoder d)
        |> Result.mapError InternalError
        |> Result.Extra.merge
        |> toMsg


someDecoder : Decode.Decoder (Progress a)
someDecoder =
    Pipeline.decode
        (\bs bse -> Some { bytes = bs, bytesExpected = bse })
        |> required "bytes" Decode.int
        |> required "bytesExpected" Decode.int


progressDecoder : Decode.Decoder a -> Decode.Decoder (Progress a)
progressDecoder aDecoder =
    Decode.at [ "type" ] Decode.string
        |> Decode.andThen
            (\str ->
                case str of
                    "None" ->
                        Decode.succeed None

                    "Canceled" ->
                        Decode.succeed Canceled

                    "Completed" ->
                        Decode.succeed Completed

                    "Done" ->
                        Decode.map Done (Decode.at [ "value" ] aDecoder)

                    "Some" ->
                        someDecoder

                    "Fail" ->
                        Decode.map Fail (Decode.at [ "error" ] errorDecoder)

                    unknownType ->
                        Decode.fail <| "Unknown type: " ++ unknownType
            )


type alias Status =
    { code : Int
    , message : String
    }


statusDecoder : Decode.Decoder Status
statusDecoder =
    Pipeline.decode
        Status
        |> required "code" Decode.int
        |> required "message" Decode.string


tryToDict : List (List String) -> Decode.Decoder (Dict String String)
tryToDict list =
    list
        |> List.map
            (\innerList ->
                case innerList of
                    a :: b :: [] ->
                        Just ( a, b )

                    _ ->
                        Nothing
            )
        |> Maybe.Extra.combine
        |> Maybe.map (Dict.fromList >> Decode.succeed)
        |> Maybe.withDefault (Decode.fail "could not parse headers into dictionary")


responseDecoder : Decode.Decoder (Http.Response String)
responseDecoder =
    Pipeline.decode
        Http.Response
        |> required "url" Decode.string
        |> required "status" statusDecoder
        |> required "headers" (Decode.list (Decode.list Decode.string) |> Decode.andThen tryToDict)
        |> required "body" Decode.string


errorDecoder : Decode.Decoder Http.Error
errorDecoder =
    Decode.at [ "type" ] Decode.string
        |> Decode.andThen
            (\str ->
                case str of
                    "Timeout" ->
                        Decode.succeed Timeout

                    "NetworkError" ->
                        Decode.succeed NetworkError

                    "BadUrl" ->
                        Decode.map BadUrl (field "url" Decode.string)

                    "BadPayload" ->
                        Decode.map2
                            BadPayload
                            (field "errorMessage" Decode.string)
                            (field "response" responseDecoder)

                    "BadStatus" ->
                        Decode.map BadStatus (field "response" responseDecoder)

                    unknownType ->
                        Decode.fail <| "Unknown type: " ++ unknownType
            )