Prim.hs

{-# LANGUAGE OverloadedStrings #-}
module Haste.Crypto.Prim where
import Haste
import Haste.Foreign
import Haste.Crypto.Types
import Data.Array.Unboxed
import Data.Array.IO
import Data.Word
import Haste.Concurrent

-- | Fill the given array with random bits, using the browser's @window.crypto@
--   object.
randomBits :: ArrView e => IOUArray Word32 e -> IO ()
randomBits = ffi "(function(arr){window['__haste_crypto'].getRandomValues(arr);})"

-- | Wait for a promise to either complete or get rejected. Promises used with
--   this function should not get rejected unless there is a bug in this very
--   library.
--   Promises that may fail for normal reasons should not use this function.
promise :: MonadConc m
        => ((a -> IO ()) -> (JSString -> IO ()) -> IO ())
        -> m a
promise f = liftCIO $ do
  res <- promiseE f
  case res of
    Right x -> return x
    Left e  -> error ("promise rejected: " ++ fromJSStr e)

-- | A promise that might fail.
promiseE :: MonadConc m
        => ((a -> IO ()) -> (JSString -> IO ()) -> IO ())
        -> m (Either JSString a)
promiseE f = liftCIO $ do
  v <- newEmptyMVar
  liftIO $ f (concurrent . putMVar v . Right) (concurrent . putMVar v . Left)
  takeMVar v

generateKey' :: Cipher -> (SymmetricKey -> IO ()) -> (JSString -> IO ()) -> IO ()
generateKey' = ffi "(function(c, yay, nay) {\
  \window['__haste_crypto'].subtle.generateKey(c, true, ['encrypt','decrypt'])\
  \.then(function(k) {yay({key: k, cipher: c});})\
  \.catch(nay);\
  \})"

encrypt' :: (Ix i, ArrView e)
         => SymmetricKey -> IV -> UArray i e
         -> (UArray Word32 Word8 -> IO ())
         -> (JSString -> IO ())
         -> IO ()
encrypt' = ffi "(function(k, iv, data, yay, nay) {\
  \k.cipher.iv = iv;\
  \window['__haste_crypto'].subtle.encrypt(k.cipher, k.key, data)\
  \.then(function(enc){yay(new Uint8Array(enc));})\
  \.catch(nay);\
  \})"

decrypt' :: (Ix i, ArrView e)
         => SymmetricKey -> IV -> UArray i e
         -> (UArray Word32 Word8 -> IO ())
         -> (JSString -> IO ())
         -> IO ()
decrypt' = ffi "(function(k, iv, data, yay, nay) {\
  \k.cipher.iv = iv;\
  \window['__haste_crypto'].subtle.decrypt(k.cipher, k.key, data)\
  \.then(function(dec){yay(new Uint8Array(dec));})\
  \.catch(nay);\
  \})"

keyBytes' :: SymmetricKey
          -> (UArray Word32 Word8 -> IO ())
          -> (JSString -> IO ())
          -> IO ()
keyBytes' = ffi "(function(k, yay, nay){\
  \window['__haste_crypto'].subtle.exportKey('raw', k.key)\
  \.then(function(dec){yay(new Uint8Array(dec));})\
  \.catch(nay);\
  \})"

keyFromBytes' :: Cipher
              -> UArray Word32 Word8
              -> (SymmetricKey -> IO ())
              -> (JSString -> IO ())
              -> IO ()
keyFromBytes' = ffi "(function(alg, k, yay, nay){\
  \window['__haste_crypto'].subtle.importKey('raw', k, alg, true, ['encrypt', 'decrypt'])\
  \.then(function(k) {yay({key: k, cipher: alg});})\
  \.catch(nay);\
  \})"

deriveKey' :: Cipher -> Salt -> Int -> UArray Word32 Word8 -> (Maybe SymmetricKey -> IO ()) -> (JSString -> IO ()) -> IO ()
deriveKey' = ffi "(function(alg, s, n, k, yay, nay){\
  \window['__haste_crypto'].subtle.importKey('raw', k, {name:'PBKDF2'}, false, ['deriveKey']).then(function(mk) {\
  \window['__haste_crypto'].subtle.deriveKey({name:'PBKDF2',salt:s,iterations:n,hash:'SHA-256'}, mk, alg, true, ['encrypt', 'decrypt']).then(function(k){yay({key: k, cipher: alg});}).catch(function(_){yay(null);});\
  \});})"

encodeUtf8' :: JSString -> IO (UArray Word32 Word8)
encodeUtf8' = ffi "(function(s){\
  \s = unescape(encodeURIComponent(s));\
  \var arr = new Uint8Array(s.length);\
  \for(var i = 0 ; i < s.length; ++i) {\
  \  arr[i] = s.charCodeAt(i);\
  \}\
  \return arr;\
  \})"