Add handling for possible key import errors

This commit is contained in:
Emi Simpson 2022-11-07 17:49:20 -05:00
parent c434b19515
commit 612fe976a0
Signed by: Emi
GPG key ID: A12F2C2FFDC3D847
3 changed files with 65 additions and 33 deletions

View file

@ -13,7 +13,7 @@ import Effect.Exception (message)
import Fetch (fetch) import Fetch (fetch)
import Data.Array (head) import Data.Array (head)
import Data.Base64 (decodeBase64, fromString) import Data.Base64 (decodeBase64, fromString)
import Data.Either (Either(..), note) import Data.Either (Either(..), hush, note)
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap) import Data.Newtype (unwrap)
import Data.ArrayBuffer.ArrayBuffer (byteLength) import Data.ArrayBuffer.ArrayBuffer (byteLength)
@ -26,7 +26,7 @@ import Parsing (runParserT)
import Web.File.Url (createObjectURL) import Web.File.Url (createObjectURL)
import Web.HTML (window) as HTML import Web.HTML (window) as HTML
import Web.HTML.Window (location) import Web.HTML.Window (location)
import Web.HTML.Location (hash, origin, pathname) as Location import Web.HTML.Location (hash, pathname) as Location
import Crypto.Subtle.Constants.AES (aesGCM, t128) import Crypto.Subtle.Constants.AES (aesGCM, t128)
import Crypto.Subtle.Encrypt (aesGCM, decrypt) as Alg import Crypto.Subtle.Encrypt (aesGCM, decrypt) as Alg
@ -40,9 +40,14 @@ databuffToBuffer = execPut <<< putDataBuff
decodeKey :: String -> Maybe ArrayBuffer decodeKey :: String -> Maybe ArrayBuffer
decodeKey key = decodeBase64 <$> fromString key decodeKey key = decodeBase64 <$> fromString key
importKey :: ArrayBuffer -> Aff CryptoKey importKey :: ArrayBuffer -> Aff (Either GalleryError CryptoKey)
importKey key = importKey key = do
SC.importKey raw key (aes aesGCM) false [decrypt] maybeImportedKey <- try $ SC.importKey raw key (aes aesGCM) false [decrypt]
pure case maybeImportedKey of
Right importedKey -> Right importedKey
Left _ -> Left if byteLength key == 0
then MissingKey
else MalformedKey
decryptBlob :: CryptoKey -> ArrayBuffer -> ArrayBuffer -> Aff ArrayBuffer decryptBlob :: CryptoKey -> ArrayBuffer -> ArrayBuffer -> Aff ArrayBuffer
decryptBlob key cyphertext nonce = decryptBlob key cyphertext nonce =
@ -55,7 +60,7 @@ convertImageFromProtobuf protoimage = let protoimage' = unwrap protoimage in do
thumbUrl <- note (IndexMissingField "images[].thumb_url") protoimage'.thumb_url thumbUrl <- note (IndexMissingField "images[].thumb_url") protoimage'.thumb_url
blurhash <- note (IndexMissingField "images[].blurhash") protoimage'.blurhash blurhash <- note (IndexMissingField "images[].blurhash") protoimage'.blurhash
format <- note (IndexMissingField "images[].format") protoimage'.format format <- note (IndexMissingField "images[].format") protoimage'.format
let key = importKey =<< liftEffect (databuffToBuffer $ unwrap rawKey) let key = hush <$> (importKey =<< liftEffect (databuffToBuffer $ unwrap rawKey))
let thumb = Unloaded thumbUrl let thumb = Unloaded thumbUrl
let full = Unloaded fullUrl let full = Unloaded fullUrl
pure { key, blurhash, format, thumb, full } pure { key, blurhash, format, thumb, full }
@ -100,11 +105,13 @@ fetchImageAsBlobUrl nonce format key fileID = do
else UnknownStatusCodeForImage status else UnknownStatusCodeForImage status
Left e -> pure $ IError $ NetworkError $ message e Left e -> pure $ IError $ NetworkError $ message e
_fetchImg :: ImageData -> Format.Format -> Aff CryptoKey -> Aff ImageData _fetchImg :: ImageData -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData
_fetchImg imgdata format cryptokey = case imgdata of _fetchImg imgdata format cryptokey = case imgdata of
Unloaded fileID -> do Unloaded fileID -> do
key <- cryptokey key' <- cryptokey
fetchImageAsBlobUrl nonce format key fileID case key' of
Nothing -> pure $ IError BadKey
Just key -> fetchImageAsBlobUrl nonce format key fileID
loadedOrError -> pure loadedOrError loadedOrError -> pure loadedOrError
fetchThumb :: Image -> Aff ImageData fetchThumb :: Image -> Aff ImageData
@ -113,32 +120,42 @@ fetchThumb image = _fetchImg image.thumb Format.Format_WEBP image.key
fetchFull :: Image -> Aff ImageData fetchFull :: Image -> Aff ImageData
fetchFull image = _fetchImg image.full image.format image.key fetchFull image = _fetchImg image.full image.format image.key
fetch_gallery_from_page_info :: Aff Model type Parameters =
fetch_gallery_from_page_info = do { fileId :: String
, key :: CryptoKey
}
get_parameters :: Aff (Either GalleryError Parameters)
get_parameters = do
urlInfo <- liftEffect do urlInfo <- liftEffect do
window <- HTML.window window <- HTML.window
location <- location window location <- location window
keyB64 <- drop 1 <$> Location.hash location keyB64 <- drop 1 <$> Location.hash location
server <- Location.origin location
fileId <- drop 1 <$> Location.pathname location fileId <- drop 1 <$> Location.pathname location
pure {keyB64, server, fileId} pure {keyB64, fileId}
case decodeKey urlInfo.keyB64 of case decodeKey urlInfo.keyB64 of
Nothing -> pure $ GError MalformedKey Nothing -> pure $ Left MalformedKey
Just keyBuffer -> do Just keyBuffer -> do
cryptoKey <- importKey keyBuffer cryptoKey <- importKey keyBuffer
result <- try $ fetch (urlInfo.server <> "/" <> urlInfo.fileId <> ".bin") {} case cryptoKey of
case result of Left e -> pure $ Left e
Right {status: 200, arrayBuffer} -> do Right cryptoKey' -> pure $ Right {fileId: urlInfo.fileId, key: cryptoKey'}
encryptedIndex <- arrayBuffer
serializedIndex <- try $ decryptBlob cryptoKey encryptedIndex nonce fetch_and_decrypt_gallery :: Parameters -> Aff Model
case serializedIndex of fetch_and_decrypt_gallery params = do
Left _ -> pure $ GError DecryptFailed result <- try $ fetch (params.fileId <> ".bin") {}
Right serializedIndex' -> do case result of
liftEffect $ parseIndex serializedIndex' Right {status: 200, arrayBuffer} -> do
Right {status: 404} -> pure $ GError NotFound encryptedIndex <- arrayBuffer
Right {status} -> serializedIndex <- try $ decryptBlob params.key encryptedIndex nonce
pure $ GError $ case serializedIndex of
if status / 100 == 5 Left _ -> pure $ GError DecryptFailed
then ServerError Right serializedIndex' -> do
else UnknownStatusCodeForIndex status liftEffect $ parseIndex serializedIndex'
Left _ -> pure $ GError $ TotalNetworkError Right {status: 404} -> pure $ GError NotFound
Right {status} ->
pure $ GError $
if status / 100 == 5
then ServerError
else UnknownStatusCodeForIndex status
Left _ -> pure $ GError $ TotalNetworkError

