diff --git a/src/Logic.purs b/src/Logic.purs new file mode 100644 index 0000000..41f735a --- /dev/null +++ b/src/Logic.purs @@ -0,0 +1,122 @@ +module Aviary.Logic where + +import Prelude +import AviaryFormat.Format (Format, Image, Index, parseIndex) as Format +import Aviary.FFI (arrayBufferToBlob) +import Aviary.Model (formatToMime, GalleryError(..), Image, ImageData(..), ImageError(..), Model(..)) + +import Control.Monad.Error.Class (try) +import Effect (Effect) +import Effect.Aff (Aff) +import Effect.Class (liftEffect) +import Fetch (fetch) +import Data.Array (head) +import Data.Base64 (decodeBase64, fromString) +import Data.Either (Either(..), note) +import Data.Maybe (Maybe(..)) +import Data.Newtype (unwrap) +import Data.ArrayBuffer.ArrayBuffer (byteLength) +import Data.ArrayBuffer.Builder (DataBuff, execPut, putDataBuff, putInt8) +import Data.ArrayBuffer.DataView (whole) +import Data.ArrayBuffer.Types (ArrayBuffer) +import Data.Filterable (partitionMap) +import Data.Foldable (traverse_) +import Data.String (drop) +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 + +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] + +databuffToBuffer :: DataBuff -> Effect ArrayBuffer +databuffToBuffer = execPut <<< putDataBuff + +decodeKey :: String -> Maybe ArrayBuffer +decodeKey key = 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 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 + format <- note (IndexMissingField "images[].format") protoimage'.format + let key = importKey =<< liftEffect (databuffToBuffer $ unwrap rawKey) + let thumb = Unloaded thumbUrl + let full = Unloaded fullUrl + pure { key, blurhash, format, thumb, full } + +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 protoindex'.title protoindex'.desc images + 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 + { status, arrayBuffer } <- fetch (fileID <> ".bin") {} + case status of + 200 -> 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 + 404 -> pure $ IError ImageNotFound + s -> pure $ IError $ if s / 100 == 5 then MinorServerError else UnknownStatusCodeForImage s + +fetch_gallery_from_page_info :: Aff Model +fetch_gallery_from_page_info = 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} + case decodeKey urlInfo.keyB64 of + Nothing -> pure $ GError MalformedKey + Just keyBuffer -> do + cryptoKey <- importKey keyBuffer + { status, arrayBuffer } <- fetch (urlInfo.server <> "/" <> urlInfo.fileId <> ".bin") {} + case status of + 200 -> do + encryptedIndex <- arrayBuffer + serializedIndex <- try $ decryptBlob cryptoKey encryptedIndex urlInfo.nonce + case serializedIndex of + Left _ -> pure $ GError DecryptFailed + Right serializedIndex' -> do + liftEffect $ parseIndex serializedIndex' + 404 -> pure $ GError NotFound + s -> pure $ GError $ if s / 100 == 5 then ServerError else UnknownStatusCodeForIndex s diff --git a/src/Main.purs b/src/Main.purs index c40067a..3eb5522 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -1,130 +1,18 @@ module Main where import Prelude -import AviaryFormat.Format (Format, Image, Index, parseIndex) as Format -import Aviary.FFI (arrayBufferToBlob) -import Aviary.Model (formatToMime, GalleryError(..), Image, ImageData(..), ImageError(..), Model(..)) import Aviary.UI (component) +import Aviary.Logic (fetch_gallery_from_page_info) -import Control.Monad.Error.Class (try) import Effect (Effect) import Effect.Aff (Aff, launchAff) -import Effect.Class (liftEffect) -import Effect.Console (log) -import Fetch (fetch) -import Data.Array (head) -import Data.Base64 (decodeBase64, fromString) -import Data.Either (Either(..), note) -import Data.Maybe (Maybe(..)) -import Data.Newtype (unwrap) -import Data.ArrayBuffer.ArrayBuffer (byteLength) -import Data.ArrayBuffer.Builder (DataBuff, execPut, putDataBuff, putInt8) -import Data.ArrayBuffer.DataView (whole) -import Data.ArrayBuffer.Types (ArrayBuffer) -import Data.Filterable (partitionMap) -import Data.Foldable (traverse_) -import Data.String (drop) import Halogen.Aff (awaitBody) import Halogen.VDom.Driver (runUI) -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 - -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] - -databuffToBuffer :: DataBuff -> Effect ArrayBuffer -databuffToBuffer = execPut <<< putDataBuff - -decodeKey :: String -> Maybe ArrayBuffer -decodeKey key = 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 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 - format <- note (IndexMissingField "images[].format") protoimage'.format - let key = importKey =<< liftEffect (databuffToBuffer $ unwrap rawKey) - let thumb = Unloaded thumbUrl - let full = Unloaded fullUrl - pure { key, blurhash, format, thumb, full } - -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 protoindex'.title protoindex'.desc images - 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 - { status, arrayBuffer } <- fetch (fileID <> ".bin") {} - case status of - 200 -> 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 - 404 -> pure $ IError ImageNotFound - s -> pure $ IError $ if s / 100 == 5 then MinorServerError else UnknownStatusCodeForImage s main_aff :: Aff Unit main_aff = do body <- awaitBody - 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} - gallery <- case decodeKey urlInfo.keyB64 of - Nothing -> pure $ GError MalformedKey - Just keyBuffer -> do - cryptoKey <- importKey keyBuffer - { status, arrayBuffer } <- fetch (urlInfo.server <> "/" <> urlInfo.fileId <> ".bin") {} - case status of - 200 -> do - encryptedIndex <- arrayBuffer - serializedIndex <- try $ decryptBlob cryptoKey encryptedIndex urlInfo.nonce - case serializedIndex of - Left _ -> pure $ GError DecryptFailed - Right serializedIndex' -> do - liftEffect $ parseIndex serializedIndex' - 404 -> pure $ GError NotFound - s -> pure $ GError $ if s / 100 == 5 then ServerError else UnknownStatusCodeForIndex s + gallery <- fetch_gallery_from_page_info _ <- runUI (component gallery) unit body pure unit