aviary-ps/src/Main.purs

module Main where

import Prelude
import AviaryFormat.Format (Format, Image, Index, parseIndex) as Format

import Control.Monad.Error.Class (try)
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.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.ArrayBuffer.ArrayBuffer (byteLength)
import Data.ArrayBuffer.Builder (execPut, putInt8)
import Data.ArrayBuffer.Builder.Internal (toView)
import Data.ArrayBuffer.DataView (buffer, 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 Parsing (runParserT)
import Web.HTML (window) as HTML
import Web.HTML.Window (location)
import Web.HTML.Location (hash, origin, 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)

nonceE :: Effect ArrayBuffer
nonceE = execPut $ traverse_ putInt8 [0xd0, 0xc3, 0x75, 0x56, 0x58, 0xc1, 0x7e, 0x5f, 0xd6, 0xcc, 0xb6, 0x76]

data AviaryError
    = MalformedKey
    | MalformedUrl
    | DecryptFailed
    | StrangeIndex
    | IndexMissingField String

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

type UrlInfo =
    { server :: String
    , fileId :: String
    , key :: String
    }

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

importKey :: ArrayBuffer -> Aff CryptoKey
importKey key =
    SC.importKey raw key (aes aesGCM) false [decrypt]

decryptBlob :: CryptoKey -> ArrayBuffer -> ArrayBuffer -> Aff ArrayBuffer
decryptBlob key cyphertext nonce =
    -- nonce <- makeAff (\_ -> nonceE)
    Alg.decrypt (Alg.aesGCM nonce Nothing (Just t128)) key cyphertext

convertImageFromProtobuf :: Format.Image -> Either AviaryError 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
    format <- note (IndexMissingField "images[].format") protoimage'.format
    let key = SC.importKey raw (buffer $ toView $ unwrap rawKey) (aes aesGCM) false [decrypt]
    pure { key, fullUrl, thumbUrl, blurhash, format }

convertIndexFromProtobuf :: Format.Index -> Either AviaryError Index
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

parseIndex :: ArrayBuffer -> Effect (Either AviaryError Index)
parseIndex rawData = do
    parseResult <- runParserT (whole rawData) (Format.parseIndex (byteLength rawData))
    pure $ convertIndexFromProtobuf =<< (note StrangeIndex $ hush parseResult)

main_aff :: Aff Unit
main_aff = do
    urlInfo <- liftEffect do
        window <- HTML.window
        location <- location window
        keyB64 <- drop 1 <$> Location.hash location
        server <- Location.origin location
        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
            cryptoKey <- importKey keyBuffer
            { status, arrayBuffer } <- fetch (urlInfo.server <> "/" <> urlInfo.fileId <> ".bin") {}
            encryptedIndex <- arrayBuffer
            serializedIndex <- try $ decryptBlob cryptoKey encryptedIndex urlInfo.nonce
            case serializedIndex of
                Left err -> do
                    _ <- liftEffect $ log $ message err
                    pure $ Left $ DecryptFailed
                Right serializedIndex' -> do
                    _ <- liftEffect $ log "BBBBBBBBB!"
                    maybeIndex <- liftEffect $ parseIndex serializedIndex'
                    pure ((\i -> i.title) <$> maybeIndex)
    liftEffect $ log $ show maybeIndex

main :: Effect Unit
main = launchAff main_aff $> unit