This week we'll build a moderately complex SVG-based drawing tool, where each shape has associated metadata that can be modified. Before we get into the preparation, let's have a look at the solution to last week's exercise.

Exercise Solution

Last week, we asked you to modify our S3 Uploads to support uploading multiple files at once. Today I'll show you my solution.

I'm starting out with the elm_web_components_playground project, tagged before this episode.

Support in the Model

We'll add a field to hold a dict of NewPhotoModels, so we can differentiate them later:

module Model
-- ...
import Dict exposing (Dict)
-- ...
type alias Model =
    { -- ...
    , photos : Dict Int NewPhotoModel
    }

And update our initial model:

module App exposing (..)
-- ...
import Dict
-- ...
init : Navigation.Location -> ( Model, Cmd Msg )
init location =
    ( { -- ...
      , photos = Dict.empty
      }
    , Cmd.none
    )

Route

We'll add a route to a view to manage this:

vim src/Routes.elm
module Routes exposing (Route(..), parseRoute, toString)
-- ...
type Route
    = -- ...
    | Photos


parseRoute : Url.Parser (Route -> a) a
parseRoute =
    Url.oneOf
        [ -- ...
        , Url.map Photos (s "photos")
        ]


toString : Route -> String
toString route =
    case route of
        -- ...
        Photos ->
            "photos"

View

We'll add a view to handle this, based on the View.Cards module:

vim src/View/Photos.elm
module View.Photos exposing (view)

import Html
    exposing
        ( Html
        , Attribute
        , text
        , div
        , node
        , h2
        , p
        , input
        )
import Html.Attributes
    exposing
        ( attribute
        , style
        , class
        , type_
        , accept
        )
import Html.Events exposing (onClick, on)
import Model exposing (Model, NewPhotoModel)
import Msg exposing (Msg)
import Polymer.Paper as Paper
import Json.Decode as Decode
import FileReader as FR exposing (parseSelectedFiles)
import Dict


-- We'll show a card for each file, and a means of picking some files and
-- issuing an upload.
view : Model -> Html Msg
view model =
    let
        photoViews =
            model.photos
                |> Dict.toList
                |> List.map (viewPhoto << Tuple.second)
    in
        div
            [ class "view-cards" ]
        <|
            photoViews
                ++ [ filePicker
                   , uploadButton
                   ]


-- The upload button won't do anything just yet.
uploadButton : Html Msg
uploadButton =
    Paper.button
        []
        [ text "Upload" ]


-- in our file picker, we need to enable multiple file choices with the
-- `multiple` attribute.
filePicker : Html Msg
filePicker =
    input
        [ type_ "file"
        , attribute "multiple" "multiple"
        , accept "image/*"
        , class "photo-input"
        , onChangeFile
        ]
        []


-- each photo is in a pretty simplistic card
viewPhoto : NewPhotoModel -> Html Msg
viewPhoto newPhoto =
    Paper.card
        [ attribute "heading" ""
        , attribute "image" (Maybe.withDefault "" newPhoto.dataUrl)
        , attribute "elevation" "2"
        ]
        [ div
            [ class "card-content" ]
            [ p [] [ text "a lonely card" ]
            ]
        ]


-- For now, when we change file, we'll issue a `NoOp`
onChangeFile : Attribute Msg
onChangeFile =
    on "change"
        (Decode.map
            (always Msg.NoOp)
            parseSelectedFiles
        )

And show it in our main view for the appropriate route:

vim src/View.elm
module View exposing (view)
-- ...
-- VIEW MODULES
-- ...
import View.Photos
-- ...
drawer : Model -> Html Msg
drawer model =
    let
        -- ...
        subscribedLinks =
            [ -- ...
            , Routes.Photos
            ]
        -- ...
    in
        -- ...
-- ...
routeView : Model -> Html Msg
routeView model =
    case currentRoute model of
        Just route ->
            case route of
                -- ...
                Routes.Photos ->
                    View.Photos.view model

With this, we can navigate to the view and see a basic, but unimpressive, interface. Let's add a Msg to handle receiving a bunch of new files. This will mimic our NewPhotoMsg pretty heavily.

vim src/Msg.elm
module Msg
    exposing
        ( -- ...
        , PhotosMsg(..)
        )
-- ...
type Msg
    = -- ...
    | Photos PhotosMsg
    | NoOp
-- ...
-- Each of our photos msgs, aside from the one that handles us changing them,
-- takes the dictionary key as its first argument so we know what to update
type PhotosMsg
    = SetPhotos (List NativeFile)
    | ReceivedPhotoAsDataUrl Int Decode.Value
    | RequestPhotoUploadSignatures
    | ReceivePhotoUploadSignature Int UploadSignatureModel

