Move a lot of code into a seperate Logic module
This commit is contained in:
parent
4ab1bcdbc1
commit
111bebf0de
GPG key ID:
A12F2C2FFDC3D847
122
src/Logic.purs
Normal file
122
src/Logic.purs
Normal file
|
|
@ -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
|
||||
116
src/Main.purs
116
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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue