FileUpload.purs

module Component.FileUploader where 

import Prelude

import Control.Monad.Except (ExceptT(..), catchError, runExceptT)
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
import Control.MonadZero (guard)
import Control.Plus (empty)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.Either (Either, either, hush, isLeft)
import Data.Maybe (Maybe(..), maybe)
import Data.PCM as PCM
import DesignSystem.Components as DesignSystem
import DesignSystem.DOM as DesignSystem
import Effect (Effect)
import Effect.Aff (Milliseconds(..), delay, launchAff_)
import Effect.Class (liftEffect)
import Effect.Console (log, logShow)
import React.Basic (Component, JSX, StateUpdate(..), capture, capture_, createComponent, make, send)
import React.Basic.DOM as R
import React.Basic.DOM.Events (currentTarget)
import Web.Event.EventTarget (EventTarget)
import Web.File.File (File)
import Web.File.File as File
import Web.File.FileList (item) as FileList
import Web.File.FileReader.Aff (readAsText_) as FileReader
import Web.File.FileReader.ReadyState as FileReadyState
import Web.HTML.HTMLInputElement as Input

component :: Component Props 
component = createComponent "FileUploader"

type Props = { accept  :: String
               , "type"  :: String
               , id      :: String
               , dispatchAlert :: (String -> String -> Effect Unit)
               }

type State 
  = { inputLabel     :: String 
    , file           :: Maybe File 
    , fileReadyState :: FileReadyState.ReadyState
    , pcmRecords     :: Either String PCM.PCMRecords
    }

data Action 
  = CancelFileInput
  | FileReady
  | FileInput EventTarget
  | FileState FileReadyState.ReadyState
  | PCMRecords (Either String PCM.PCMRecords)
  | ProcessFile (Maybe File) 
  | CreatePCMRecords 

onFileChange :: (Maybe File -> Effect Unit) -> EventTarget -> Effect Unit
onFileChange sendFile currentTarget = launchAff_ $ runMaybeT do
    fileList  <- maybe empty (MaybeT <<< liftEffect <<< Input.files) $ Input.fromEventTarget currentTarget 
    let mFile = FileList.item 0 fileList 
    
    liftEffect $ sendFile mFile 


processFile :: (Action -> Effect Unit) -> File -> Effect Unit 
processFile sendAction file = launchAff_ do 
  let blob  =  File.toBlob file
  contents  <- FileReader.readAsText_ (sendAction <<< FileState)  blob
  _ <- liftEffect $ sendAction <<< PCMRecords $ lmap show $ PCM.parseCSV contents
  liftEffect $ logShow (PCM.parseCSV contents) 

createRecords self = do 
  pcmRecs <- ExceptT $ pure self.state.pcmRecords
  _ <- pure $ PCM.createPCMRecords pcmRecs
  liftEffect $ self.props.dispatchAlert "PCM Records successfully created" "success"

