Emi/aviary-ps
1
0
Fork 0
Code Issues Pull requests Releases Activity

Restructure code to use a more sound model

Browse source
This commit is contained in:
Emi Simpson 2022-11-05 17:33:12 -04:00
parent 86f7740baa
commit e24bdf5b13
Signed by: Emi
GPG key ID: A12F2C2FFDC3D847
3 changed files with 133 additions and 103 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
spago.dhall
View file

@ -21,7 +21,6 @@ to generate this file without the comments in this block.
, "console"
, "effect"
, "either"
, "exceptions"
, "fetch"
, "filterable"
, "foldable-traversable"

135
src/Main.purs
View file

@ -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

100
src/Model.purs Normal file
View file

@ -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"