diff --git a/spago.dhall b/spago.dhall index df0019a..1ca43ab 100644 --- a/spago.dhall +++ b/spago.dhall @@ -21,7 +21,6 @@ to generate this file without the comments in this block. , "console" , "effect" , "either" - , "exceptions" , "fetch" , "filterable" , "foldable-traversable" diff --git a/src/Main.purs b/src/Main.purs index b6aed32..2bcc538 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -1,20 +1,19 @@ module Main 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) +import Aviary.Model (formatToMime, GalleryError(..), Image, ImageData(..), ImageError(..), Model(..)) import Control.Monad.Error.Class (try) -import Control.Parallel (parTraverse) import Effect (Effect) import Effect.Aff (Aff, launchAff) import Effect.Class (liftEffect) import Effect.Console (log) -import Effect.Exception (message) import Fetch (fetch) import Data.Array (head) import Data.Base64 (decodeBase64, fromString) -import Data.Either (Either(..), hush, note) +import Data.Either (Either(..), note) import Data.Maybe (Maybe(..)) import Data.Newtype (unwrap) import Data.ArrayBuffer.ArrayBuffer (byteLength) @@ -23,8 +22,7 @@ import Data.ArrayBuffer.DataView (whole) import Data.ArrayBuffer.Types (ArrayBuffer) import Data.Filterable (partitionMap) import Data.Foldable (traverse_) -import Data.String (drop, indexOf', indexOf, splitAt) -import Data.String.Pattern (Pattern(..)) +import Data.String (drop) import Parsing (runParserT) import Web.File.Url (createObjectURL) import Web.HTML (window) as HTML @@ -43,67 +41,8 @@ nonceE = execPut $ traverse_ putInt8 [0xd0, 0xc3, 0x75, 0x56, 0x58, 0xc1, 0x7e, databuffToBuffer :: DataBuff -> Effect ArrayBuffer databuffToBuffer = execPut <<< putDataBuff -data AviaryError - = ServerError - | UnexpectedStatusCode Int - | MalformedKey - | MalformedUrl - | DecryptFailed - | ImageDecryptFailed - | StrangeIndex - | IndexMissingField String - | ImageNotFound - | IndexNotFound - -type Image = - { key :: Aff CryptoKey - , fullUrl :: String - , thumbUrl :: String - , blurhash :: String - , format :: Format.Format - } - -type Index = - { images :: Array Image - , title :: Maybe String - , desc :: Maybe String - } - -instance showAviaryError :: Show AviaryError where - show ServerError = "The server encountered an error" - show MalformedKey = "Malformed key!!" - show MalformedUrl = "Malformed url!!" - show DecryptFailed = "Either the data provided by the server was bad, or valid but incorrect key. Expiration likely." - show ImageDecryptFailed = "The decryption of the album's index succeeded, but it contained a reference to an image whose decryption failed. This likely indicates expiration" - show StrangeIndex = "The gallery index matched with the provided key, but was in a strange format. This could indicate a severe version mismatch, or that the gallery was created by a malfunctioning client." - show (IndexMissingField f) = "The gallery index was missing the crucial field " <> f <> ". This is almost certainly the result of a version mismatch or that the creator's client was not fully up-to-spec." - show ImageNotFound = "The image was not found, likely indicating that it expired" - show IndexNotFound = "The index was not found, likely indicating that the gallery never existed or expired" - show (UnexpectedStatusCode status) = "Server returned an unexpected status code: " <> (show status) - -type UrlInfo = - { server :: String - , fileId :: String - , key :: String - } - -formatToMime :: Format.Format -> String -formatToMime Format.Format_WEBP = "image/webp" -formatToMime Format.Format_AVIF = "image/avif" -formatToMime Format.Format_JPG = "image/jpeg" -formatToMime Format.Format_PNG = "image/png" -formatToMime Format.Format_GIF = "image/gif" - -parseUrl :: String -> Either AviaryError UrlInfo -parseUrl url = note MalformedUrl do - slashIndex <- indexOf' (Pattern "/") 8 url - let { after, before: server } = splitAt (1 + slashIndex) url - poundIndex <- indexOf (Pattern "#") after - let { after: key, before: fileId } = splitAt poundIndex after - Just { server, fileId, key: drop 1 key } - -decodeKey :: String -> Either AviaryError ArrayBuffer -decodeKey key = note MalformedKey $ decodeBase64 <$> fromString key +decodeKey :: String -> Maybe ArrayBuffer +decodeKey key = decodeBase64 <$> fromString key importKey :: ArrayBuffer -> Aff CryptoKey importKey key = @@ -114,7 +53,7 @@ decryptBlob key cyphertext nonce = -- nonce <- makeAff (\_ -> nonceE) Alg.decrypt (Alg.aesGCM nonce Nothing (Just t128)) key cyphertext -convertImageFromProtobuf :: Format.Image -> Either AviaryError Image +convertImageFromProtobuf :: Format.Image -> Either GalleryError Image convertImageFromProtobuf protoimage = let protoimage' = unwrap protoimage in do rawKey <- note (IndexMissingField "images[].key") protoimage'.key fullUrl <- note (IndexMissingField "images[].full_url") protoimage'.full_url @@ -122,43 +61,40 @@ convertImageFromProtobuf protoimage = let protoimage' = unwrap protoimage in do blurhash <- note (IndexMissingField "images[].blurhash") protoimage'.blurhash format <- note (IndexMissingField "images[].format") protoimage'.format let key = importKey =<< liftEffect (databuffToBuffer $ unwrap rawKey) - pure { key, fullUrl, thumbUrl, blurhash, format } + let thumb = Unloaded thumbUrl + let full = Unloaded fullUrl + pure { key, blurhash, format, thumb, full } -convertIndexFromProtobuf :: Format.Index -> Either AviaryError Index +convertIndexFromProtobuf :: Format.Index -> Model convertIndexFromProtobuf protoindex = let protoindex' = unwrap protoindex in let {right: images, left: imagesErrors} = partitionMap convertImageFromProtobuf protoindex'.images in case head imagesErrors of - Nothing -> - Right - { images - , title: protoindex'.title - , desc: protoindex'.desc - } - Just err -> Left err + Nothing -> GLoaded protoindex'.title protoindex'.desc images + Just err -> GError err -parseIndex :: ArrayBuffer -> Effect (Either AviaryError Index) +parseIndex :: ArrayBuffer -> Effect Model parseIndex rawData = do parseResult <- runParserT (whole rawData) (Format.parseIndex (byteLength rawData)) - _ <- liftEffect $ log $ show (parseResult) - pure $ convertIndexFromProtobuf =<< (note StrangeIndex $ hush parseResult) + pure case parseResult of + Left _ -> GError StrangeIndex + Right index -> convertIndexFromProtobuf index -fetchImageAsBlobUrl :: ArrayBuffer -> Image -> Aff (Either AviaryError String) -fetchImageAsBlobUrl nonce image = do - cryptoKey <- image.key - { status, arrayBuffer } <- fetch (image.fullUrl <> ".bin") {} +fetchImageAsBlobUrl :: ArrayBuffer -> Format.Format -> CryptoKey -> String -> Aff ImageData +fetchImageAsBlobUrl nonce format key fileID = do + { status, arrayBuffer } <- fetch (fileID <> ".bin") {} case status of 200 -> do encryptedImage <- arrayBuffer - decryptedImage <- try $ decryptBlob cryptoKey encryptedImage nonce + decryptedImage <- try $ decryptBlob key encryptedImage nonce case decryptedImage of - Left _ -> pure $ Left ImageDecryptFailed + Left _ -> pure $ IError ImageDecryptFailed Right rawImage -> do - url <- liftEffect $ createObjectURL $ (arrayBufferToBlob $ formatToMime image.format) rawImage - pure $ Right url - 404 -> pure $ Left ImageNotFound - s -> pure $ Left $ if s / 100 == 5 then ServerError else UnexpectedStatusCode s + url <- liftEffect $ createObjectURL $ (arrayBufferToBlob $ formatToMime format) rawImage + pure $ ILoaded url + 404 -> pure $ IError ImageNotFound + s -> pure $ IError $ if s / 100 == 5 then MinorServerError else UnknownStatusCodeForImage s main_aff :: Aff Unit main_aff = do @@ -170,9 +106,9 @@ main_aff = do fileId <- drop 1 <$> Location.pathname location nonce <- nonceE pure {keyB64, server, fileId, nonce} - maybeIndex <- case decodeKey urlInfo.keyB64 of - Left err -> pure $ Left err - Right keyBuffer -> do + gallery <- case decodeKey urlInfo.keyB64 of + Nothing -> pure $ GError MalformedKey + Just keyBuffer -> do cryptoKey <- importKey keyBuffer { status, arrayBuffer } <- fetch (urlInfo.server <> "/" <> urlInfo.fileId <> ".bin") {} case status of @@ -180,17 +116,12 @@ main_aff = do encryptedIndex <- arrayBuffer serializedIndex <- try $ decryptBlob cryptoKey encryptedIndex urlInfo.nonce case serializedIndex of - Left err -> do - _ <- liftEffect $ log $ message err - pure $ Left $ DecryptFailed + Left _ -> pure $ GError DecryptFailed Right serializedIndex' -> do liftEffect $ parseIndex serializedIndex' - 404 -> pure $ Left ImageNotFound - s -> pure $ Left $ if s / 100 == 5 then ServerError else UnexpectedStatusCode s - maybeUrls <- case maybeIndex of - Left err -> pure $ Left err - Right index -> Right <$> parTraverse (fetchImageAsBlobUrl urlInfo.nonce) index.images - liftEffect $ log $ show maybeUrls + 404 -> pure $ GError NotFound + s -> pure $ GError $ if s / 100 == 5 then ServerError else UnknownStatusCodeForIndex s + liftEffect $ log "Gallery info loaded or error. No I won't tell you which one." main :: Effect Unit main = launchAff main_aff $> unit diff --git a/src/Model.purs b/src/Model.purs new file mode 100644 index 0000000..0c5154e --- /dev/null +++ b/src/Model.purs @@ -0,0 +1,100 @@ +module Aviary.Model where + +import Prelude + +import AviaryFormat.Format (Format(..)) as Format + +import Crypto.Subtle.Key.Types (CryptoKey) +import Data.Maybe (Maybe(..)) +import Effect.Aff (Aff) + +data GalleryError + = ServerError + | NotFound + | MalformedKey + | DecryptFailed + | StrangeIndex + | IndexMissingField String + | UnknownStatusCodeForIndex Int + +data ImageError + = MinorServerError + | ImageNotFound + | BadIndexData + | ImageDecryptFailed + | UnknownStatusCodeForImage Int + +data ImageData + = Unloaded String -- file ID of encrypted data + | ILoaded String -- blob url of decrypted image + | IError ImageError + +type Image = + { key :: Aff CryptoKey + , blurhash :: String + , format :: Format.Format + , thumb :: ImageData + , full :: ImageData + } + +data Model + = GError GalleryError + | GLoaded + (Maybe String) -- Title + (Maybe String) -- Description + (Array Image) -- Images + +instance showGalleryError :: Show GalleryError where + show ServerError = + "The server is experiencing issues at the minute. Please try again later, or if " + <> "it keeps up, make a report to the server owner." + show NotFound = + "Either this gallery never existed, or it has already expired. Either way, " + <> "there's nothing here now." + show MalformedKey = + "Hmm, something about the decryption key in your URL doesn't seem quite right. " + <> "Please double check that you entered the correct URL, the whole URL, and " + <> "nothing but the URL (especially the numbers and letters at the end). If so, " + <> "the person who gave you this URL might have sent the wrong one." + show DecryptFailed = + "I wasn't able to decrypt any information about the gallery at this location. " + <> "If you're sure you entered the URL correctly, it's likely that the gallery " + <> "that used to be here has expired." + show StrangeIndex = + "Hmm, something is strange here. I was able to decrypt the data for this " + <> "gallery, but I couldn't make any sense of it. It's possible that this " + <> "gallery was created with an incompatible protocol, or the client used to " + <> "create this gallery was malfunctioning. Specifically, the gallery index was " + <> "successfully decrypted, but isn't valid protobuf data." + show (IndexMissingField field) = + "Uh oh! This gallery's index was missing crucial information. This probably " + <> "means that it was created with an older version of Aviary that is no longer " + <> "supported. The field that was missing is: " <> field + show (UnknownStatusCodeForIndex 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 " + <> "and be more helpful next time. The unknown code was: " <> (show code) + +instance showImageError :: Show ImageError 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 ImageNotFound = + "This image has expired, and isn't available anymore" + show BadIndexData = + "Uh oh! This gallery had some corrupted-seeming data in it, and I wasn't able " + <> "to load this image because of it." + show ImageDecryptFailed = + "This image seems to have expired" + 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 " + <> "and be more helpful next time. The unknown code was: " <> (show code) + +formatToMime :: Format.Format -> String +formatToMime Format.Format_WEBP = "image/webp" +formatToMime Format.Format_AVIF = "image/avif" +formatToMime Format.Format_JPG = "image/jpeg" +formatToMime Format.Format_PNG = "image/png" +formatToMime Format.Format_GIF = "image/gif"