Merge pull request #1712 from unisonweb/topic/basic-hashing

Cryptographic primitives for hashing and HMAC

parser-typechecker/src/Unison/Builtin.hs

@@ -162,6 +162,7 @@ builtinTypesSrc =
   , B' "Socket" CT.Data, Rename' "Socket" "io2.Socket"
   , B' "ThreadId" CT.Data, Rename' "ThreadId" "io2.ThreadId"
   , B' "MVar" CT.Data, Rename' "MVar" "io2.MVar"
+  , B' "crypto.HashAlgorithm" CT.Data
   ]
 
 -- rename these to "builtin" later, when builtin means intrinsic as opposed to
@@ -384,6 +385,24 @@ builtinsSrc =
   , B "Bytes.size" $ bytes --> nat
   , B "Bytes.flatten" $ bytes --> bytes
 
+   {- These are all `Bytes -> Bytes`, rather than `Bytes -> Text`.
+      This is intentional: it avoids a round trip to `Text` if all
+      you are doing with the bytes is dumping them to a file or a
+      network socket.
+
+      You can always `Text.tryFromUtf8` the results of these functions
+      to get some `Text`.
+    -}
+  , B "Bytes.toBase16" $ bytes --> bytes
+  , B "Bytes.toBase32" $ bytes --> bytes
+  , B "Bytes.toBase64" $ bytes --> bytes
+  , B "Bytes.toBase64UrlUnpadded" $ bytes --> bytes
+
+  , B "Bytes.fromBase16" $ bytes --> eithert text bytes
+  , B "Bytes.fromBase32" $ bytes --> eithert text bytes
+  , B "Bytes.fromBase64" $ bytes --> eithert text bytes
+  , B "Bytes.fromBase64UrlUnpadded" $ bytes --> eithert text bytes
+
   , B "List.empty" $ forall1 "a" list
   , B "List.cons" $ forall1 "a" (\a -> a --> list a --> list a)
   , Alias "List.cons" "List.+:"
@@ -405,10 +424,24 @@ builtinsSrc =
                   ,("<=", "lteq")
                   ,(">" , "gt")
                   ,(">=", "gteq")]
-  ] ++ io2List ioBuiltins ++ io2List mvarBuiltins
-
-io2List :: [(Text, Type v)] -> [BuiltinDSL v]
-io2List bs = bs >>= \(n,ty) -> [B n ty, Rename n ("io2." <> n)]
+  ] ++ moveUnder "io2" ioBuiltins
+    ++ moveUnder "io2" mvarBuiltins
+    ++ hashBuiltins
+
+moveUnder :: Text -> [(Text, Type v)] -> [BuiltinDSL v]
+moveUnder prefix bs = bs >>= \(n,ty) -> [B n ty, Rename n (prefix <> "." <> n)]
+
+hashBuiltins :: Var v => [BuiltinDSL v]
+hashBuiltins =
+  [ B "crypto.hash" $ forall1 "a" (\a -> hashAlgo --> a --> bytes)
+  , B "crypto.hashBytes" $ hashAlgo --> bytes --> bytes
+  , B "crypto.hmac" $ forall1 "a" (\a -> hashAlgo --> bytes --> a --> bytes)
+  , B "crypto.hmacBytes" $ hashAlgo --> bytes --> bytes --> bytes
+  ] ++
+  map h [ "Sha3_512", "Sha3_256", "Sha2_512", "Sha2_256", "Blake2b_512", "Blake2b_256", "Blake2s_256" ]
+  where
+  hashAlgo = Type.ref() Type.hashAlgorithmRef
+  h name = B ("crypto.HashAlgorithm."<>name) $ hashAlgo
 
 ioBuiltins :: Var v => [(Text, Type v)]
 ioBuiltins =
@@ -496,9 +529,10 @@ infixr -->
 
 io, ioe :: Var v => Type v -> Type v
 io = Type.effect1 () (Type.builtinIO ())
-ioe = io . either (DD.ioErrorType ())
-  where
-  either l r = DD.eitherType () `app` l `app` r
+ioe = io . eithert (DD.ioErrorType ())
+
+eithert :: Var v => Type v -> Type v -> Type v
+eithert l r = DD.eitherType () `app` l `app` r
 
 socket, threadId, handle, unit :: Var v => Type v
 socket = Type.socket ()
@@ -520,3 +554,4 @@ text = Type.text ()
 boolean = Type.boolean ()
 float = Type.float ()
 char = Type.char ()
+

parser-typechecker/src/Unison/Runtime/Builtin.hs

@@ -28,15 +28,19 @@ import Unison.Symbol
 import Unison.Runtime.Stack (Closure)
 import Unison.Runtime.Foreign.Function
 import Unison.Runtime.IOSource
