Added ability to recover from some network errors

spago.dhall

@@ -19,6 +19,7 @@ to generate this file without the comments in this block.
   , "arrays"
   , "base64-codec"
   , "console"
+  , "datetime"
   , "effect"
   , "either"
   , "exceptions"

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
+                then Retrying fileID MinorServerError
-                else UnknownStatusCodeForImage status
+                else IError $ UnknownStatusCodeForImage status
-        Left e -> pure $ IError $ NetworkError $ message e
+        Left e -> pure $ Retrying fileID $ NetworkError $ message e
 
-_fetchImg :: ArrayBuffer -> ImageData -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData
+_fetchImgInner :: String -> ArrayBuffer -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData
-_fetchImg nonce imgdata format cryptokey = case imgdata of
+_fetchImgInner fileID nonce format cryptokey = do
-    Unloaded fileID -> do
+    key' <- cryptokey
-        key' <- cryptokey
+    case key' of
-        case key' of
+        Nothing -> pure $ IError BadKey
-            Nothing -> pure $ IError BadKey
+        Just key -> fetchImageAsBlobUrl nonce format key fileID
-            Just key -> fetchImageAsBlobUrl nonce format key fileID
+_fetchImg :: ImageData -> ArrayBuffer -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData
-    loadedOrError -> pure loadedOrError
+_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

src/Model.purs

@@ -20,24 +20,28 @@ data GalleryError
     | UnknownStatusCodeForIndex Int
     | TotalNetworkError
 
-data ImageError
+data RecoverableImageError
-    = MinorServerError
+    = NetworkError String
-    | ImageNotFound
+    | 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 "

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
+    | ImgLoaded Boolean Int ImageData -- isThumb, index, data
-    | FullLoaded Int ImageData
     | 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 :: (Image -> Image) -> Int -> LoadedGallery -> Model
-setImage _ _ (GError e) = (GError e)
+setImage tranformation pos gallery =
-setImage tranformation pos (GLoaded 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' (ImgLoaded isThumb pos newData) (GLoaded gal) =
-update' (FullLoaded pos newData) m = Modify $ setFull newData pos m
+    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 } })