SHA-1 in pure R / attendant unsigned int32 and bitwise operation

sha1.R

library(methods)

# bitwise operation
Bit32 <- setRefClass("bit32",
  methods = list(
    rotate = function(a,s) {
      ior(shift(a,s),shift(a,-(32-s)))
    },
    shift = function(a,shift) {
      if(class(a) != "uint32") a <- UInt32$new(a)
      if(shift == 0) return(a)
      signshift <- sign(shift)
      shift <- abs(shift)
      se <- ifelse(signshift > c(0,0),c(0,shift),c(shift,0))
      bits <- c(rep(F,se[2]),a$bits[(1+se[1]):(32-se[2])],rep(F,se[1]))
      byte <- packBits(bits)
      num <- sum(as.integer(byte) * 2^(c(0,8,16,24)))
      return(UInt32$new(num,obyte=byte,obits=bits))
    },
    not = function(a) {
      if(class(a) != "uint32") a <- UInt32$new(a)
      bits <- (!as.logical(a$bits))
      #byte <- packBits(bits)
      byte <- !a$byte
      num <- sum(as.integer(byte) * 2^(c(0,8,16,24)))
      return(UInt32$new(num,byte,bits))
    },
    xor = function(a,b) {
      if(class(a) != "uint32") a <- UInt32$new(a)
      if(class(b) != "uint32") b <- UInt32$new(b)
      bits <- base::xor(a$bits , b$bits)
      #byte <- packBits(bits)
      byte <- base::xor(a$byte , b$byte)
      num <- sum(as.integer(byte) * 2^(c(0,8,16,24)))
      return(UInt32$new(num,byte,bits))
    },
    ior = function(a,b) {
      if(class(a) != "uint32") a <- UInt32$new(a)
      if(class(b) != "uint32") b <- UInt32$new(b)
      bits <- a$bits | b$bits
      #byte <- packBits(bits)
      byte <- a$byte | b$byte
      num <- sum(as.integer(byte) * 2^(c(0,8,16,24)))
      return(UInt32$new(num,byte,bits))
    },
    and = function(a,b) {
      if(class(a) != "uint32") a <- UInt32$new(a)
      if(class(b) != "uint32") b <- UInt32$new(b)
      bits <- a$bits & b$bits
      #byte <- packBits(bits)
      byte <- a$byte & b$byte
      num <- sum(as.integer(byte) * 2^(c(0,8,16,24)))
      return(UInt32$new(num,byte,bits))
    }
  )
)
# unsigned int32 
# byte : 4-length raw
# bits : 32-length bit (bit is 0/1 raw)
# num  : fractional part of double (as 52bit integer)
UInt32 <- setRefClass("uint32",
  fields  = list(
    byte = "raw",
    bits = "logical",
    num  = "numeric"
  ),
  methods = list(
    initialize = function(num=0,obyte=NA,obits=NA) {
      if((!is.na(obyte) && !is.na(obits))){
        bits <<- obits
        byte <<- obyte
        if(num > 0){
          num  <<- num
        } else {
          num <<- sum(as.integer(byte) * 2^(c(0,8,16,24)))
        }
      } else if(num < .Machine$integer.max) {
        bits <<- as.logical(intToBits(num))
        byte <<- packBits(bits)
        num  <<- num
      } else if(num < (.Machine$integer.max+1)*2) {
        lsword <- num %%  2^16
        msword <- num %/% 2^16
        bits[32:17] <<- as.logical(intToBits(msword)[16:1])
        bits[16:1] <<-  as.logical(intToBits(lsword)[16:1])
        byte <<-  packBits(bits)
        num <<- num
      } else {
        stop(sprintf("%g is out of range",num))
      }
      return(.self)
    }
  )
)
# Add(a,b) := a + b (mod UINT32_MAX+1)
`+.uint32` <- function(a,b) {
  added <- (a$num + b$num) %% 2^32
  UInt32$new(added)
}

# bitwise operator
bit32 <- Bit32$new()

