1structure SHA1_ML :> SHA1_ML =
2struct
3
4  (* taken from
5       git@github.com:srdqty/sml-sha1.git
6  *)
7
8(* Copyright (c) 2014 Sophia Donataccio, The MIT License (MIT) *)
9
10(* A good explanation of the sha1 algorithm is available at
11   https://en.wikipedia.org/wiki/SHA-1 *)
12
13  type 'a byte_reader = 'a * int -> Word8Vector.vector * 'a
14
15  local
16    fun toBitSize x = Word64.*(x, 0w8)
17
18    fun explodeSize size (* in bits *) =
19      let
20        val s7 = Word64.>>(Word64.<<(size, 0w56), 0w56)
21        val s6 = Word64.>>(Word64.<<(size, 0w48), 0w56)
22        val s5 = Word64.>>(Word64.<<(size, 0w40), 0w56)
23        val s4 = Word64.>>(Word64.<<(size, 0w32), 0w56)
24        val s3 = Word64.>>(Word64.<<(size, 0w24), 0w56)
25        val s2 = Word64.>>(Word64.<<(size, 0w16), 0w56)
26        val s1 = Word64.>>(Word64.<<(size, 0w08), 0w56)
27        val s0 = Word64.>>(size                 , 0w56)
28      in
29        ( Word8.fromLarge (Word64.toLarge s0)
30        , Word8.fromLarge (Word64.toLarge s1)
31        , Word8.fromLarge (Word64.toLarge s2)
32        , Word8.fromLarge (Word64.toLarge s3)
33        , Word8.fromLarge (Word64.toLarge s4)
34        , Word8.fromLarge (Word64.toLarge s5)
35        , Word8.fromLarge (Word64.toLarge s6)
36        , Word8.fromLarge (Word64.toLarge s7))
37      end
38
39    fun createLastChunk (chunk, messageByteSize) =
40      let
41        val chunkSize = Word8Vector.length chunk
42        val (s0, s1, s2, s3, s4, s5, s6, s7) =
43          (* Size in bits is stored in the chunk *)
44          explodeSize (toBitSize messageByteSize)
45        fun buildChunk i =
46          if i < chunkSize then Word8Vector.sub (chunk, i)
47          else if i = chunkSize then 0wx80
48          else if i = 56 then s0
49          else if i = 57 then s1
50          else if i = 58 then s2
51          else if i = 59 then s3
52          else if i = 60 then s4
53          else if i = 61 then s5
54          else if i = 62 then s6
55          else if i = 63 then s7
56          else 0w0
57      in
58        Word8Vector.tabulate (64, buildChunk)
59      end
60
61    fun addPadding chunk =
62      let
63        val chunkSize = Word8Vector.length chunk
64        fun buildChunk i =
65          if i < chunkSize then Word8Vector.sub (chunk, i)
66          else if i = chunkSize then 0wx80
67          else 0w0
68      in
69        Word8Vector.tabulate (64, buildChunk)
70      end
71
72    fun createPadChunk messageByteSize =
73      let
74        val (s0, s1, s2, s3, s4, s5, s6, s7) =
75          (* Size in bits is stored in the chunk *)
76          explodeSize (toBitSize messageByteSize)
77        fun buildChunk i =
78          if i < 56 then 0w0
79          else if i = 56 then s0
80          else if i = 57 then s1
81          else if i = 58 then s2
82          else if i = 59 then s3
83          else if i = 60 then s4
84          else if i = 61 then s5
85          else if i = 62 then s6
86          else if i = 63 then s7
87          else raise (Fail "createPadChunk: invalid chunk size")
88      in
89        Word8Vector.tabulate (64, buildChunk)
90      end
91
92    datatype 'a ChunkReaderState =
93      Reading of 'a byte_reader * 'a * Word64.word
94    | PadChunk of Word8Vector.vector
95    | Empty
96
97  in (* local *)
98
99    fun makeInitChunkStreamState (byteReader, byteStreamState) =
100      Reading (byteReader, byteStreamState, 0w0)
101
102    fun readChunk Empty = NONE
103      | readChunk (PadChunk chunk) = SOME (chunk, Empty)
104      | readChunk (Reading(byteReader, byteStreamState, totalBytesRead)) =
105        let
106          val (chunk, nextByteStreamState) = byteReader (byteStreamState, 64)
107          val chunkSize = Word8Vector.length chunk
108          val nextTotalBytesRead =
109              Word64.+(Word64.fromInt chunkSize, totalBytesRead)
110        in
111          if chunkSize = 64 then SOME (chunk, Reading(byteReader,
112              nextByteStreamState, nextTotalBytesRead))
113          else if chunkSize < 56 then SOME(createLastChunk (chunk,
114              nextTotalBytesRead), Empty)
115          else (* 56 < chunkSize <= 64 *)
116            SOME(addPadding chunk, PadChunk (createPadChunk nextTotalBytesRead))
117        end
118  end
119
120  structure Word32Array = Array
121
122  local
123    fun initializeWorkingArrayWithDataFromChunk (chunk, wArray) =
124      let
125        fun sub (c, i) =
126          Word32.fromLarge(PackWord32Big.subVec (c, i))
127        fun calcW i =
128          let
129            val w1 = Word32Array.sub(wArray, i - 3)
130            val w2 = Word32Array.sub(wArray, i - 8)
131            val w3 = Word32Array.sub(wArray, i - 14)
132            val w4 = Word32Array.sub(wArray, i - 16)
133            fun lrot1 w = Word32.orb(Word32.<<(w, 0w1), Word32.>>(w, 0w31))
134          in
135            lrot1 (Word32.xorb(Word32.xorb(Word32.xorb(w1, w2), w3), w4))
136          end
137        fun loop1 i =
138          if 0 <= i andalso i <= 15 then
139            (Word32Array.update (wArray, i, sub (chunk, i))
140            ; loop1 (i + 1))
141          else ()
142        fun loop2 i =
143          if 16 <= i andalso i <= 79 then
144            (Word32Array.update (wArray, i, calcW i)
145            ; loop2 (i + 1))
146          else ()
147      in
148        ( loop1 0
149        ; loop2 16)
150      end
151
152    fun packHashResultIntoByteVector (h0, h1, h2, h3, h4) =
153      let
154        val result = Word8Array.array (20, 0wx0)
155      in
156        (PackWord32Big.update(result, 0, Word32.toLarge h0)
157        ; PackWord32Big.update(result, 1, Word32.toLarge h1)
158        ; PackWord32Big.update(result, 2, Word32.toLarge h2)
159        ; PackWord32Big.update(result, 3, Word32.toLarge h3)
160        ; PackWord32Big.update(result, 4, Word32.toLarge h4)
161        ; Word8Array.vector result)
162      end
163
164    (* Given the current hash state values and the current
165       chunk (preprocessed into a working array by fillWorkingArray),
166       this function updates the hash state values according to the
167       sha1 algorithm *)
168    fun processChunkData (wArray, h0, h1, h2, h3, h4) =
169      let
170        fun loop (i, a, b, c, d, e) =
171          let
172            fun lrot5 w =
173              let
174                val lsb5 = Word32.>>(w, 0w27)
175                val msb27 = Word32.<<(w, 0w5)
176              in
177                Word32.orb(msb27, lsb5)
178              end
179            fun lrot30 w =
180              let
181                val lsb30 = Word32.>>(w, 0w2)
182                val msb2 = Word32.<<(w, 0w30)
183              in
184                Word32.orb(msb2, lsb30)
185              end
186            fun calcF (i, b, c, d) =
187              if 0 <= i andalso i <= 19 then
188                Word32.orb(Word32.andb(b, c),
189                           Word32.andb(Word32.notb b, d))
190              else if 20 <= i andalso i <= 39 then
191                Word32.xorb(Word32.xorb(b, c), d)
192              else if 40 <= i andalso i <= 59 then
193                Word32.orb(Word32.orb(Word32.andb(b, c),
194                                      Word32.andb(b, d)),
195                           Word32.andb(c, d))
196              else (* 60 <= i <= 79 *)
197                Word32.xorb(Word32.xorb(b, c), d)
198            fun calcK i =
199              if 0 <= i andalso i <= 19 then       0wx5a827999
200              else if 20 <= i andalso i <= 39 then 0wx6ed9eba1
201              else if 40 <= i andalso i <= 59 then 0wx8f1bbcdc
202              else (* 60 <= i <= 79 *)             0wxca62c1d6
203            fun calcA (a, f, e, k, w) =
204              Word32.+(Word32.+(Word32.+(Word32.+(lrot5 a, f), e), k), w)
205          in
206            if 0 <= i andalso i <= 79 then
207              let
208                val f = calcF (i, b, c, d)
209                val k = calcK i
210                val a' = calcA (a, f, e, k, Word32Array.sub(wArray, i))
211                val b' = a
212                val c' = lrot30 b
213                val d' = c
214                val e' = d
215              in
216                loop (i + 1, a', b', c', d', e')
217              end
218            else
219              (h0 + a, h1 + b, h2 + c, h3 + d, h4 + e)
220          end
221      in
222        loop (0, h0, h1, h2, h3, h4)
223      end
224
225  in (* local *)
226
227    fun sha1 byteReader byteStreamState =
228      let
229        (* The initial values of the hash result state. These are defined
230           by the sha1 algorithm. *)
231        val initH0 : Word32.word = 0wx67452301
232        val initH1 : Word32.word = 0wxefcdab89
233        val initH2 : Word32.word = 0wx98badcfe
234        val initH3 : Word32.word = 0wx10325476
235        val initH4 : Word32.word = 0wxc3d2e1f0
236
237        (* An array that will be used for temporary space repeatedly
238           to process each chunk *)
239        val workingArray = Word32Array.array (80, 0wx0)
240
241        fun loopOverChunks (chunkStreamState, h0, h1, h2, h3, h4) =
242          case readChunk chunkStreamState of
243            NONE => packHashResultIntoByteVector (h0, h1, h2, h3, h4)
244          | SOME (chunk, nextChunkStreamState) =>
245            let
246              val _ =
247                initializeWorkingArrayWithDataFromChunk (chunk, workingArray)
248
249              (* Process the data in the working array (filled
250                 with the current chunk's data) using the sha1
251                 hash algorithm *)
252              val (h0', h1', h2', h3', h4') =
253                processChunkData (workingArray, h0, h1, h2, h3, h4)
254            in
255              loopOverChunks (nextChunkStreamState, h0', h1', h2', h3', h4')
256            end
257      in
258        loopOverChunks (makeInitChunkStreamState (byteReader, byteStreamState),
259                        initH0, initH1, initH2, initH3, initH4)
260      end
261  end
262
263  fun sha1String byteReader byteStreamState = let
264    val hashVector = sha1 byteReader byteStreamState
265
266    fun ithNibbleToHexDigitChar i = let
267      fun getNibble i = let
268        fun isEven n = n mod 2 = 0
269        fun getMostSignificantNibble byte = Word8.>>(byte, 0w4)
270        fun getLeastSignificantNibble byte = Word8.andb(byte, 0wx0f)
271        val byteI = Word8Vector.sub (hashVector, i div 2)
272      in
273        if isEven i
274          then getMostSignificantNibble byteI
275          else getLeastSignificantNibble byteI
276      end
277
278      fun nibbleToHexDigitChar nibble =
279        case Char.fromString (Word8.toString nibble) of
280            NONE => raise (Fail "sha1String: invalid hex digit")
281          | SOME ch => Char.toLower ch
282
283    in
284      nibbleToHexDigitChar (getNibble i)
285    end
286
287  in
288    CharVector.tabulate (40, ithNibbleToHexDigitChar)
289  end
290
291  fun sha1_file0 {filename} =
292      let
293        val fstream = BinIO.openIn filename
294        val fstream' = BinIO.getInstream fstream
295      in
296        sha1String BinIO.StreamIO.inputN fstream' before
297        BinIO.closeIn fstream
298      end
299
300  fun sha1_file {filename} =
301      if OS.FileSys.access("/usr/bin/shasum", [OS.FileSys.A_EXEC]) then
302          case Mosml.run "/usr/bin/shasum" [Systeml.protect filename] "" of
303              Mosml.Success s => hd (String.tokens Char.isSpace s)
304            | Mosml.Failure _ => sha1_file0 {filename=filename}
305      else
306        sha1_file0 {filename=filename}
307
308end
309