DropZone

DropZone.purs

module CubePlan.Pages.Import.DropZone
  ( Query(..)
  , Input
  , Message(..)
  , Slot(..)
  , dropZone
  , module CubePlan.Pages.Import.DropZone.Style
  ) where

import Prelude

import CSS (display, displayNone)
import CubePlan.HTML (icon)
import CubePlan.HTML.Icon as Icon
import CubePlan.HTML.Utils (css)
import CubePlan.Pages.Import.DropZone.Style (classNames, stylesheet)
import CubePlan.Utils.Conditional ((?))
import Data.Maybe (Maybe(..))
import Data.Traversable (for_)
import Effect.Class (class MonadEffect)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.CSS as CSS
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties (InputType(..))
import Halogen.HTML.Properties as HP
import Prelude.Unicode ((∘))
import Web.Event.Event (preventDefault, stopPropagation)
import Web.File.FileList (FileList)
import Web.HTML.Event.DataTransfer as DataTransfer
import Web.HTML.Event.DragEvent (DragEvent, dataTransfer)
import Web.HTML.Event.DragEvent as DragEvent
import Web.HTML.HTMLElement as Element
import Web.HTML.HTMLInputElement as Input

data Query a
  = PickFiles a
  | DropFiles DragEvent a
  | SetDragOver Boolean DragEvent a
  | OpenFilePicker a
  | PreventDrag DragEvent (DragEvent → Query a)

type Input = Unit

data Message
  = FileListChanged (Maybe FileList)

type State =
  { dragOver ∷ Boolean
  }

data Slot = Slot
derive instance eqSlot ∷ Eq Slot
derive instance ordSlot ∷ Ord Slot

type Component = H.Component HH.HTML Query Input Message
type DSL = H.ComponentDSL State Query Message
type HTML = H.ComponentHTML Query

dropZone ∷ ∀ m. MonadEffect m ⇒ Component m
dropZone = H.component
  { initialState: const initialState
  , render
  , eval
  , receiver: const Nothing
  }
  where
    initialState ∷ State
    initialState = { dragOver: false }

    eval ∷ Query ~> DSL m
    eval = case _ of
      PickFiles a → a <$ do
        inputEl ← H.getHTMLElementRef inputRef
        for_ inputEl \el → do
          for_ (Input.fromHTMLElement el) \input → do
            files ← H.liftEffect $ Input.files input
            H.raise $ FileListChanged files
      DropFiles e a → a <$ do
        let files = DataTransfer.files ∘ dataTransfer $ e
        H.raise $ FileListChanged files
      OpenFilePicker a → a <$ do
        inputEl ← H.getHTMLElementRef inputRef
        for_ inputEl $ H.liftEffect ∘ Element.click
      SetDragOver v _ a →
        H.modify_ _ { dragOver = v } $> a
      PreventDrag e q → do
        let event = DragEvent.toEvent e
        H.liftEffect $ preventDefault event
        H.liftEffect $ stopPropagation event
        eval $ q e

    preventDrag f q = f \x → Just $ PreventDrag x $ H.action ∘ q

    render ∷ State → HTML
    render state =
      HH.div
      [ css
        [ classNames.root
        , state.dragOver ?
          classNames.dragOver $
          classNames.dragNone
        ]
        , HE.onClick (HE.input_ OpenFilePicker)
        , preventDrag HE.onDragEnter (SetDragOver true)
        , preventDrag HE.onDragOver (SetDragOver true)
        , preventDrag HE.onDragLeave (SetDragOver false)
        , preventDrag HE.onDrop DropFiles
      ]
      [ icon
        Icon.CloudUpload
        [ css [classNames.uploadIcon] ]
      , HH.div
        [ css [classNames.content] ]
        [ HH.text """
          Перетащите сюда файлы,
          которые хотите загрузить или выберите их
          """
        ]
      , HH.input
        [ HP.type_ InputFile
        , HP.id_ "upload"
        , HP.ref inputRef
        , HP.multiple true
        , HE.onChange $ HE.input_ PickFiles
        , CSS.style $ display displayNone
        ]
      ]

-- | A reference to the `input` element which can
-- | be used to open file picker programmatically.
inputRef ∷ H.RefLabel
inputRef = H.RefLabel "upload"

-- FileItem module
-- ... 
    eval ∷ Query ~> DSL m
    eval = case _ of
      Upload a → a <$ do
        { name, file } ← H.get
        H.liftAff $ FormAPI.upload file
-- ...
-- FormAPI module
import Web.File.File (File)
import Web.File.File as File
import Web.XHR.FormData (EntryName(..), FileName(..))
import Web.XHR.FormData as FormData
-- ...
upload ∷ File → Aff (Either Error Unit)
upload file = do
  formData ← liftEffect FormData.new
  liftEffect $ FormData.appendBlob (EntryName name) (File.toBlob file) (fileName file) formData