We'll update our view to send a SetPhotos message when you pick your files:

module View.Photos exposing (view)
-- ...
onChangeFile : Attribute Msg
onChangeFile =
    on "change"
        (Decode.map
            (Msg.Photos << Msg.SetPhotos)
            parseSelectedFiles
        )

Now we want to handle this in our Update:

module Update exposing (update)
-- ...
import Msg
    exposing
        ( -- ...
        , PhotosMsg(..)
        )
-- ...
import Dict exposing (Dict)


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg of
        -- ...
        Photos photosMsg ->
            let
                ( photosModel, photosCmd ) =
                    updatePhotos model.apiKey photosMsg model.photos
            in
                ( { model | photos = photosModel }
                , photosCmd
                )
-- ...
-- I definitely don't love the size of these update functions, but this one is
-- at least a tiny bit smarter than updateNewPhoto was.
updatePhotos : Maybe String -> PhotosMsg -> Dict Int NewPhotoModel -> ( Dict Int NewPhotoModel, Cmd Msg )
updatePhotos apiKey photosMsg photosModel =
    case photosMsg of
        -- When we set photos, we just replace them and try to read them as a
        -- data uri
        SetPhotos nativeFiles ->
            let
                -- We always specify the key
                handleDataUrl key result =
                    result
                        |> Result.map (Photos << ReceivedPhotoAsDataUrl key)
                        |> Result.withDefault NoOp

                -- This isn't really different from before
                newUpload nativeFile =
                    NewUploadModel
                        nativeFile.name
                        (Maybe.withDefault ""
                            (Maybe.map
                                MimeType.toString
                                nativeFile.mimeType
                            )
                        )
                        nativeFile

                -- Here's a function to generate a new photo for placing into
                -- the dict - so we include a key in a 2-tuple
                newPhoto key nativeFile =
                    ( key
                    , { newUpload = Just (newUpload nativeFile)
                      , dataUrl = Nothing
                      }
                    )

                -- We map the native files through our newPhoto function and
                -- turn them into a dict.
                newPhotos =
                    nativeFiles
                        |> List.indexedMap newPhoto
                        |> Dict.fromList

                -- we also map them to tasks to read the data url, and perform
                -- the tasks, mapping them back through our `handleDataUrl`
                -- function
                readFileDataUrls =
                    nativeFiles
                        |> List.indexedMap
                            (\key val ->
                                readAsDataUrl val.blob
                                    |> Task.attempt (handleDataUrl key)
                            )
            in
                -- And we set the model part and batch the commands
                ( newPhotos
                , Cmd.batch readFileDataUrls
                )

        -- When we receive the decoded data url, we update our photos for the
        -- key this url is for
        ReceivedPhotoAsDataUrl key value ->
            let
                dataUrl =
                    Decode.decodeValue Decode.string value
                        |> Result.toMaybe

                -- Here's a function that will just update the appropriate item
                -- in the dict. We could fetch and update it, which would be a
                -- bit more performant, but it's a bit more code to handle the
                -- Maybes and it seems like a premature optimization.
                updatePhoto photoKey photo =
                    if photoKey == key then
                        { photo | dataUrl = dataUrl }
                    else
                        photo
            in
                -- Then we update our photos
                ( Dict.map updatePhoto photosModel
                , Cmd.none
                )

        -- We won't deal with requesting the upload signatures just yet, because
        -- it will require changing our API.
        RequestPhotoUploadSignatures ->
            photosModel ! []

        -- And when we receive the upload signature, we need to make the S3
        -- request. We could clean up this nasty bit of branching with judicious
        -- use of Maybe.map, but I wanted logging for each branch. Cleaning it
        -- up would make a good follow-up exercise that's pretty short, if you want
        -- to try it out.
        ReceivePhotoUploadSignature key uploadSignature ->
            case Dict.get key photosModel of
                Nothing ->
                    let
                        _ =
                            Debug.log "ReceivePhotoUploadSignature" <|
                                "No photo with this key: "
                                    ++ (toString key)
                    in
                        photosModel ! []

                Just newPhotoModel ->
                    case newPhotoModel.newUpload of
                        Nothing ->
                            let
                                _ =
                                    Debug.log "ReceivePhotoUploadSignature" <|
                                        "No newUpload for key: "
                                            ++ (toString key)
                            in
                                photosModel ! []

                        Just newUpload ->
                            let
                                _ =
                                    Debug.log "ReceivePhotoUploadSignature" uploadSignature
                            in
                                -- If we actually got an upload signature for an
                                -- upload we know about, then we can issue the
                                -- S3 API call.
                                photosModel
                                    ! [ S3.uploadFile
                                            uploadSignature
                                            newUpload.nativeFile
                                      ]