# sha-1 function
f00 <- function(B,C,D) {
  return(bit32$ior(bit32$and(B , C) , bit32$and(bit32$not(B), D)))
}
f20 <- function(B,C,D) {
  return(Reduce(bit32$xor,c(B,C,D)))
}
f40 <- function(B,C,D) {
  return(Reduce(bit32$ior,c(bit32$and(B,C),bit32$and(B,D),bit32$and(C,D))))
}
f <- c(f00,f20,f40,f20)

# sha-1 constant
K <- sapply(c(
  0x5A827999,
  0x6ED9EBA1,
  0x8F1BBCDC,
  0xCA62C1D6
),UInt32$new)

# sha-1 class
SHA1 <- setRefClass("sha1",
  fields = list(
    H0  = "uint32"
    ,H1 = "uint32"
    ,H2 = "uint32"
    ,H3 = "uint32"
    ,H4 = "uint32"
    ,message = "raw"
  ),
  methods = list(
    initialize = function() {
      .self$reset()
    },
    reset = function() {
      message <<- as.raw(c())
      H0 <<- UInt32$new(0x67452301)
      H1 <<- UInt32$new(0xEFCDAB89)
      H2 <<- UInt32$new(0x98BADCFE)
      H3 <<- UInt32$new(0x10325476)
      H4 <<- UInt32$new(0xC3D2E1F0)
    },
    digest = function() {
      masterblock <- expand(message)
      for(idx in 1:(length(masterblock)%/%64)) {
        A <- H0
        B <- H1
        C <- H2
        D <- H3
        E <- H4
        block <- masterblock[(1:64)+(64*(idx-1))]

        calcBlock <- function(i,n) {
          intToBits(block[i*4+n])[1:8]
        }
        W <- list()
        length(W) <- 80
        for(i in 0:17) {
          bits <- as.logical(c(calcBlock(i,4),calcBlock(i,3),calcBlock(i,2),calcBlock(i,1)))
          byte <- packBits(bits)
          W[[i+1]] <- UInt32$new(obits=bits,obyte=byte)
        }
        for(i in 17:80) {
          W[i] <- bit32$rotate(Reduce(bit32$xor,c(W[[i-3]],W[[i-8]],W[[i-14]],W[[i-16]])),1)
        }
        for(i in 0:3){
          for(j in 1:20) {
            temp <- Reduce(`+`,c(bit32$rotate(A,5) , f[[i+1]](B,C,D) , E , W[[i*20+j]] , K[[i+1]]))
            E <- D
            D <- C
            C <- bit32$rotate(B,30)
            B <- A
            A <- temp
          }
        }
        H4 <<- H4 + E
        H3 <<- H3 + D
        H2 <<- H2 + C
        H1 <<- H1 + B
        H0 <<- H0 + A
      }

      return(rev(c(
        H4$byte,
        H3$byte,
        H2$byte,
        H1$byte,
        H0$byte
      )))
    },
    update = function(msg) {
      if(is.character(msg)) msg <- charToRaw(msg)
      message <<- c(message,msg)
    },
    expand = function(msg) {
      len <- length(msg)
      bitLength <- c(rep(as.raw(0x00),4),rev(UInt32$new(len*8)$byte))
      needZero <- (64 - 8) - ( len + 1 ) %% 64
      if(needZero < 0) {
        c(msg,as.raw(0x80),rep(as.raw(0x00),needZero+64),bitLength)
      } else {
        c(msg,as.raw(0x80),rep(as.raw(0x00),needZero),bitLength)
      }
    }
  )
)

# test (example)
library(testthat)
test_that("sha1",{
sha1 <- SHA1$new()
sha1$reset()
sha1$update("abcde")
expect_equal(
  (paste(sha1$digest(),collapse="")),
  "03de6c570bfe24bfc328ccd7ca46b76eadaf4334"
)
sha1$reset()
sha1$update(rep(charToRaw("a"),120))
expect_equal(
  paste(sha1$digest(),collapse=""),
  "f34c1488385346a55709ba056ddd08280dd4c6d6"
)
})