+import Unison.Runtime.Foreign (HashAlgorithm(..))
 
 import qualified Unison.Type as Ty
 import qualified Unison.Builtin as Ty (builtinTypes)
 import qualified Unison.Builtin.Decls as Ty
+import qualified Crypto.Hash as Hash
+import qualified Crypto.MAC.HMAC as HMAC
 
 import Unison.Util.EnumContainers as EC
 
 import Data.Word (Word64)
 import Data.Text as Text (Text, unpack)
+import qualified Data.ByteArray as BA
 
 import Data.Set (Set, insert)
 
@@ -1104,6 +1108,50 @@ mvar'try'read instr
   where
   [mv,t,r] = freshes 3
 
+-- Pure ForeignOp taking two boxed values
+pfopbb :: ForeignOp
+pfopbb instr
+  = ([BX,BX],)
+  . TAbss [b1,b2]
+  $ TFOp instr [b1,b2]
+  where
+  [b1,b2] = freshes 2
+
+pfopbbb :: ForeignOp
+pfopbbb instr
+  = ([BX,BX,BX],)
+  . TAbss [b1,b2,b3]
+  $ TFOp instr [b1,b2,b3]
+  where
+  [b1,b2,b3] = freshes 3
+
+-- Pure ForeignOp taking no values
+pfop0 :: ForeignOp
+pfop0 instr = ([],) $ TFOp instr []
+
+-- Pure ForeignOp taking 1 boxed value and returning 1 boxed value
+pfopb :: ForeignOp
+pfopb instr
+  = ([BX],)
+  . TAbss [b]
+  $ TFOp instr [b]
+  where
+  [b] = freshes 1
+
+-- Pure ForeignOp taking 1 boxed value and returning 1 Either, both sides boxed
+pfopb_ebb :: ForeignOp
+pfopb_ebb instr
+  = ([BX],)
+  . TAbss [b]
+  . TLet e UN (AFOp instr [b])
+  . TMatch e . MatchSum
+  $ mapFromList
+  [ (0, ([BX], TAbs ev $ TCon eitherReference 0 [ev]))
+  , (1, ([BX], TAbs ev $ TCon eitherReference 1 [ev]))
+  ]
+  where
+  [e,b,ev] = freshes 3
+
 builtinLookup :: Var v => Map.Map Reference (SuperNormal v)
 builtinLookup
   = Map.fromList
@@ -1354,10 +1402,10 @@ declareForeigns = do
   declareForeign "IO.socketAccept" socket'accept
     . mkForeignIOE $ void . SYS.accept
   declareForeign "IO.socketSend" socket'send
-    . mkForeignIOE $ \(sk,bs) -> SYS.send sk (Bytes.toByteString bs)
+    . mkForeignIOE $ \(sk,bs) -> SYS.send sk (Bytes.toArray bs)
   declareForeign "IO.socketReceive" socket'receive
     . mkForeignIOE $ \(hs,n) ->
-        fmap Bytes.fromByteString <$> SYS.recv hs n
+        fmap Bytes.fromArray <$> SYS.recv hs n
   declareForeign "IO.kill" kill'thread $ mkForeignIOE killThread
   declareForeign "IO.delay" delay'thread $ mkForeignIOE threadDelay
   declareForeign "IO.stdHandle" standard'handle
@@ -1388,6 +1436,46 @@ declareForeigns = do
   declareForeign "MVar.tryRead" mvar'try'read
     . mkForeign $ \(mv :: MVar Closure) -> tryReadMVar mv
 