Alright, so this is almost all the way ready. Let's try out what we have so far. If you choose multiple image files, you'll see a card for each of them.

API

Next, we need to modify our API. This is because it presently is hard-coded to issue a particular message each time we create an upload signature. We'll let it take a tagger function that it uses to generate the outbound message:

vim src/Api.elm
module Api
-- ...
-- We accept the tagger and pass it on to the
-- `handleCreateUploadSignatureComplete` function
createUploadSignature : String -> (UploadSignatureModel -> Msg) -> NewUploadModel -> Cmd Msg
createUploadSignature apiKey tagger newUpload =
    post (apiUrl "upload_signatures")
        |> withHeader "authorization" ("Bearer " ++ apiKey)
        |> withJsonBody (newUploadEncoder newUpload)
        |> withTimeout (10 * Time.second)
        |> withExpect (Http.expectJson <| uploadSignatureDecoder)
        |> send (handleCreateUploadSignatureComplete tagger)
-- ...
-- And we accept the tagger and apply it in handleCreateUploadSignatureComplete
handleCreateUploadSignatureComplete : (UploadSignatureModel -> Msg) -> Result Http.Error UploadSignatureModel -> Msg
handleCreateUploadSignatureComplete tagger result =
    case result of
        Ok uploadSignature ->
            tagger uploadSignature

        Err errorString ->
            let
                _ =
                    Debug.log "error creating upload signature" errorString
            in
                NoOp

We also need to modify the existing use of this api in the Update module:

module Update exposing (update)
-- ...
updateNewPhoto : Maybe String -> NewPhotoMsg -> NewPhotoModel -> ( NewPhotoModel, Cmd Msg )
updateNewPhoto apiKey newPhotoMsg newPhotoModel =
    case newPhotoMsg of
        -- ...
        RequestUploadSignature ->
            case newPhotoModel.newUpload of
                -- ...
                Just newUpload ->
                    newPhotoModel
                        ! [ Api.createUploadSignature
                                (Maybe.withDefault "" apiKey)
                                (NewPhoto << ReceiveUploadSignature)
                                newUpload
                          ]

Now we also want to handle this for our photos:

updatePhotos : Maybe String -> PhotosMsg -> Dict Int NewPhotoModel -> ( Dict Int NewPhotoModel, Cmd Msg )
updatePhotos apiKey photosMsg photosModel =
    case photosMsg of
        -- ...
        RequestPhotoUploadSignatures ->
            let
                -- For a given possible NewUploadModel, we'll create an API call
                -- or do nothing if it's malformed somehow. The fact that it can
                -- be malformed bothers me, but I'm not dealing with that today!
                createUploadSignature : Int -> Maybe NewUploadModel -> Cmd Msg
                createUploadSignature key maybeNewUpload =
                    maybeNewUpload
                        |> Maybe.map
                            (Api.createUploadSignature
                                (Maybe.withDefault "" apiKey)
                                (Photos << (ReceivePhotoUploadSignature key))
                            )
                        |> Maybe.withDefault Cmd.none

                -- We'll also produce a function that takes the key and the
                -- photo itself and produces the upload signature call
                createPhotoUploadSignature : Int -> NewPhotoModel -> Cmd Msg
                createPhotoUploadSignature key photo =
                    createUploadSignature
                        key
                        photo.newUpload

                -- And finally we'll map our photos dictionary to a list of
                -- commands, using the above functions.
                uploadSignatureCmds : List (Cmd Msg)
                uploadSignatureCmds =
                    photosModel
                        |> Dict.map createPhotoUploadSignature
                        |> Dict.toList
                        |> List.map Tuple.second
            in
                -- Then we'll return them from this branch
                photosModel ! uploadSignatureCmds
        -- ...

Finally, we'll want to wire up the upload button in the view:

uploadButton : Html Msg
uploadButton =
    Paper.button
        [ onClick <| Msg.Photos Msg.RequestPhotoUploadSignatures ]
        [ text "Upload" ]

If you try it out now, you'll see one S3 upload in your network tab for each photo you've uploaded!

Preparatory Readings

This week we're going to build an SVG drawing tool that supports editing and tracks metadata for each shape. We haven't done much with SVG lately, so now would be a good time to review the documentation:

I'll produce a decent starting point so we don't have to deal with the extremely basic parts and can get into the fun bits immediately. See you soon!