Add handling for possible key import errors
This commit is contained in:
parent
c434b19515
commit
612fe976a0
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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"
|
||||||
|
|
Loading…
Reference in a new issue