From 66f2e6902682048292ab8ece209e43a0c61778ef Mon Sep 17 00:00:00 2001 From: Emi Simpson Date: Tue, 15 Nov 2022 22:18:19 -0500 Subject: [PATCH] Added ability to recover from some network errors --- spago.dhall | 1 + src/Logic.purs | 40 +++++++++++++++++++++++-------------- src/Model.purs | 22 ++++++++++++-------- src/UI.purs | 54 +++++++++++++++++++++++++++++++++++++++----------- 4 files changed, 82 insertions(+), 35 deletions(-) diff --git a/spago.dhall b/spago.dhall index ba392de..6b67969 100644 --- a/spago.dhall +++ b/spago.dhall @@ -19,6 +19,7 @@ to generate this file without the comments in this block. , "arrays" , "base64-codec" , "console" + , "datetime" , "effect" , "either" , "exceptions" diff --git a/src/Logic.purs b/src/Logic.purs index 39a1303..251820b 100644 --- a/src/Logic.purs +++ b/src/Logic.purs @@ -3,7 +3,15 @@ module Aviary.Logic where import Prelude import AviaryFormat.Format (Format(..), Image, Index, parseIndex) as Format import Aviary.FFI (arrayBufferToBlob, nonce_a, nonce_b, decodeBlurhash32) -import Aviary.Model (formatToMime, GalleryError(..), Image, ImageData(..), ImageError(..), Model(..)) +import Aviary.Model + ( formatToMime + , GalleryError(..) + , Image + , ImageData(..) + , Model(..) + , PermanentImageError(..) + , RecoverableImageError(..) + ) import Control.Monad.Error.Class (try) import Effect (Effect) @@ -105,26 +113,28 @@ fetchImageAsBlobUrl nonce format key fileID = do url <- liftEffect $ createObjectURL $ (arrayBufferToBlob $ formatToMime format) rawImage pure $ ILoaded url Right {status: 404} -> pure $ IError ImageNotFound - Right {status} -> pure $ IError $ + Right {status} -> pure $ if status / 100 == 5 - then MinorServerError - else UnknownStatusCodeForImage status - Left e -> pure $ IError $ NetworkError $ message e + then Retrying fileID MinorServerError + else IError $ UnknownStatusCodeForImage status + Left e -> pure $ Retrying fileID $ NetworkError $ message e -_fetchImg :: ArrayBuffer -> ImageData -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData -_fetchImg nonce imgdata format cryptokey = case imgdata of - Unloaded fileID -> do - key' <- cryptokey - case key' of - Nothing -> pure $ IError BadKey - Just key -> fetchImageAsBlobUrl nonce format key fileID - loadedOrError -> pure loadedOrError +_fetchImgInner :: String -> ArrayBuffer -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData +_fetchImgInner fileID nonce format cryptokey = do + key' <- cryptokey + case key' of + Nothing -> pure $ IError BadKey + Just key -> fetchImageAsBlobUrl nonce format key fileID +_fetchImg :: ImageData -> ArrayBuffer -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData +_fetchImg (Retrying fileID _) = _fetchImgInner fileID +_fetchImg (Unloaded fileID) = _fetchImgInner fileID +_fetchImg loadedOrError = \_ -> \_ -> \_ -> pure loadedOrError fetchThumb :: Image -> Aff ImageData -fetchThumb image = _fetchImg nonce_b image.thumb Format.Format_WEBP image.key +fetchThumb image = _fetchImg image.thumb nonce_b Format.Format_WEBP image.key fetchFull :: Image -> Aff ImageData -fetchFull image = _fetchImg nonce_a image.full image.format image.key +fetchFull image = _fetchImg image.full nonce_a image.format image.key type Parameters = { fileId :: String diff --git a/src/Model.purs b/src/Model.purs index 155d76f..fba812d 100644 --- a/src/Model.purs +++ b/src/Model.purs @@ -20,24 +20,28 @@ data GalleryError | UnknownStatusCodeForIndex Int | TotalNetworkError -data ImageError - = MinorServerError - | ImageNotFound +data RecoverableImageError + = NetworkError String + | MinorServerError + +data PermanentImageError + = ImageNotFound | BadIndexData | ImageDecryptFailed - | NetworkError String | UnknownStatusCodeForImage Int | BadKey data ImageData = Unloaded String -- file ID of encrypted data | Loading + | Retrying String RecoverableImageError | ILoaded String -- blob url of decrypted image - | IError ImageError + | IError PermanentImageError instance showImageData :: Show ImageData where show (Unloaded fileID) = "Unloaded Image with fileID " <> fileID show Loading = "Image loading..." + show (Retrying fileID e) = "temporary network error [" <> (show e) <> "] while loading image with fileID " <> fileID show (ILoaded url) = "image: " <> url show (IError e) = "error loading image: " <> (show e) @@ -112,11 +116,15 @@ instance showGalleryError :: Show GalleryError where "Check that you are connected to the internet and then try again. It's " <> "also possible that the server is down at the minute." -instance showImageError :: Show ImageError where +instance showRecoverableImageError :: Show RecoverableImageError where show MinorServerError = "Oops! The server is experiencing issues at the minute, and wasn't able to send " <> "this image. Please try reloading the page after a few minutes, and if the " <> "issue keeps up, try contacting the server admin." + show (NetworkError msg) = + "A network error occured while trying to download this image - " <> msg + +instance showPermanentImageError :: Show PermanentImageError where show ImageNotFound = "This image has expired, and isn't available anymore" show BadIndexData = @@ -124,8 +132,6 @@ instance showImageError :: Show ImageError where <> "to load this image because of it." show ImageDecryptFailed = "This image seems to have expired" - show (NetworkError msg) = - "A network error occured while trying to download this image - " <> msg show (UnknownStatusCodeForImage code) = "Huh! The server returned a status code that I don't know the meaning of. " <> "Please consider opening an issue on our issue tracker so that I can improve " diff --git a/src/UI.purs b/src/UI.purs index a2d747f..fd6aabc 100644 --- a/src/UI.purs +++ b/src/UI.purs @@ -6,6 +6,7 @@ import Aviary.Logic (fetchFull, fetchThumb) import Aviary.Model ( GalleryError(..) , Image , ImageData(..) + , LoadedGallery , Model(..) ) @@ -14,7 +15,8 @@ import Control.Monad.Free (liftF) import Data.Array (index, length, mapWithIndex, modifyAt) import Data.Maybe (fromMaybe, maybe, Maybe(..)) import Data.Tuple (Tuple(..)) -import Effect.Aff (Aff) +import Data.Time.Duration (Milliseconds(..)) +import Effect.Aff (Aff, delay) import Halogen as H import Halogen.HTML as HH import Halogen.HTML.Events as HE @@ -28,9 +30,11 @@ import Web.HTML.Window (document) as Web import Web.UIEvent.KeyboardEvent as KE import Web.UIEvent.KeyboardEvent.EventTypes as KET +failCooldown :: Milliseconds +failCooldown = Milliseconds 10000.0 + data Event = LoadThumbs - | ThumbLoaded Int ImageData - | FullLoaded Int ImageData + | ImgLoaded Boolean Int ImageData -- isThumb, index, data | Focus Int | Unfocus | Zoom @@ -72,6 +76,13 @@ renderThumbnail pos image = [ HH.text "Loading..." ] ] + Retrying _ e -> + [ HH.span + [ HP.class_ $ ClassName "error-msg" + ] + [ HH.text $ "Error! " <> (show e) + ] + ] IError e -> [ HH.span [ HP.class_ $ ClassName "error-msg" @@ -140,6 +151,13 @@ renderFocused zoom image = [ HH.text $ "Error! " <> (show e) ] ] + Retrying _ e -> + [ HH.span + [ HP.class_ $ ClassName "error-msg" + ] + [ HH.text $ "Error! " <> (show e) + ] + ] ILoaded url -> [ HH.img [ HP.src url @@ -148,24 +166,23 @@ renderFocused zoom image = ] ] -setImage :: (Image -> Image) -> Int -> Model -> Model -setImage _ _ (GError e) = (GError e) -setImage tranformation pos (GLoaded gallery) = +setImage :: (Image -> Image) -> Int -> LoadedGallery -> Model +setImage tranformation pos gallery = case modifyAt pos tranformation gallery.images of Just newImages -> GLoaded gallery{images = newImages} Nothing -> GError $ UnexpectedError "setImage called with an out of bounds index!" -setThumb :: ImageData -> Int -> Model -> Model +setThumb :: ImageData -> Int -> LoadedGallery -> Model setThumb newThumb = setImage \i -> i{thumb = newThumb} -setFull :: ImageData -> Int -> Model -> Model +setFull :: ImageData -> Int -> LoadedGallery -> Model setFull newImage = setImage \i -> i{full = newImage} fetchThumbAction :: Int -> Image -> Aff Event -fetchThumbAction position image = fetchThumb image <#> ThumbLoaded position +fetchThumbAction position image = fetchThumb image <#> ImgLoaded true position fetchFullAction :: Int -> Image -> Aff Event -fetchFullAction position image = fetchFull image <#> FullLoaded position +fetchFullAction position image = fetchFull image <#> ImgLoaded false position eventByKey :: KE.KeyboardEvent -> Maybe Event eventByKey ev = case KE.key ev of @@ -206,8 +223,21 @@ update' :: Event -> Model -> UpdateResult update' Init _ = Affect $ [RegisterListeners, LoadThumbs] <#> pure update' LoadThumbs (GLoaded {images}) = Affect $ mapWithIndex fetchThumbAction images -update' (ThumbLoaded pos newData) m = Modify $ setThumb newData pos m -update' (FullLoaded pos newData) m = Modify $ setFull newData pos m +update' (ImgLoaded isThumb pos newData) (GLoaded gal) = + let newGallery = (if isThumb then setThumb else setFull) newData pos gal + updatedImage = case newGallery of + (GLoaded {images}) -> index images pos + _ -> Nothing + retryAction = \img -> do + let fetch = if isThumb then fetchThumbAction else fetchFullAction + _ <- delay failCooldown + fetch pos img + in case newData, updatedImage of + (Retrying _ _), Just img -> Both [retryAction img] newGallery + (IError _), _ -> Modify newGallery + (ILoaded _), _ -> Modify newGallery + _, Nothing -> Modify $ GError $ UnexpectedError $ "Suprising out of bound index!" + weirdData, _ -> Modify $ GError $ UnexpectedError $ "Strange newData passed in ImgLoaded event: " <> show weirdData <> " Please open an issue on our issue tracker!" update' (Focus imageIndex) (GLoaded gal) = Both ([DownloadImage >>> pure] <*> [imageIndex, imageIndex - 1, imageIndex + 1]) (GLoaded gal{ focus = Just { imageIndex, zoom: false } })