+  -- Hashing functions
+  let declareHashAlgorithm :: forall v alg . Var v => Hash.HashAlgorithm alg => Text -> alg -> FDecl v ()
+      declareHashAlgorithm txt alg = do
+        let algoRef = Builtin ("crypto.HashAlgorithm." <> txt)
+        declareForeign ("crypto.HashAlgorithm." <> txt) pfop0 . mkForeign $ \() ->
+          pure (HashAlgorithm algoRef alg)
+
+  declareHashAlgorithm "Sha3_512" Hash.SHA3_512
+  declareHashAlgorithm "Sha3_256" Hash.SHA3_256
+  declareHashAlgorithm "Sha2_512" Hash.SHA512
+  declareHashAlgorithm "Sha2_256" Hash.SHA256
+  declareHashAlgorithm "Blake2b_512" Hash.Blake2b_512
+  declareHashAlgorithm "Blake2b_256" Hash.Blake2b_256
+  declareHashAlgorithm "Blake2s_256" Hash.Blake2s_256
+
+  -- declareForeign ("crypto.hash") pfopbb . mkForeign $ \(HashAlgorithm _ref _alg, _a :: Closure) ->
+  --   pure $ Bytes.empty -- todo : implement me
+
+  declareForeign "crypto.hashBytes" pfopbb . mkForeign $
+    \(HashAlgorithm _ alg, b :: Bytes.Bytes) ->
+        let ctx = Hash.hashInitWith alg
+        in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.chunks b)
+
+  declareForeign "crypto.hmacBytes" pfopbbb
+    . mkForeign $ \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) ->
+        let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg)
+            u :: a -> HMAC.HMAC a -> HMAC.HMAC a
+            u _ h = h -- to help typechecker along
+        in pure $ Bytes.fromArray out
+
+  declareForeign "Bytes.toBase16" pfopb . mkForeign $ pure . Bytes.toBase16
+  declareForeign "Bytes.toBase32" pfopb . mkForeign $ pure . Bytes.toBase32
+  declareForeign "Bytes.toBase64" pfopb . mkForeign $ pure . Bytes.toBase64
+  declareForeign "Bytes.toBase64UrlUnpadded" pfopb . mkForeign $ pure . Bytes.toBase64UrlUnpadded
+
+  declareForeign "Bytes.fromBase16" pfopb_ebb . mkForeign $ pure . Bytes.fromBase16
+  declareForeign "Bytes.fromBase32" pfopb_ebb . mkForeign $ pure . Bytes.fromBase32
+  declareForeign "Bytes.fromBase64" pfopb_ebb . mkForeign $ pure . Bytes.fromBase64
+  declareForeign "Bytes.fromBase64UrlUnpadded" pfopb . mkForeign $ pure . Bytes.fromBase64UrlUnpadded
+
 hostPreference :: Maybe Text -> SYS.HostPreference
 hostPreference Nothing = SYS.HostAny
 hostPreference (Just host) = SYS.Host $ Text.unpack host

parser-typechecker/src/Unison/Runtime/Decompile.hs

