Added ability to recover from some network errors
This commit is contained in:
parent
8a6eda1fed
commit
66f2e69026
GPG Key ID:
A12F2C2FFDC3D847
|
|
@ -19,6 +19,7 @@ to generate this file without the comments in this block.
|
|||
, "arrays"
|
||||
, "base64-codec"
|
||||
, "console"
|
||||
, "datetime"
|
||||
, "effect"
|
||||
, "either"
|
||||
, "exceptions"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 "
|
||||
|
|
|
|||
54
src/UI.purs
54
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 } })
|
||||
|
|
|
|||
Loading…
Reference in New Issue