<commit_before>{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Server.BlobStorage
-- Copyright   :  <NAME> <<EMAIL>>
--
-- Maintainer  :  <NAME> <<EMAIL>>
-- Stability   :  alpha
-- Portability :  portable
--
-- Persistent storage for blobs of data.
--
module Distribution.Server.BlobStorage (
    BlobStorage,
    BlobId,
    open,
    add,
    fetch,
  ) where

import qualified Data.ByteString.Lazy as BS
import Data.ByteString.Lazy (ByteString)
import Data.Digest.Pure.MD5
         ( MD5Digest, md5 )
import Data.Typeable (Typeable)
import Data.Binary (Binary)
import System.FilePath
         ( (</>) )
import Control.Exception as Exception
import System.Directory
import System.IO

-- | An id for a blob. The content of the blob is stable.
--
newtype BlobId = BlobId MD5Digest
  deriving (Eq, Ord, Binary, Typeable)

instance Show BlobId where show (BlobId digest) = show digest

-- | A persistent blob storage area. Blobs can be added and retrieved but
-- not removed or modified.
--
newtype BlobStorage = BlobStorage FilePath -- ^ location of the store

filepath :: BlobStorage -> BlobId -> FilePath
filepath (BlobStorage store) (BlobId hash) = store </> show hash

incomingDir :: BlobStorage -> FilePath
incomingDir (BlobStorage store) = store </> "incoming"

-- | Add a blob into the store. The result is a 'BlobId' that can be used
-- later with 'fetch' to retrieve the blob content.
--
-- * This operation is idempotent. That is, adding the same content again
--   gives the same 'BlobId'.
--
add :: BlobStorage -> ByteString -> IO BlobId
add store content = do
  (file, hnd) <- openBinaryTempFile (incomingDir store) "tmp"
  handleExceptions file hnd $ do
    -- TODO: calculate the md5 and write to the temp file in one pass:
    BS.hPut hnd content
    hSeek hnd AbsoluteSeek 0
    blobId <- evaluate . BlobId . md5 =<< BS.hGetContents hnd
    --TODO: if the target already exists then there is no need to overwrite it
    --      since it will have the same content. Checking and then renaming
    --      would give a race condition but that's ok since they have the same
    --      content.
    renameFile file (filepath store blobId)
    return blobId

  where
    handleExceptions tmpFile tmpHandle =
      Exception.handle $ \err -> do
        hClose tmpHandle
        removeFile tmpFile
        Exception.throwIO err

-- | Retrieve a blob from the store given its 'BlobId'.
--
-- * The content corresponding to a given 'BlobId' never changes.
--<commit_msg>Add BlobStorage.addWith Writes the input to the incomming area, gives us a chance to validate and then either rolls back or commits the blob to the store. Refactored internals to support both add and addWith.<commit_after>{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Server.BlobStorage
-- Copyright   :  <NAME> <<EMAIL>>
--
-- Maintainer  :  <NAME> <<EMAIL>>
-- Stability   :  alpha
-- Portability :  portable
--
-- Persistent storage for blobs of data.
--
module Distribution.Server.BlobStorage (
    BlobStorage,
    BlobId,
    open,
    add,
    addWith,
    fetch,
  ) where

import qualified Data.ByteString.Lazy as BS
import Data.ByteString.Lazy (ByteString)
import Data.Digest.Pure.MD5
         ( MD5Digest, md5 )
import Data.Typeable (Typeable)
import Data.Binary (Binary)
import System.FilePath
         ( (</>) )
import Control.Exception as Exception
import System.Directory
import System.IO

-- | An id for a blob. The content of the blob is stable.
--
newtype BlobId = BlobId MD5Digest
  deriving (Eq, Ord, Binary, Typeable)

instance Show BlobId where show (BlobId digest) = show digest

-- | A persistent blob storage area. Blobs can be added and retrieved but
-- not removed or modified.
--
newtype BlobStorage = BlobStorage FilePath -- ^ location of the store

filepath :: BlobStorage -> BlobId -> FilePath
filepath (BlobStorage store) (BlobId hash) = store </> show hash

incomingDir :: BlobStorage -> FilePath
incomingDir (BlobStorage store) = store </> "incoming"

-- | Add a blob into the store. The result is a 'BlobId' that can be used
-- later with 'fetch' to retrieve the blob content.
--
-- * This operation is idempotent. That is, adding the same content again
--   gives the same 'BlobId'.
--
add :: BlobStorage -> ByteString -> IO BlobId
add store content =
  withIncomming store content $ \_ blobId -> return (blobId, True)

-- | Like 'add' but we get another chance to make another pass over the input
-- 'ByteString'.
--
-- What happens is that we stream the input into a temp file in an incomming
-- area. Then we can make a second pass over it to do some validation or
-- processing. If the validator decides to reject then we rollback and the
-- blob is not entered into the store. If it accepts then the blob is added
-- and the 'BlobId' is returned.
--
addWith :: BlobStorage -> ByteString
        -> (ByteString -> Either error result)
        -> IO (Either error (result, BlobId))
addWith store content check =
  withIncomming store content $ \hnd blobId -> do
    hSeek hnd AbsoluteSeek 0
    content' <- BS.hGetContents hnd
    case check content' of
      Left  err -> return (Left  err,          False)
      Right res -> return (Right (res, blobId), True)

withIncomming :: BlobStorage -> ByteString
              -> (Handle -> BlobId -> IO (a, Bool))
              -> IO a
withIncomming store content action = do
  (file, hnd) <- openBinaryTempFile (incomingDir store) "tmp"
  handleExceptions file hnd $ do
    -- TODO: calculate the md5 and write to the temp file in one pass:
    BS.hPut hnd content
    hSeek hnd AbsoluteSeek 0
    blobId <- evaluate . BlobId . md5 =<< BS.hGetContents hnd

    (res, commit) <- action hnd blobId
    hClose hnd
    if commit
      --TODO: if the target already exists then there is no need to overwrite
      -- it since it will have the same content. Checking and then renaming
      -- would give a race condition but that's ok since they have the same
      -- content.
      then renameFile file (filepath store blobId)
      else removeFile file
    return res

  where
    handleExceptions tmpFile tmpHandle =
      Exception.handle $ \err -> do
        hClose tmpHandle
        removeFile tmpFile
        Exception.throwIO err

-- | Retrieve a blob from the store given its 'BlobId'.
--
-- * The content corresponding to a given 'BlobId' never changes.
--
{'fraction_non_alphanumeric': 0.11097616517382723, 'fraction_numerical': 0.0022772126916654014, 'mean_word_length': 2.6357615894039736, 'pattern_counts': {'":': 0, '<': 31, '<?xml version=': 0, '>': 46, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7639484', 'n_tokens_mistral': 1904, 'n_tokens_neox': 1875, 'n_words': 776}