As described in its documentation, Amazon S3 Glacier requires that all uploaded files come with a checksum computed as a Merkle Tree using SHA-256.

Specifically, the SHA-256 hash is computed for each 1MiB block of the file. And then, starting from the beginning of the file, the raw hashes of consecutive blocks are paired up and concatenated together, and a new hash is computed from each concatenation. Then these are paired up and concatenated and hashed, and the process continues until there is only one hash left, which is the final checksum. The hexadecimal representation of this checksum is the value that must be included with the AWS API call to upload the object (or complete a multipart upload).

Implement this algorithm in your language; you can use the code from the SHA-256 task for the actual hash computations. For better manageability and portability, build the tree using a smaller block size of only 1024 bytes, and demonstrate it on the RosettaCode title image with that block size. The final result should be the hexadecimal digest value a4f902cf9d51fe51eda156a6792e1445dff65edf3a217a1f3334cc9cf1495c2c.

{-# LANGUAGE BangPatterns, LambdaCase #-}
 
import Control.Monad (mfilter)
import Crypto.Hash.SHA256 (hash)
import qualified Data.ByteString as B
import Data.ByteString.Builder (byteStringHex, char7, hPutBuilder)
import Data.Functor ((<&>))
import Data.Maybe (listToMaybe)
import Data.Strict.Tuple (Pair(..))
import qualified Data.Strict.Tuple as T
import System.Environment (getArgs)
import System.IO (Handle, stdin, stdout)
import System.IO.Streams (InputStream)
import qualified System.IO.Streams as S
import Text.Read (readMaybe)
 
type Node a    = Pair Int a
type LevelPred = Int -> Int -> Bool
type Combine a = a -> a -> a
 
-- From a stream of nodes construct the root of a tree from the bottom up.  For
-- each level of the tree pairs of nodes are combined to form a parent node one
-- level higher.  Use a stack to store nodes waiting to be combined with another
-- node on their level.  (An exception to this is at the end of processing,
-- where all the nodes on the stack can be combined.)
build :: Combine a -> [Node a] -> InputStream (Node a) -> IO (Maybe (Node a))
build combine !stack is = S.read is >>= \case
  Nothing -> return $ listToMaybe $ reduce always combine stack
  Just h  -> build combine (reduce (==) combine (h:stack)) is
 
-- Given a predicate, combining function and a stack, then as long as the
-- predicate is true, repeatedly replace the two top values on the stack with
-- their combined values.
reduce :: LevelPred -> Combine a -> [Node a] -> [Node a]
reduce prd combine (x@(i :!: _):y@(j :!: _):zs)
  | prd i j = reduce prd combine (nodeLift combine y x : zs)
reduce _ _ zs = zs
 
-- Apply a combining function to the values in two nodes while calculating the
-- appropriate level for the new node.
nodeLift :: Combine a -> Node a -> Node a -> Node a
nodeLift f (i :!: x) (j :!: y) = max i j + 1 :!: f x y
 
always :: a -> b -> Bool
always _ _ = True
 
-- Build a SHA256-based Merkle tree using bytes read from a handle, and hashing
-- the data using the given chunk size.
merkleTreeSha256 :: Int -> Handle -> IO (Maybe B.ByteString)
merkleTreeSha256 sz h = mkHash <&> fmap T.snd
  where mkHash = S.makeInputStream getBuf >>=
                 S.map (\bs -> 0 :!: hash bs) >>=
                 build (\x y -> hash (x `B.append` y)) []
        getBuf = B.hGet h sz <&> (mfilter (/= B.empty) . Just)
 
-- Print a ByteString in hex.
printByteStringHex :: B.ByteString -> IO ()
printByteStringHex = hPutBuilder stdout . (<> char7 '\n') . byteStringHex
 
main :: IO ()
main = getArgs <&> map readMaybe >>= \case
  [Just sz] -> merkleTreeSha256 sz stdin >>= \case
                 Nothing -> putStrLn "No input to hash"
                 Just h  -> printByteStringHex h
  _         -> putStrLn "Argument usage: chunk-size"