View file

@ -2,8 +2,10 @@ module Main where
import Prelude import Prelude
import Aviary.UI (component) import Aviary.UI (component)
import Aviary.Logic (fetch_gallery_from_page_info) import Aviary.Logic (fetch_and_decrypt_gallery, get_parameters)
import Aviary.Model (Model(..))
import Data.Either (Either(..))
import Effect (Effect) import Effect (Effect)
import Effect.Aff (Aff, launchAff) import Effect.Aff (Aff, launchAff)
import Halogen.Aff (awaitBody) import Halogen.Aff (awaitBody)
@ -12,7 +14,10 @@ import Halogen.VDom.Driver (runUI)
main_aff :: Aff Unit main_aff :: Aff Unit
main_aff = do main_aff = do
body <- awaitBody body <- awaitBody
gallery <- fetch_gallery_from_page_info parameters <- get_parameters
gallery <- case parameters of
Left e -> pure $ GError e
Right parameters' -> fetch_and_decrypt_gallery parameters'
_ <- runUI (component gallery) unit body _ <- runUI (component gallery) unit body
pure unit pure unit

View file

@ -13,6 +13,7 @@ data GalleryError
| ServerError | ServerError
| NotFound | NotFound
| MalformedKey | MalformedKey
| MissingKey
| DecryptFailed | DecryptFailed
| StrangeIndex | StrangeIndex
| IndexMissingField String | IndexMissingField String
@ -26,6 +27,7 @@ data ImageError
| ImageDecryptFailed | ImageDecryptFailed
| NetworkError String | NetworkError String
| UnknownStatusCodeForImage Int | UnknownStatusCodeForImage Int
| BadKey
data ImageData data ImageData
= Unloaded String -- file ID of encrypted data = Unloaded String -- file ID of encrypted data
@ -38,7 +40,7 @@ instance showImageData :: Show ImageData where
show (IError e) = "error loading image: " <> (show e) show (IError e) = "error loading image: " <> (show e)
type Image = type Image =
{ key :: Aff CryptoKey { key :: Aff (Maybe CryptoKey)
, blurhash :: String , blurhash :: String
, format :: Format.Format , format :: Format.Format
, thumb :: ImageData , thumb :: ImageData
@ -72,6 +74,12 @@ instance showGalleryError :: Show GalleryError where
<> "Please double check that you entered the correct URL, the whole URL, and " <> "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, " <> "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." <> "the person who gave you this URL might have sent the wrong one."
show MissingKey =
"This image gallery is encrypted, and you don't have the key! Double check "
<> "you've entered the whole URL, which should include a pound sign (#) in the "
<> "middle. If the URL you were sent doesn't have a pound sign in the middle, "
<> "you were sent a partial URL and won't be able to decrypt this content "
<> "without a key."
show DecryptFailed = show DecryptFailed =
"I wasn't able to decrypt any information about the gallery at this location. " "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 " <> "If you're sure you entered the URL correctly, it's likely that the gallery "
@ -113,6 +121,8 @@ instance showImageError :: Show ImageError where
"Huh! The server returned a status code that I don't know the meaning of. " "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 " <> "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) <> "and be more helpful next time. The unknown code was: " <> (show code)
show BadKey =
"The key associated with this image is bad, and it cannot be loaded"
formatToMime :: Format.Format -> String formatToMime :: Format.Format -> String
formatToMime Format.Format_WEBP = "image/webp" formatToMime Format.Format_WEBP = "image/webp"