aviary-ps/src/Logic.purs

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