Add image decryption

spago.dhall

@@ -27,12 +27,14 @@ to generate this file without the comments in this block.
   , "foldable-traversable"
   , "maybe"
   , "newtype"
+  , "parallel"
   , "parsing"
   , "prelude"
   , "protobuf"
   , "strings"
   , "subtlecrypto"
   , "transformers"
+  , "web-file"
   , "web-html"
   ]
 , packages = ./packages.dhall

src/Main.purs

@@ -1,9 +1,11 @@
 module Main where
 
 import Prelude
-import AviaryFormat.Format (Format, Image, Index, parseIndex) as Format
+import AviaryFormat.Format (Format(..), Image, Index, parseIndex) as Format
+import Aviary.FFI (arrayBufferToBlob)
 
 import Control.Monad.Error.Class (try)
+import Control.Parallel (parTraverse)
 import Effect (Effect)
 import Effect.Aff (Aff, launchAff)
 import Effect.Class (liftEffect)
@@ -16,15 +18,15 @@ 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 (DataBuff, execPut, putDataBuff, putInt8)
-import Data.ArrayBuffer.Builder.Internal (toView)
+import Data.ArrayBuffer.DataView (whole)
-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.File.Url (createObjectURL)
 import Web.HTML (window) as HTML
 import Web.HTML.Window (location)
 import Web.HTML.Location (hash, origin, pathname) as Location
@@ -38,12 +40,19 @@ 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]
 
+databuffToBuffer :: DataBuff -> Effect ArrayBuffer
+databuffToBuffer = execPut <<< putDataBuff
+
 data AviaryError
-    = MalformedKey
+    = ServerError
+    | UnexpectedStatusCode Int
+    | MalformedKey
     | MalformedUrl
     | DecryptFailed
+    | ImageDecryptFailed
     | StrangeIndex
     | IndexMissingField String
+    | ImageNotFound
 
 type Image =
     { key :: Aff CryptoKey
@@ -60,11 +69,15 @@ type Index =
     }
 
 instance showAviaryError :: Show AviaryError where
+    show ServerError = "The server encountered an error"
     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 ImageDecryptFailed = "The decryption of the album's index succeeded, but it contained a reference to an image whose decryption failed.  This likely indicates expiration"
     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."
+    show ImageNotFound = "The image was not found, likely indicating that it expired"
+    show (UnexpectedStatusCode status) = "Server returned an unexpected status code: " <> (show status)
 
 type UrlInfo =
     { server :: String
@@ -72,6 +85,13 @@ type UrlInfo =
     , key :: String
     }
 
+formatToMime :: Format.Format -> String
+formatToMime Format.Format_WEBP = "image/webp"
+formatToMime Format.Format_AVIF = "image/avif"
+formatToMime Format.Format_JPG = "image/jpeg"
+formatToMime Format.Format_PNG = "image/png"
+formatToMime Format.Format_GIF = "image/gif"
+
 parseUrl :: String -> Either AviaryError UrlInfo
 parseUrl url = note MalformedUrl do
     slashIndex <- indexOf' (Pattern "/") 8 url
@@ -99,7 +119,7 @@ convertImageFromProtobuf protoimage = let protoimage' = unwrap protoimage in do
     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]
+    let key = importKey =<< liftEffect (databuffToBuffer $ unwrap rawKey)
     pure { key, fullUrl, thumbUrl, blurhash, format }
 
 convertIndexFromProtobuf :: Format.Index -> Either AviaryError Index
@@ -119,8 +139,25 @@ convertIndexFromProtobuf protoindex =
 parseIndex :: ArrayBuffer -> Effect (Either AviaryError Index)
 parseIndex rawData = do
     parseResult <- runParserT (whole rawData) (Format.parseIndex (byteLength rawData))
+    _ <- liftEffect $ log $ show (parseResult)
     pure $ convertIndexFromProtobuf =<< (note StrangeIndex $ hush parseResult)
 
+fetchImageAsBlobUrl :: ArrayBuffer -> Image -> Aff (Either AviaryError String)
+fetchImageAsBlobUrl nonce image = do
+    cryptoKey <- image.key
+    { status, arrayBuffer } <- fetch (image.fullUrl <> ".bin") {}
+    case status of
+        200 -> do
+            encryptedImage <- arrayBuffer
+            decryptedImage <- try $ decryptBlob cryptoKey encryptedImage nonce
+            case decryptedImage of
+                Left _ -> pure $ Left ImageDecryptFailed
+                Right rawImage -> do
+                    url <- liftEffect $ createObjectURL $ (arrayBufferToBlob $ formatToMime image.format) rawImage
+                    pure $ Right url
+        404 -> pure $ Left ImageNotFound
+        s -> pure $ Left $ if s / 100 == 5 then ServerError else UnexpectedStatusCode s
+
 main_aff :: Aff Unit
 main_aff = do
     urlInfo <- liftEffect do
@@ -143,10 +180,11 @@ main_aff = do
                     _ <- liftEffect $ log $ message err
                     pure $ Left $ DecryptFailed
                 Right serializedIndex' -> do
-                    _ <- liftEffect $ log "BBBBBBBBB!"
+                    liftEffect $ parseIndex serializedIndex'
-                    maybeIndex <- liftEffect $ parseIndex serializedIndex'
+    maybeUrls <- case maybeIndex of
-                    pure ((\i -> i.title) <$> maybeIndex)
+        Left err -> pure $ Left err
-    liftEffect $ log $ show maybeIndex
+        Right index -> Right <$> parTraverse (fetchImageAsBlobUrl urlInfo.nonce) index.images
+    liftEffect $ log $ show maybeUrls
 
 main :: Effect Unit
 main = launchAff main_aff $> unit