@@ -1,20 +1,18 @@
 {-# language PatternGuards #-}
 {-# language TupleSections #-}
 {-# language PatternSynonyms #-}
+{-# language OverloadedStrings #-}
 
 module Unison.Runtime.Decompile
   ( decompile ) where
 
 import Prelude hiding (seq)
-
-import Data.String (fromString)
-import Data.Sequence (Seq)
-import Data.Word (Word64)
+import Unison.Prelude
 
 import Unison.ABT (absChain, substs, pattern AbsN')
 import Unison.Term
   ( Term
-  , nat, int, char, float, boolean, constructor, app, apps', text
+  , nat, int, char, float, boolean, constructor, app, apps', text, ref
   , seq, seq', builtin
   )
 import Unison.Type
@@ -24,7 +22,7 @@ import Unison.Var (Var)
 import Unison.Reference (Reference)
 
 import Unison.Runtime.Foreign
-  (Foreign, maybeUnwrapBuiltin, maybeUnwrapForeign)
+  (Foreign, HashAlgorithm(..), maybeUnwrapBuiltin, maybeUnwrapForeign)
 import Unison.Runtime.Stack
   (Closure(..), pattern DataC, pattern PApV, CombIx(..))
 
@@ -102,6 +100,7 @@ decompileForeign
 decompileForeign topTerms f
   | Just t <- maybeUnwrapBuiltin f = Right $ text () t
   | Just b <- maybeUnwrapBuiltin f = Right $ decompileBytes b
+  | Just h <- maybeUnwrapBuiltin f = Right $ decompileHashAlgorithm h
   | Just s <- unwrapSeq f
   = seq' () <$> traverse (decompile topTerms) s
 decompileForeign _ _ = err "cannot decompile Foreign"
@@ -111,5 +110,8 @@ decompileBytes
   = app () (builtin () $ fromString "Bytes.fromList")
   . seq () . fmap (nat () . fromIntegral) . By.toWord8s
 
+decompileHashAlgorithm :: Var v => HashAlgorithm -> Term v ()
+decompileHashAlgorithm (HashAlgorithm r _) = ref () r
+
 unwrapSeq :: Foreign -> Maybe (Seq Closure)
 unwrapSeq = maybeUnwrapForeign vectorRef

parser-typechecker/src/Unison/Runtime/Foreign.hs

@@ -5,6 +5,7 @@
 
 module Unison.Runtime.Foreign
   ( Foreign(..)
+  , HashAlgorithm(..)
   , unwrapForeign
   , maybeUnwrapForeign
   , wrapBuiltin
@@ -22,7 +23,7 @@ import Unison.Util.Bytes (Bytes)
 import Unison.Reference (Reference)
 import Unison.Referent (Referent)
 import qualified Unison.Type as Ty
-
+import qualified Crypto.Hash as Hash
 import Unsafe.Coerce
 
 data Foreign where
@@ -43,6 +44,7 @@ ref2cmp r
   | r == Ty.textRef = Just $ promote (compare @Text)
   | r == Ty.termLinkRef = Just $ promote (compare @Referent)
   | r == Ty.typeLinkRef = Just $ promote (compare @Reference)
+  | r == Ty.bytesRef = Just $ promote (compare @Bytes)
   | otherwise = Nothing
 
 instance Eq Foreign where
@@ -53,7 +55,9 @@ instance Eq Foreign where
 instance Ord Foreign where
   Wrap rl t `compare` Wrap rr u
     | rl == rr, Just cmp <- ref2cmp rl = cmp t u
-  compare _ _ = error "Ord Foreign"
+  compare (Wrap rl1 _) (Wrap rl2 _) =
+    error $ "Attempting to compare two values of different types: "
+         <> show (rl1, rl2)
 
 instance Show Foreign where
   showsPrec p !(Wrap r _)
@@ -77,6 +81,12 @@ instance BuiltinForeign Handle where foreignRef = Tagged Ty.fileHandleRef
 instance BuiltinForeign Socket where foreignRef = Tagged Ty.socketRef
 instance BuiltinForeign ThreadId where foreignRef = Tagged Ty.threadIdRef
 
+data HashAlgorithm where
+  -- Reference is a reference to the hash algorithm
+  HashAlgorithm :: Hash.HashAlgorithm a => Reference -> a -> HashAlgorithm
+
+instance BuiltinForeign HashAlgorithm where foreignRef = Tagged Ty.hashAlgorithmRef
+
 wrapBuiltin :: forall f. BuiltinForeign f => f -> Foreign
 wrapBuiltin x = Wrap r x
   where

parser-typechecker/src/Unison/Runtime/Foreign/Function.hs

@@ -2,6 +2,7 @@
 {-# language DataKinds #-}
 {-# language ViewPatterns #-}
 {-# language RecordWildCards #-}
+{-# language UndecidableInstances #-}
 
 module Unison.Runtime.Foreign.Function
   ( ForeignFunc(..)
@@ -295,6 +296,10 @@ instance ForeignConvention (MVar Closure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap mvarRef)
 
+instance {-# overlappable #-} BuiltinForeign b => ForeignConvention b where
+  readForeign = readForeignBuiltin
+  writeForeign = writeForeignBuiltin
+
 instance {-# overlappable #-} BuiltinForeign b => ForeignConvention [b]
   where
   readForeign us (i:bs) _ bstk

parser-typechecker/src/Unison/Runtime/Rt1.hs

@@ -299,7 +299,7 @@ builtinCompilationEnv = CompilationEnv (builtinsMap <> IR.builtins) mempty
     , mk1 "List.size"  ats (pure . N) (fromIntegral . Sequence.length)
 
     , mk1 "Bytes.fromList" ats (pure . Bs) (\s ->
-        Bytes.fromByteString (BS.pack [ fromIntegral n | N n <- toList s]))
+        Bytes.fromArray (BS.pack [ fromIntegral n | N n <- toList s]))
     , mk2 "Bytes.++"  atbs atbs (pure . Bs) (<>)
     , mk2 "Bytes.take" atn atbs (pure . Bs) (\n b -> Bytes.take (fromIntegral n) b)
     , mk2 "Bytes.drop" atn atbs (pure . Bs) (\n b -> Bytes.drop (fromIntegral n) b)

parser-typechecker/src/Unison/Runtime/Rt1IO.hs

@@ -400,12 +400,12 @@ handleIO cenv cid = go (IOSrc.constructorName IOSrc.ioReference cid)
     newUnisonSocket $ fst conn
   go "io.IO.send_" [IR.Data _ _ [IR.T socket], IR.Bs bs] = do
     hs <- getHaskellSocketOrThrow socket
-    reraiseIO . Net.send hs $ Bytes.toByteString bs
+    reraiseIO . Net.send hs $ Bytes.toArray bs
     pure IR.unit
   go "io.IO.receive_" [IR.Data _ _ [IR.T socket], IR.N n] = do
     hs <- getHaskellSocketOrThrow socket
     bs <- reraiseIO . Net.recv hs $ fromIntegral n
-    pure . convertMaybe $ IR.Bs . Bytes.fromByteString <$> bs
+    pure . convertMaybe $ IR.Bs . Bytes.fromArray <$> bs
   go "io.IO.fork_" [IR.Lam _ _ ir] = do
     s    <- ask
     t    <- liftIO genText