<commit_before>{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE BangPatterns           #-}

module Push where

import Control.Exception.Safe
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.AWS              (AWST', runAWST)
import Control.Monad.Trans.Resource
import Data.Int
import Data.Either
import Data.Maybe
import Data.String.Conversions              (cs)
import Data.Text                            (append, Text)
import Katip
import Network.AWS
import Network.AWS.Data
import Network.AWS.Glacier.CompleteMultipartUpload
import Network.AWS.Glacier.InitiateMultipartUpload
import Network.AWS.Glacier.UploadArchive
import Network.AWS.Glacier.UploadMultipartPart
import Network.AWS.Data.Headers
import System.Environment
import System.Exit
import System.IO
import Test.QuickCheck

import qualified Crypto.Hash.SHA256             as SHA256
import qualified Data.ByteString.Base16         as B16
import qualified Crypto.Hash                    as Hash
import qualified Data.ByteString                as BS
import qualified Data.CaseInsensitive           as CI

type Hash = BS.ByteString

chunkSize :: Int64
chunkSize = 4096

-- | Section of a file for a multipart upload. The start
-- and end offsets are inclusive.
data Part = Part
    { _partStart    :: !Int64
    , _partEnd      :: !Int64
    , _partHash     :: !Hash
    , _path         :: !FilePath
    }
  deriving (Show)

-- | Things needed for a multipart upload.
data MultiPart = MultiPart
    { _multipartFullHash    :: !Hash         -- ^ Hash of the whole file.
    , _partSize             :: !Int64        -- ^ Part size in bytes.
    , _multiParts           :: ![Part]       -- ^ Description of each part.
    , _multipartPath        :: !FilePath     -- ^ Path to the file.
    , _multipartArchiveSize :: !Int64        -- ^ Total archive (file) size.
    }
  deriving (Show)

makeLenses ''Part
makeLenses ''MultiPart

-- | We use a single '@-@ ' (hyphen) as the account ID so that Amazon Glacier uses the AWS account ID
-- associated with the credentials used to sign the request.
accountId :: Text
accountId = "-"

data MyException = MissingUploadID deriving (Show, Typeable)

instance Exception MyException

treeHashFile filepath = do
    l <- leaves' filepath
    return $ treeHash' l
  where
    treeHash' []  = error "Internal error in treeHash'."
    treeHash' [x] = x
    treeHash' xs  = treeHash' $ next xs

    leaves' filepath = do
        h <- openFile filepath ReadMode
        loop h
      where
        loop h = do
            eof <- hIsEOF h
            if eof
                then return []
                else do (h, chunk) <- hashOneMbChunk h
                        let chunk' = toHexBS chunk
                        rest <- loop h
                        return (chunk':rest)

    toHexBS :: Hash.Digest Hash.SHA256 -> BS.ByteString
    toHexBS = cs . show

    hashOneMbChunk :: Handle -> IO (Handle, Hash.Digest Hash.SHA256)
    hashOneMbChunk h = loop h Hash.hashInit oneMb
      where
        loop h context 0 = return (h, Hash.hashFinalize context)
        loop h !context !remaining = do
          chunk <- BS.hGetSome h $ fromIntegral chunkSize
          if BS.null chunk
            then return (h, Hash.hashFinalize context)
            else loop h (Hash.hashUpdate context chunk) (remaining - chunkSize)

readFile' :: (MonadCatch m, MonadIO m) => String -> m BS.ByteString
readFile' = liftIO . BS.readFile

getFileSize' :: (MonadCatch m, MonadIO m) => FilePath -> m Integer
getFileSize' f = liftIO $ withFile f ReadMode hFileSize

oneMb :: Int64
oneMb = 1024*1024

-- | Compute a tree hash of a bytestring as described in
-- http://docs.aws.amazon.com/amazonglacier/latest/dev/checksum-calculations.html
treeHash :: BS.ByteString -> Hash
treeHash s = treeHash' $ leaves s
  where
    treeHash' []  = error "Internal error in treeHash'."
    treeHash' [x] = B16.encode x
    treeHash' xs  = treeHash' $ next xs

leaves :: BS.ByteString -> [BS.ByteString]
leaves s = map sha256 $ oneMbChunks s

next :: [BS.ByteString] -> [BS.ByteString]
next []       = []
next [a]      = [a]
next (a:b:xs) = sha256 (BS.append a b) : next xs

oneMbChunks :: BS.ByteString -> [BS.ByteString]
oneMbChunks x
  | BS.length x <= (fromIntegral oneMb) = [x]
  | otherwise            = BS.take (fromIntegral oneMb) x : oneMbChunks (BS.drop (fromIntegral oneMb) x)

sha256 :: BS.ByteString -> BS.ByteString
sha256 = cs . SHA256.hash

-- | Send a request in the AWS monad transformer.
send'
    :: (MonadIO m,
        HasEnv e,
        MonadAWS (AWST' e (ResourceT IO)),
        AWSRequest a)
    => e        -- ^ Environment (e.g. 'Env').
    -> a        -- ^ Request to send, e.g. 'UploadMultipartPart'.
    -> m (Rs a) -- ^ Response.
send' env x = liftIO $ runResourceT . runAWST env $ send x

-- | Upload an archive in one go.
uploadArchiveSingle
    :: (MonadCatch m, MonadIO m)
    => Env                      -- ^ AWS Environment.
    -> Text                     -- ^ Vault name.
    -> FilePath                 -- ^ File to upload.
    -> Text                     -- ^ Archive Description.
    -> m ArchiveCreationOutput  -- ^ Response.
uploadArchiveSingle env vault f archiveDesc = do
    hash <- treeHash <$> readFile' f
    body <- toHashed <$> readFile' f<commit_msg>More efficient for single upload.<commit_after>{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE BangPatterns           #-}

module Push where

import Control.Exception.Safe
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.AWS              (AWST', runAWST)
import Control.Monad.Trans.Resource
import Data.Int
import Data.Either
import Data.Maybe
import Data.String.Conversions              (cs)
import Data.Text                            (append, Text)
import Katip
import Network.AWS
import Network.AWS.Data
import Network.AWS.Glacier.CompleteMultipartUpload
import Network.AWS.Glacier.InitiateMultipartUpload
import Network.AWS.Glacier.UploadArchive
import Network.AWS.Glacier.UploadMultipartPart
import Network.AWS.Data.Headers
import System.Environment
import System.Exit
import System.IO
import Test.QuickCheck

import qualified Crypto.Hash.SHA256             as SHA256
import qualified Data.ByteString.Base16         as B16
import qualified Crypto.Hash                    as Hash
import qualified Data.ByteString                as BS
import qualified Data.CaseInsensitive           as CI

type Hash = BS.ByteString

chunkSize :: Int64
chunkSize = 4096

-- | Section of a file for a multipart upload. The start
-- and end offsets are inclusive.
data Part = Part
    { _partStart    :: !Int64
    , _partEnd      :: !Int64
    , _partHash     :: !Hash
    , _path         :: !FilePath
    }
  deriving (Show)

-- | Things needed for a multipart upload.
data MultiPart = MultiPart
    { _multipartFullHash    :: !Hash         -- ^ Hash of the whole file.
    , _partSize             :: !Int64        -- ^ Part size in bytes.
    , _multiParts           :: ![Part]       -- ^ Description of each part.
    , _multipartPath        :: !FilePath     -- ^ Path to the file.
    , _multipartArchiveSize :: !Int64        -- ^ Total archive (file) size.
    }
  deriving (Show)

makeLenses ''Part
makeLenses ''MultiPart

-- | We use a single '@-@ ' (hyphen) as the account ID so that Amazon Glacier uses the AWS account ID
-- associated with the credentials used to sign the request.
accountId :: Text
accountId = "-"

data MyException = MissingUploadID deriving (Show, Typeable)

instance Exception MyException

treeHashFile filepath = do
    l <- leaves' filepath
    return $ treeHash' l
  where
    treeHash' []  = error "Internal error in treeHash'."
    treeHash' [x] = x
    treeHash' xs  = treeHash' $ next xs

    leaves' filepath = do
        h <- openFile filepath ReadMode
        loop h
      where
        loop h = do
            eof <- hIsEOF h
            if eof
                then return []
                else do (h, chunk) <- hashOneMbChunk h
                        let chunk' = toHexBS chunk
                        rest <- loop h
                        return (chunk':rest)

    toHexBS :: Hash.Digest Hash.SHA256 -> BS.ByteString
    toHexBS = cs . show

    hashOneMbChunk :: Handle -> IO (Handle, Hash.Digest Hash.SHA256)
    hashOneMbChunk h = loop h Hash.hashInit oneMb
      where
        loop h context 0 = return (h, Hash.hashFinalize context)
        loop h !context !remaining = do
          chunk <- BS.hGetSome h $ fromIntegral chunkSize
          if BS.null chunk
            then return (h, Hash.hashFinalize context)
            else loop h (Hash.hashUpdate context chunk) (remaining - chunkSize)

readFile' :: (MonadCatch m, MonadIO m) => String -> m BS.ByteString
readFile' = liftIO . BS.readFile

getFileSize' :: (MonadCatch m, MonadIO m) => FilePath -> m Integer
getFileSize' f = liftIO $ withFile f ReadMode hFileSize

oneMb :: Int64
oneMb = 1024*1024

-- | Compute a tree hash of a bytestring as described in
-- http://docs.aws.amazon.com/amazonglacier/latest/dev/checksum-calculations.html
treeHash :: BS.ByteString -> Hash
treeHash s = treeHash' $ leaves s
  where
    treeHash' []  = error "Internal error in treeHash'."
    treeHash' [x] = B16.encode x
    treeHash' xs  = treeHash' $ next xs

leaves :: BS.ByteString -> [BS.ByteString]
leaves s = map sha256 $ oneMbChunks s

next :: [BS.ByteString] -> [BS.ByteString]
next []       = []
next [a]      = [a]
next (a:b:xs) = sha256 (BS.append a b) : next xs

oneMbChunks :: BS.ByteString -> [BS.ByteString]
oneMbChunks x
  | BS.length x <= (fromIntegral oneMb) = [x]
  | otherwise            = BS.take (fromIntegral oneMb) x : oneMbChunks (BS.drop (fromIntegral oneMb) x)

sha256 :: BS.ByteString -> BS.ByteString
sha256 = cs . SHA256.hash

-- | Send a request in the AWS monad transformer.
send'
    :: (MonadIO m,
        HasEnv e,
        MonadAWS (AWST' e (ResourceT IO)),
        AWSRequest a)
    => e        -- ^ Environment (e.g. 'Env').
    -> a        -- ^ Request to send, e.g. 'UploadMultipartPart'.
    -> m (Rs a) -- ^ Response.
send' env x = liftIO $ runResourceT . runAWST env $ send x

-- | Upload an archive in one go.
uploadArchiveSingle
    :: (MonadCatch m, MonadIO m)
    => Env                      -- ^ AWS Environment.
    -> Text                     -- ^ Vault name.
    -> FilePath                 -- ^ File to upload.
    -> Text                     -- ^ Archive Description.
    -> m ArchiveCreationOutput  -- ^ Response.
uploadArchiveSingle env vault f archiveDesc = do
    hash <- liftIO $ treeHashFile f
    body <- toHashed <$> (liftIO . BS.readFile) f
{'fraction_non_alphanumeric': 0.10032864706956363, 'fraction_numerical': 0.010589738908161402, 'mean_word_length': 2.2449644549763033, 'pattern_counts': {'":': 0, '<': 24, '<?xml version=': 0, '>': 44, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4755196', 'n_tokens_mistral': 3492, 'n_tokens_neox': 3294, 'n_words': 1052}