S3.hs

{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeOperators         #-}

-- | Hashing of S3 objects
--
--   This module allows us to fetch objects from S3, taking advantage of S3's
--   support for CAS to avoid the need to calculate our own content hashes.
module Data.CAS.ContentHashable.S3 where

import qualified Aws
import qualified Aws.S3                          as S3
import           Control.Monad                   ((>=>))
import           Control.Monad.Trans.Resource    (runResourceT)
import           Data.Aeson
import           Data.CAS.ContentHashable
import           Data.Constraint
import           Data.Reflection
import           GHC.Generics                    (Generic)
import           Network.HTTP.Conduit            (newManager,
                                                  tlsManagerSettings)

-- | Reference to an object in an S3 bucket
--
--   Objects can be referenced in a few ways, so this
--   type is parametrised over the object reference.
--   Currently, this is expected to be:
--   - S3.Object (alias for Text)
--   - S3.ObjectInfo
data ObjectInBucket obj = ObjectInBucket
  { _oibBucket :: S3.Bucket
  , _oibObject :: obj
  } deriving (Show, Generic)

-- | A lens to _oibBucket
oibBucket :: Functor f => (S3.Bucket -> f S3.Bucket) -> ObjectInBucket obj -> f (ObjectInBucket obj)
oibBucket f oib = rebuild <$> f (_oibBucket oib)
  where rebuild b = oib{_oibBucket=b}

-- | A lens to _oibObject
oibObject :: Functor f => (a -> f b) -> ObjectInBucket a -> f (ObjectInBucket b)
oibObject f oib = rebuild <$> f (_oibObject oib)
  where rebuild o = oib{_oibObject=o}

instance FromJSON (ObjectInBucket S3.Object)
instance ToJSON (ObjectInBucket S3.Object)

class ObjectReference a where
  objectReference :: a -> S3.Object

instance ObjectReference S3.Object where
  objectReference = id

instance ObjectReference S3.ObjectInfo where
  objectReference = S3.objectKey

-- | An S3 object is hashable whenever we have sufficient configuration to
--   access said object. To deal with this, we use reflection to reify a value
--   (the AWS configuration) into a class constraint.
--   To use this instance, you must reify the value using 'give':
--   @
--     cfg <- Aws.baseConfiguration
--     give cfg $ contentHash s3object
--   @
--
--   Since S3 is already content hashed, we do not need to actually hash the
--   object ourselves. In fact, we avoid fetching the object, and only
--   request the metadata including the content hash.
--   We incorporate the bucket and name into this to give extra guarantees on
--   uniqueness, but we may be better abolishing this to deduplicate files
--   stored in multiple places.
instance (Given Aws.Configuration)
  => ContentHashable IO (ObjectInBucket S3.Object) where
  contentHashUpdate ctx a = let
      s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery
    in do
      {- Set up a ResourceT region with an available HTTP manager. -}
      mgr <- newManager tlsManagerSettings

      {- Create a request object with S3.getObject and run the request with pureAws. -}
      S3.GetObjectResponse { S3.gorMetadata = md } <- runResourceT $
        Aws.pureAws given s3cfg mgr $
          S3.getObject (_oibBucket a) (_oibObject a)

      flip contentHashUpdate (_oibBucket a)
        >=> flip contentHashUpdate (_oibObject a)
        >=> flip contentHashUpdate (S3.omETag md)
          $ ctx

-- | Reified instance of the implication to allow us to use this as a
--   constraint.
instance (Given Aws.Configuration)
         :=> ContentHashable IO (ObjectInBucket S3.Object) where
  ins = Sub Dict

-- | When we already have `ObjectInfo` (because we have, for example, queried
--   the bucket), we can calculate the 'ContentHash' directly without recourse
--   do S3, because we already know the S3 hash.
instance Monad m => ContentHashable m (ObjectInBucket S3.ObjectInfo) where
  contentHashUpdate ctx a =
    flip contentHashUpdate (_oibBucket a)
      >=> flip contentHashUpdate (S3.objectKey $ _oibObject a)
      >=> flip contentHashUpdate (S3.objectETag $ _oibObject a)
        $ ctx

-- | Reified instance of the implication to allow us to use this as a
--   constraint.
instance (Given Aws.Configuration)
         :=> ContentHashable IO (ObjectInBucket S3.ObjectInfo) where
  ins = Sub Dict