0 |
  1 | ||| SipHash24 copied from C [reference implementation](https://github.com/veorq/SipHash/blob/master/siphash.c)
  2 | module Data.Hashable.SipHash
  3 |
  4 | import Data.Buffer
  5 | import Data.IORef
  6 |
  7 | %default total
  8 |
  9 | %inline
 10 | CROUNDS : Nat
 11 | CROUNDS = 2
 12 |
 13 | %inline
 14 | DROUNDS : Nat
 15 | DROUNDS = 4
 16 |
 17 | record State where
 18 |     constructor MkState
 19 |     v0 : Bits64
 20 |     v1 : Bits64
 21 |     v2 : Bits64
 22 |     v3 : Bits64
 23 |
 24 | %inline
 25 | shl : Bits64 -> Bits64 -> Bits64
 26 | shl = prim__shl_Bits64
 27 |
 28 | %inline
 29 | shr : Bits64 -> Bits64 -> Bits64
 30 | shr = prim__shr_Bits64
 31 |
 32 | %inline
 33 | bor : Bits64 -> Bits64 -> Bits64
 34 | bor = prim__or_Bits64
 35 |
 36 | %inline
 37 | xor : Bits64 -> Bits64 -> Bits64
 38 | xor = prim__xor_Bits64
 39 |
 40 | %inline
 41 | and : Int -> Int -> Int
 42 | and = prim__and_Int
 43 |
 44 | %inline
 45 | %spec b
 46 | rotl : Bits64 -> (b : Bits64) -> Bits64
 47 | rotl x b = (x `shl` b) `bor` (x `shr` (64 - b))
 48 |
 49 | ||| Make the length the smallest multiple of 8 bytes >= the given number
 50 | %inline
 51 | fullSize : Int -> Int
 52 | fullSize x =
 53 |     let left = x `prim__and_Int` 7
 54 |      in if (x `prim__and_Int` 7) == 0
 55 |         then x
 56 |         else x - left + 8
 57 |
 58 | -- %inline
 59 | compress : IORef State -> IO ()
 60 | compress stref = do
 61 |     MkState v0 v1 v2 v3 <- readIORef stref
 62 |     let v0 = v0 + v1;
 63 |         v1 = v1 `rotl` 13;
 64 |         v1 = v1 `xor` v0;
 65 |         v0 = v0 `rotl` 32;
 66 |         v2 = v2 + v3;
 67 |         v3 = v3 `rotl` 16;
 68 |         v3 = v3 `xor` v2;
 69 |         v0 = v0 + v3;
 70 |         v3 = v3 `rotl` 21;
 71 |         v3 = v3 `xor` v0;
 72 |         v2 = v2 + v1;
 73 |         v1 = v1 `rotl` 17;
 74 |         v1 = v1 `xor` v2;
 75 |         v2 = v2 `rotl` 32;
 76 |     writeIORef stref $ MkState v0 v1 v2 v3
 77 |
 78 | -- this could all be in ST, but Buffer doesn't support it
 79 | %inline
 80 | siphashInit : IO (IORef State)
 81 | siphashInit = newIORef $ MkState
 82 |     { v0 = 0x736f6d6570736575
 83 |     , v1 = 0x646f72616e646f6d
 84 |     , v2 = 0x6c7967656e657261
 85 |     , v3 = 0x7465646279746573
 86 |     }
 87 |
 88 | %inline
 89 | %spec count
 90 | repeat : (count : Nat) -> IO () -> IO ()
 91 | repeat Z _ = pure ()
 92 | repeat (S k) act = act >> repeat k act
 93 |
 94 | siphashLoop : IORef State -> Buffer -> Int -> Int -> IO ()
 95 | siphashLoop stref buf idx len = if idx >= len
 96 |     then pure ()
 97 |     else do
 98 |         m <- getBits64 buf idx
 99 |         repeat CROUNDS $ compress stref
100 |         siphashLoop stref buf (assert_smaller idx $ idx + 8) len
101 |
102 | %inline
103 | siphashLeftover : IORef State -> Buffer -> Int -> Int -> Int -> IO Bits64
104 | siphashLeftover stref buf size left idx = do
105 |     x <- getBits64 buf idx
106 |     pure $ x `bor` (cast size `shl` 56)
107 |
108 | siphash : Buffer -> IO Bits64
109 | siphash buf = do
110 |     stref <- siphashInit
111 |     size <- fullSize <$> rawSize buf
112 |     siphashLoop stref buf 0 size
113 |     let left = size `and` 7
114 |     b <- siphashLeftover stref buf size (size - left) left
115 |     modifyIORef stref $ { v3 $= (`xor` b) }
116 |     repeat DROUNDS $ compress stref
117 |     modifyIORef stref $ { v0 $= (`xor` b) }
118 |     MkState v0 v1 v2 v3 <- readIORef stref
119 |     pure $ (v0 `xor` v1) `xor` (v2 `xor` v3)
120 |
121 | export
122 | siphashString : String -> Bits64
123 | siphashString str = unsafePerformIO $ do
124 |     Just buf <- newBuffer $ fullSize $ stringByteLength str
125 |         | Nothing => assert_total $ idris_crash "Error allocating buffer"
126 |     setString buf 0 str
127 |     siphash buf
128 |