fileUploader :: Props -> JSX 
fileUploader = make component { initialState, update, render }
  where 
    initialState = { inputLabel: "hello", file: Nothing, fileReadyState: FileReadyState.EMPTY, pcmRecords: pure empty } :: State

    --- Execute Action 
    update self = case _ of 
        PCMRecords records_  -> 
          Update self.state { pcmRecords = records_ } 

        CreatePCMRecords -> 
          SideEffects \_ -> launchAff_ $  do 
            eitherCreated <- (runExceptT $ createRecords self)
            if isLeft eitherCreated then liftEffect $ self.props.dispatchAlert "could not create records" "error" else pure unit 

        CancelFileInput -> 
          Update self.state { fileReadyState = FileReadyState.EMPTY, file = Nothing }

        FileReady -> 
          UpdateAndSideEffects self.state { fileReadyState = FileReadyState.DONE } $ \_ -> do 
             either (\e -> self.props.dispatchAlert (show e) "error" *> send self CancelFileInput) (const $ pure unit) self.state.pcmRecords


        FileState readyState -> case readyState of  
          FileReadyState.DONE -> 
            SideEffects \_ -> launchAff_ $ delay (Milliseconds 2000.00) *> (liftEffect $ send self FileReady)

          otherwise -> 
            UpdateAndSideEffects self.state { fileReadyState = readyState} $ \_ -> log $ "ReadyState: " <> show readyState

        FileInput currentTarget -> 
          SideEffects $ \_ -> onFileChange (send self <<< ProcessFile) currentTarget 
        
        ProcessFile file_ -> do
          let fileReadError  = Update $ setFileState false empty
              fileReadSuccess f = UpdateAndSideEffects (setFileState true file_) $ \_ -> processFile (send self) f 
              setFileState b f = self.state { file =  f} 

          maybe fileReadError fileReadSuccess file_

    render self =  case self.state.fileReadyState of 
      FileReadyState.LOADING -> DesignSystem.spinner { assistiveText: {label: "Loading..." },  variant: "brand", size: "large"}
      
      FileReadyState.DONE -> 
        R.div 
        { children: 
          [ R.p { children: pure $ R.text "12 records found" }
          , DesignSystem.button { label: "Create PCM Records", variant: "brand", onClick: capture_ self CreatePCMRecords }
          , DesignSystem.button { label: "Cancel", onClick: capture_ self CancelFileInput }
          ]
        }

      FileReadyState.EMPTY -> 
        R.div 
        { className: "slds-form-element"
        , children: pure $
            R.div 
            { className: "slds-form-element__control"
            , children: pure $
                R.div 
                { className: "slds-file-selector slds-file-selector_files"
                , children: pure $
                    R.div 
                    { className: "slds-file-selector__dropzone"
                    , children:  
                      [ DesignSystem.input_ 
                        { className: "slds-file-selector__input slds-assistive-text"
                        , accept: self.props.accept 
                        , "type": self.props."type" 
                        , id: self.props.id 
                        , onChange: capture self currentTarget FileInput
                        }
                      , DesignSystem.label_ "file-upload-input-01"
                        { className: "slds-file-selector__body"
                        , id: "file-selector-secondary-label"
                        , children: 
                          [ R.span
                            { className: "slds-file-selector__button slds-button slds-button_neutral"
                            , children: 
                              [ DesignSystem.svgUpload { className: "slds-button__icon slds-button__icon_left", children: pure $ DesignSystem.use { xlink: "http://www.w3.org/1999/xlink", xlinkHref: "/icons/utility-sprite/svg/symbols.svg#upload" } }
                              , R.text "Upload File"
                              ]
                            }
                          , R.span 
                            { className: "slds-file-selector__text slds-medium-show"
                            , children: pure $ R.text "Upload here"
                            }
                          ]
                        }
                      ]
                    }
                }
            }
        } 

PCM.purs

module Data.PCM where 

import Prelude

import Apex.Internal (ApexError(..))
import Apex.Internal as Apex
import Control.Monad.Except (runExcept)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.Either (Either)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Tuple (Tuple(..))
import Effect.Aff (Aff)
import Foreign.Class (decode, encode)
import Foreign.Object (Object)
import Foreign.Object as Object
import Text.Parsing.CSV (Parsers, makeParsers)
import Text.Parsing.Parser (ParseError, runParser)

type PCMRecords = Array (Map String String)

parseCSV :: String -> Either ParseError PCMRecords
parseCSV csv = List.toUnfoldable <$> runParser csv windowsCSVParsers.fileHeaded

windowsCSVParsers :: Parsers String
windowsCSVParsers = makeParsers '"' "," "\r\n"

createPCMRecords :: PCMRecords -> Aff (Either ApexError Unit) 
createPCMRecords r = do 
    let obj = map (\m -> Array.foldl process Object.empty $ unfoldToArray m) r
    resp <- Apex.callApex "PCMMassController.createRecords" (encode obj) { escape: true }
    let decodeUnit f = lmap (ApexError <<< show) (runExcept $ decode f) :: Either ApexError Unit

    pure (decodeUnit =<< resp)

    where 
        unfoldToArray :: Map String String -> Array (Tuple String String)
        unfoldToArray = Map.toUnfoldable 

        process :: Object String -> Tuple String String -> Object String  
        process obj (Tuple k v) = Object.insert k v obj