diff --git a/src/Logic.purs b/src/Logic.purs index 4446d2d..63a6da9 100644 --- a/src/Logic.purs +++ b/src/Logic.purs @@ -1,7 +1,7 @@ module Aviary.Logic where import Prelude -import AviaryFormat.Format (Format, Image, Index, parseIndex) as Format +import AviaryFormat.Format (Format(..), Image, Index, parseIndex) as Format import Aviary.FFI (arrayBufferToBlob, nonce) import Aviary.Model (formatToMime, GalleryError(..), Image, ImageData(..), ImageError(..), Model(..)) @@ -65,7 +65,7 @@ convertIndexFromProtobuf protoindex = let {right: images, left: imagesErrors} = partitionMap convertImageFromProtobuf protoindex'.images in case head imagesErrors of - Nothing -> GLoaded protoindex'.title protoindex'.desc images + Nothing -> GLoaded protoindex'.title protoindex'.desc images Nothing Just err -> GError err parseIndex :: ArrayBuffer -> Effect Model @@ -90,13 +90,19 @@ fetchImageAsBlobUrl nonce format key fileID = do 404 -> pure $ IError ImageNotFound s -> pure $ IError $ if s / 100 == 5 then MinorServerError else UnknownStatusCodeForImage s -fetchThumb :: Image -> Aff ImageData -fetchThumb image = case image.thumb of +_fetchImg :: ImageData -> Format.Format -> Aff CryptoKey -> Aff ImageData +_fetchImg imgdata format cryptokey = case imgdata of Unloaded fileID -> do - key <- image.key - fetchImageAsBlobUrl nonce image.format key fileID + key <- cryptokey + fetchImageAsBlobUrl nonce format key fileID loadedOrError -> pure loadedOrError +fetchThumb :: Image -> Aff ImageData +fetchThumb image = _fetchImg image.thumb Format.Format_WEBP image.key + +fetchFull :: Image -> Aff ImageData +fetchFull image = _fetchImg image.full image.format image.key + fetch_gallery_from_page_info :: Aff Model fetch_gallery_from_page_info = do urlInfo <- liftEffect do diff --git a/src/Model.purs b/src/Model.purs index e5959be..5e9dbfb 100644 --- a/src/Model.purs +++ b/src/Model.purs @@ -49,6 +49,7 @@ data Model (Maybe String) -- Title (Maybe String) -- Description (Array Image) -- Images + (Maybe Image) -- Focused image instance showGalleryError :: Show GalleryError where show (UnexpectedError message) = diff --git a/src/UI.purs b/src/UI.purs index 247bfb4..1508e3f 100644 --- a/src/UI.purs +++ b/src/UI.purs @@ -2,7 +2,7 @@ module Aviary.UI where import Prelude -import Aviary.Logic (fetchThumb) +import Aviary.Logic (fetchFull, fetchThumb) import Aviary.Model (GalleryError(..), Image, ImageData(..), Model(..)) import Control.Parallel (parSequence_) @@ -11,11 +11,13 @@ import Data.Maybe (maybe, Maybe(..)) import Effect.Aff (Aff) import Halogen as H import Halogen.HTML as HH +import Halogen.HTML.Events as HE import Halogen.HTML.Properties as HP import Web.HTML.Common (ClassName(..)) data Event = LoadThumbs | ThumbLoaded Int ImageData + | Focus Image component :: forall query input. Model -> H.Component query input Event Aff component initialState = H.mkComponent @@ -28,28 +30,47 @@ placeholderBlurhash :: forall r i. String -> HH.IProp r i placeholderBlurhash = HH.attr (HH.AttrName "data-blurhash") renderThumbnail :: forall m. Image -> H.ComponentHTML Event () m -renderThumbnail {blurhash, thumb} = +renderThumbnail image = HH.div [ HP.class_ $ ClassName "thumbnail-card" + , HE.onClick \_ -> Focus image ] ( [ HH.img - ( [ placeholderBlurhash blurhash + ( [ placeholderBlurhash image.blurhash , HP.width 400 , HP.height 400 - ] <> case thumb of + ] <> case image.thumb of ILoaded url -> [HP.src url] _ -> [] ) - ] <> case thumb of + ] <> case image.thumb of + Unloaded _ -> [HH.p_ [HH.text "Loading..."]] + IError e -> [HH.p_ [HH.text $ "Error! " <> (show e)]] + _ -> [] + ) + +renderFocused :: forall m. Image -> H.ComponentHTML Event () m +renderFocused {blurhash, full} = + HH.div + [ HP.class_ $ ClassName "focused-panel" + , HP.class_ $ ClassName "visible" + ] + ( [ HH.img + ( [ placeholderBlurhash blurhash ] + <> case full of + ILoaded url -> [HP.src url] + _ -> [] + ) + ] <> case full of Unloaded _ -> [HH.p_ [HH.text "Loading..."]] IError e -> [HH.p_ [HH.text $ "Error! " <> (show e)]] _ -> [] ) setThumb :: Int -> ImageData -> Model -> Model -setThumb pos newThumb (GLoaded title desc images) = +setThumb pos newThumb (GLoaded title desc images focus) = case modifyAt pos (\i -> i{thumb=newThumb}) images of - Just newImages -> GLoaded title desc newImages + Just newImages -> GLoaded title desc newImages focus Nothing -> GError $ UnexpectedError "setThumb called with an invalid index!" setThumb _ _ model = model @@ -63,12 +84,25 @@ update LoadThumbs = do model <- H.get case model of GError _ -> pure unit - GLoaded _ _ images -> parSequence_ $ mapWithIndex fetchThumbAction images + GLoaded _ _ images _ -> parSequence_ $ mapWithIndex fetchThumbAction images update (ThumbLoaded pos newData) = H.modify_ $ setThumb pos newData +update (Focus newFocus) = + ( H.modify_ \model -> case model of + GError e -> GError e + GLoaded title desc images _ -> GLoaded title desc images (Just newFocus) + ) <> ( do + newData <- H.liftAff $ fetchFull newFocus + H.modify_ \m -> case m of + GError e -> GError e + GLoaded title desc images Nothing -> GLoaded title desc images Nothing + GLoaded title desc images (Just focus) -> + GLoaded title desc images (Just focus{full=newData}) + ) render :: forall m. Model -> H.ComponentHTML Event () m render (GError e) = HH.p_ [ HH.text $ show e ] -render (GLoaded title desc images) = HH.div_ +render (GLoaded title desc images focus) = HH.div_ ((maybe [] (HH.text >>> pure >>> HH.h1_ >>> pure) title) <> (maybe [] (HH.text >>> pure >>> HH.p_ >>> pure) desc) <> - (renderThumbnail <$> images)) + (renderThumbnail <$> images) <> + (maybe [] (renderFocused >>> pure) focus))