178 lines
7.0 KiB
Plaintext
178 lines
7.0 KiB
Plaintext
module Aviary.Logic where
|
|
|
|
import Prelude
|
|
import AviaryFormat.Format (Format(..), Image, Index, parseIndex) as Format
|
|
import Aviary.FFI (arrayBufferToBlob, nonce_a, nonce_b, decodeBlurhash32)
|
|
import Aviary.Model
|
|
( formatToMime
|
|
, GalleryError(..)
|
|
, Image
|
|
, ImageData(..)
|
|
, Model(..)
|
|
, PermanentImageError(..)
|
|
, RecoverableImageError(..)
|
|
)
|
|
|
|
import Control.Monad.Error.Class (try)
|
|
import Effect (Effect)
|
|
import Effect.Aff (Aff)
|
|
import Effect.Class (liftEffect)
|
|
import Effect.Exception (message)
|
|
import Fetch (fetch)
|
|
import Data.Array (head)
|
|
import Data.Base64 (decodeBase64, fromString)
|
|
import Data.Either (Either(..), hush, note)
|
|
import Data.Maybe (fromMaybe, Maybe(..))
|
|
import Data.Newtype (unwrap)
|
|
import Data.ArrayBuffer.ArrayBuffer (byteLength)
|
|
import Data.ArrayBuffer.Builder (DataBuff, execPut, putDataBuff)
|
|
import Data.ArrayBuffer.DataView (whole)
|
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
|
import Data.Filterable (partitionMap)
|
|
import Data.String (drop)
|
|
import Parsing (runParserT)
|
|
import Protobuf.Internal.Prelude (toInt)
|
|
import Web.File.Url (createObjectURL)
|
|
import Web.HTML (window) as HTML
|
|
import Web.HTML.Window (location)
|
|
import Web.HTML.Location (hash, pathname) as Location
|
|
|
|
import Crypto.Subtle.Constants.AES (aesGCM, t128)
|
|
import Crypto.Subtle.Encrypt (aesGCM, decrypt) as Alg
|
|
import Crypto.Subtle.Key.Import (aes)
|
|
import Crypto.Subtle.Key.Import (importKey) as SC
|
|
import Crypto.Subtle.Key.Types (CryptoKey, decrypt, raw)
|
|
|
|
databuffToBuffer :: DataBuff -> Effect ArrayBuffer
|
|
databuffToBuffer = execPut <<< putDataBuff
|
|
|
|
decodeKey :: String -> Maybe ArrayBuffer
|
|
decodeKey key = decodeBase64 <$> fromString key
|
|
|
|
importKey :: ArrayBuffer -> Aff (Either GalleryError CryptoKey)
|
|
importKey key = do
|
|
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 key cyphertext nonce =
|
|
Alg.decrypt (Alg.aesGCM nonce Nothing (Just t128)) key cyphertext
|
|
|
|
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
|
|
thumbUrl <- note (IndexMissingField "images[].thumb_url") protoimage'.thumb_url
|
|
blurhash <- note (IndexMissingField "images[].blurhash") protoimage'.blurhash
|
|
width' <- note (IndexMissingField "images[].width") protoimage'.width
|
|
height' <- note (IndexMissingField "images[].height") protoimage'.height
|
|
let format = fromMaybe Format.Format_WEBP protoimage'.format
|
|
let blurhashUrl = decodeBlurhash32 blurhash
|
|
let key = hush <$> (importKey =<< liftEffect (databuffToBuffer $ unwrap rawKey))
|
|
let thumb = Unloaded thumbUrl
|
|
let full = Unloaded fullUrl
|
|
let width = toInt width'
|
|
let height = toInt height'
|
|
pure { key, blurhashUrl, format, thumb, full, width, height }
|
|
|
|
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 -> GLoaded
|
|
{ title: protoindex'.title
|
|
, desc: protoindex'.desc
|
|
, images
|
|
, focus: Nothing
|
|
}
|
|
Just err -> GError err
|
|
|
|
parseIndex :: ArrayBuffer -> Effect Model
|
|
parseIndex rawData = do
|
|
parseResult <- runParserT (whole rawData) (Format.parseIndex (byteLength rawData))
|
|
pure case parseResult of
|
|
Left _ -> GError StrangeIndex
|
|
Right index -> convertIndexFromProtobuf index
|
|
|
|
fetchImageAsBlobUrl :: ArrayBuffer -> Format.Format -> CryptoKey -> String -> Aff ImageData
|
|
fetchImageAsBlobUrl nonce format key fileID = do
|
|
result <- try $ fetch (fileID <> ".bin") {}
|
|
case result of
|
|
Right {status: 200, arrayBuffer} -> do
|
|
encryptedImage <- arrayBuffer
|
|
decryptedImage <- try $ decryptBlob key encryptedImage nonce
|
|
case decryptedImage of
|
|
Left _ -> pure $ IError ImageDecryptFailed
|
|
Right rawImage -> do
|
|
url <- liftEffect $ createObjectURL $ (arrayBufferToBlob $ formatToMime format) rawImage
|
|
pure $ ILoaded url
|
|
Right {status: 404} -> pure $ IError ImageNotFound
|
|
Right {status} -> pure $
|
|
if status / 100 == 5
|
|
then Retrying fileID MinorServerError
|
|
else IError $ UnknownStatusCodeForImage status
|
|
Left e -> pure $ Retrying fileID $ NetworkError $ message e
|
|
|
|
_fetchImgInner :: String -> ArrayBuffer -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData
|
|
_fetchImgInner fileID nonce format cryptokey = do
|
|
key' <- cryptokey
|
|
case key' of
|
|
Nothing -> pure $ IError BadKey
|
|
Just key -> fetchImageAsBlobUrl nonce format key fileID
|
|
_fetchImg :: ImageData -> ArrayBuffer -> Format.Format -> Aff (Maybe CryptoKey) -> Aff ImageData
|
|
_fetchImg (Retrying fileID _) = _fetchImgInner fileID
|
|
_fetchImg (Unloaded fileID) = _fetchImgInner fileID
|
|
_fetchImg loadedOrError = \_ -> \_ -> \_ -> pure loadedOrError
|
|
|
|
fetchThumb :: Image -> Aff ImageData
|
|
fetchThumb image = _fetchImg image.thumb nonce_b Format.Format_WEBP image.key
|
|
|
|
fetchFull :: Image -> Aff ImageData
|
|
fetchFull image = _fetchImg image.full nonce_a image.format image.key
|
|
|
|
type Parameters =
|
|
{ fileId :: String
|
|
, key :: CryptoKey
|
|
}
|
|
|
|
get_parameters :: Aff (Either GalleryError Parameters)
|
|
get_parameters = do
|
|
urlInfo <- liftEffect do
|
|
window <- HTML.window
|
|
location <- location window
|
|
keyB64 <- drop 1 <$> Location.hash location
|
|
fileId <- drop 1 <$> Location.pathname location
|
|
pure {keyB64, fileId}
|
|
case decodeKey urlInfo.keyB64 of
|
|
Nothing -> pure $ Left MalformedKey
|
|
Just keyBuffer -> do
|
|
cryptoKey <- importKey keyBuffer
|
|
case cryptoKey of
|
|
Left e -> pure $ Left e
|
|
Right cryptoKey' -> pure $ Right {fileId: urlInfo.fileId, key: cryptoKey'}
|
|
|
|
fetch_and_decrypt_gallery :: Parameters -> Aff Model
|
|
fetch_and_decrypt_gallery params = do
|
|
result <- try $ fetch (params.fileId <> ".bin") {}
|
|
case result of
|
|
Right {status: 200, arrayBuffer} -> do
|
|
encryptedIndex <- arrayBuffer
|
|
serializedIndex <- try $ decryptBlob params.key encryptedIndex nonce_a
|
|
case serializedIndex of
|
|
Left _ -> pure $ GError DecryptFailed
|
|
Right serializedIndex' -> do
|
|
liftEffect $ parseIndex serializedIndex'
|
|
Right {status: 404} -> pure $ GError NotFound
|
|
Right {status} ->
|
|
pure $ GError $
|
|
if status / 100 == 5
|
|
then ServerError
|
|
else UnknownStatusCodeForIndex status
|
|
Left _ -> pure $ GError $ TotalNetworkError
|