{-# LANGUAGE DisambiguateRecordFields #-}

-- | Integration with the Casa server.


module Pantry.Casa where

import           Database.Persist.Sql ( SqlBackend )
import qualified Casa.Client as Casa
import qualified Casa.Types as Casa
import           Conduit
                   ( ConduitT, ResourceT, (.|), await, mapMC, runConduitRes )
import qualified Data.HashMap.Strict as HM
import qualified Pantry.SHA256 as SHA256
import           Pantry.Storage ( storeBlob, withStorage )
import           Pantry.Types as P
                   ( BlobKey (..), FileSize (..), HasPantryConfig (..)
                   , PantryConfig (..), PantryException (..), Tree, TreeKey (..)
                   , parseTreeM
                   )
import           RIO
import qualified RIO.ByteString as B

-- | Lookup a tree.

casaLookupTree ::
     (HasPantryConfig env, HasLogFunc env)
  => TreeKey
  -> RIO env (Maybe (TreeKey, P.Tree))
casaLookupTree :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
TreeKey -> RIO env (Maybe (TreeKey, Tree))
casaLookupTree (P.TreeKey BlobKey
key) =
  (SomeException -> RIO env (Maybe (TreeKey, Tree)))
-> RIO env (Maybe (TreeKey, Tree))
-> RIO env (Maybe (TreeKey, Tree))
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (RIO env (Maybe (TreeKey, Tree))
-> SomeException -> RIO env (Maybe (TreeKey, Tree))
forall a b. a -> b -> a
const (Maybe (TreeKey, Tree) -> RIO env (Maybe (TreeKey, Tree))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TreeKey, Tree)
forall a. Maybe a
Nothing))
    (ReaderT SqlBackend (RIO env) (Maybe (TreeKey, Tree))
-> RIO env (Maybe (TreeKey, Tree))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
      (ConduitT
  ()
  Void
  (ResourceT (ReaderT SqlBackend (RIO env)))
  (Maybe (TreeKey, Tree))
-> ReaderT SqlBackend (RIO env) (Maybe (TreeKey, Tree))
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (Identity BlobKey
-> ConduitT
     ()
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource (BlobKey -> Identity BlobKey
forall a. a -> Identity a
Identity BlobKey
key) ConduitT
  ()
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitT
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     (Maybe (TreeKey, Tree))
-> ConduitT
     ()
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     (Maybe (TreeKey, Tree))
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ((BlobKey, ByteString)
 -> ResourceT (ReaderT SqlBackend (RIO env)) (TreeKey, Tree))
-> ConduitT
     (BlobKey, ByteString)
     (TreeKey, Tree)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (BlobKey, ByteString)
-> ResourceT (ReaderT SqlBackend (RIO env)) (TreeKey, Tree)
forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM ConduitT
  (BlobKey, ByteString)
  (TreeKey, Tree)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitT
     (TreeKey, Tree)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     (Maybe (TreeKey, Tree))
-> ConduitT
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     (Maybe (TreeKey, Tree))
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  (TreeKey, Tree)
  Void
  (ResourceT (ReaderT SqlBackend (RIO env)))
  (Maybe (TreeKey, Tree))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await)))

-- | Lookup a single blob. If possible, prefer 'casaBlobSource', and query a

-- group of keys at once, rather than one at a time. This will have better

-- network performance.

casaLookupKey ::
     (HasPantryConfig env, HasLogFunc env)
  => BlobKey
  -> RIO env (Maybe ByteString)
casaLookupKey :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
BlobKey -> RIO env (Maybe ByteString)
casaLookupKey BlobKey
key =
  (SomeException -> RIO env (Maybe ByteString))
-> RIO env (Maybe ByteString) -> RIO env (Maybe ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (RIO env (Maybe ByteString)
-> SomeException -> RIO env (Maybe ByteString)
forall a b. a -> b -> a
const (Maybe ByteString -> RIO env (Maybe ByteString)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing))
  ((Maybe (BlobKey, ByteString) -> Maybe ByteString)
-> RIO env (Maybe (BlobKey, ByteString))
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    (((BlobKey, ByteString) -> ByteString)
-> Maybe (BlobKey, ByteString) -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlobKey, ByteString) -> ByteString
forall a b. (a, b) -> b
snd)
    (ReaderT SqlBackend (RIO env) (Maybe (BlobKey, ByteString))
-> RIO env (Maybe (BlobKey, ByteString))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ConduitT
  ()
  Void
  (ResourceT (ReaderT SqlBackend (RIO env)))
  (Maybe (BlobKey, ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe (BlobKey, ByteString))
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (Identity BlobKey
-> ConduitT
     ()
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource (BlobKey -> Identity BlobKey
forall a. a -> Identity a
Identity BlobKey
key) ConduitT
  ()
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitT
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     (Maybe (BlobKey, ByteString))
-> ConduitT
     ()
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     (Maybe (BlobKey, ByteString))
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  (BlobKey, ByteString)
  Void
  (ResourceT (ReaderT SqlBackend (RIO env)))
  (Maybe (BlobKey, ByteString))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await))))

-- | A source of blobs given a set of keys. All blobs are automatically stored

-- in the local pantry database.

casaBlobSource ::
     (Foldable f, HasPantryConfig env, HasLogFunc env)
  => f BlobKey
  -> ConduitT
       i
       (BlobKey, ByteString)
       (ResourceT (ReaderT SqlBackend (RIO env)))
       ()
casaBlobSource :: forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource f BlobKey
keys = ConduitT
  i
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
forall {i}.
ConduitT
  i
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
source ConduitT
  i
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitT
     (BlobKey, ByteString)
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  (BlobKey, ByteString)
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
convert ConduitT
  (BlobKey, ByteString)
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitT
     (BlobKey, ByteString)
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
-> ConduitT
     (BlobKey, ByteString)
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  (BlobKey, ByteString)
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
forall {a}.
ConduitT
  (a, ByteString)
  (a, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
store
 where
  source :: ConduitT
  i
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
source = do
    Maybe (CasaRepoPrefix, Int)
mCasaConfig <- ResourceT
  (ReaderT SqlBackend (RIO env)) (Maybe (CasaRepoPrefix, Int))
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     (Maybe (CasaRepoPrefix, Int))
forall (m :: * -> *) a.
Monad m =>
m a -> ConduitT i (BlobKey, ByteString) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResourceT
   (ReaderT SqlBackend (RIO env)) (Maybe (CasaRepoPrefix, Int))
 -> ConduitT
      i
      (BlobKey, ByteString)
      (ResourceT (ReaderT SqlBackend (RIO env)))
      (Maybe (CasaRepoPrefix, Int)))
-> ResourceT
     (ReaderT SqlBackend (RIO env)) (Maybe (CasaRepoPrefix, Int))
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     (Maybe (CasaRepoPrefix, Int))
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) (Maybe (CasaRepoPrefix, Int))
-> ResourceT
     (ReaderT SqlBackend (RIO env)) (Maybe (CasaRepoPrefix, Int))
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT SqlBackend (RIO env) (Maybe (CasaRepoPrefix, Int))
 -> ResourceT
      (ReaderT SqlBackend (RIO env)) (Maybe (CasaRepoPrefix, Int)))
-> ReaderT SqlBackend (RIO env) (Maybe (CasaRepoPrefix, Int))
-> ResourceT
     (ReaderT SqlBackend (RIO env)) (Maybe (CasaRepoPrefix, Int))
forall a b. (a -> b) -> a -> b
$ RIO env (Maybe (CasaRepoPrefix, Int))
-> ReaderT SqlBackend (RIO env) (Maybe (CasaRepoPrefix, Int))
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env (Maybe (CasaRepoPrefix, Int))
 -> ReaderT SqlBackend (RIO env) (Maybe (CasaRepoPrefix, Int)))
-> RIO env (Maybe (CasaRepoPrefix, Int))
-> ReaderT SqlBackend (RIO env) (Maybe (CasaRepoPrefix, Int))
forall a b. (a -> b) -> a -> b
$ Getting
  (Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
 -> RIO env (Maybe (CasaRepoPrefix, Int)))
-> Getting
     (Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int))
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
-> env -> Const (Maybe (CasaRepoPrefix, Int)) env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL ((PantryConfig -> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
 -> env -> Const (Maybe (CasaRepoPrefix, Int)) env)
-> ((Maybe (CasaRepoPrefix, Int)
     -> Const
          (Maybe (CasaRepoPrefix, Int)) (Maybe (CasaRepoPrefix, Int)))
    -> PantryConfig
    -> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
-> Getting
     (Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PantryConfig -> Maybe (CasaRepoPrefix, Int))
-> SimpleGetter PantryConfig (Maybe (CasaRepoPrefix, Int))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Maybe (CasaRepoPrefix, Int)
pcCasaConfig
    case Maybe (CasaRepoPrefix, Int)
mCasaConfig of
      Just (CasaRepoPrefix
pullUrl, Int
maxPerRequest) -> do
        SourceConfig
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) i.
(MonadThrow m, MonadResource m, MonadIO m) =>
SourceConfig -> ConduitT i (BlobKey, ByteString) m ()
Casa.blobsSource
          ( Casa.SourceConfig
              { sourceConfigUrl :: CasaRepoPrefix
sourceConfigUrl = CasaRepoPrefix
pullUrl
              , sourceConfigBlobs :: HashMap BlobKey Int
sourceConfigBlobs = f BlobKey -> HashMap BlobKey Int
forall (f :: * -> *).
Foldable f =>
f BlobKey -> HashMap BlobKey Int
toBlobKeyMap f BlobKey
keys
              , sourceConfigMaxBlobsPerRequest :: Int
sourceConfigMaxBlobsPerRequest = Int
maxPerRequest
              }
          )
      Maybe (CasaRepoPrefix, Int)
Nothing -> PantryException
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall e a.
(HasCallStack, Exception e) =>
e
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM PantryException
NoCasaConfig
   where
    toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int
    toBlobKeyMap :: forall (f :: * -> *).
Foldable f =>
f BlobKey -> HashMap BlobKey Int
toBlobKeyMap = [(BlobKey, Int)] -> HashMap BlobKey Int
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(BlobKey, Int)] -> HashMap BlobKey Int)
-> (f BlobKey -> [(BlobKey, Int)])
-> f BlobKey
-> HashMap BlobKey Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlobKey -> (BlobKey, Int)) -> [BlobKey] -> [(BlobKey, Int)]
forall a b. (a -> b) -> [a] -> [b]
map BlobKey -> (BlobKey, Int)
forall {b}. Num b => BlobKey -> (BlobKey, b)
unpackBlobKey ([BlobKey] -> [(BlobKey, Int)])
-> (f BlobKey -> [BlobKey]) -> f BlobKey -> [(BlobKey, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f BlobKey -> [BlobKey]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
    unpackBlobKey :: BlobKey -> (BlobKey, b)
unpackBlobKey (P.BlobKey SHA256
sha256 (FileSize Word
fileSize)) =
      (ByteString -> BlobKey
Casa.BlobKey (SHA256 -> ByteString
SHA256.toRaw SHA256
sha256), Word -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
fileSize)
  convert :: ConduitT
  (BlobKey, ByteString)
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
convert = ((BlobKey, ByteString)
 -> ResourceT (ReaderT SqlBackend (RIO env)) (BlobKey, ByteString))
-> ConduitT
     (BlobKey, ByteString)
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (BlobKey, ByteString)
-> ResourceT (ReaderT SqlBackend (RIO env)) (BlobKey, ByteString)
forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (BlobKey, ByteString)
toBlobKeyAndBlob
   where
    toBlobKeyAndBlob ::
         MonadThrow m
      => (Casa.BlobKey, ByteString)
      -> m (BlobKey, ByteString)
    toBlobKeyAndBlob :: forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (BlobKey, ByteString)
toBlobKeyAndBlob (Casa.BlobKey ByteString
keyBytes, ByteString
blob) = do
      SHA256
sha256 <-
        case ByteString -> Either SHA256Exception SHA256
SHA256.fromRaw ByteString
keyBytes of
          Left SHA256Exception
e -> SHA256Exception -> m SHA256
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SHA256Exception
e
          Right SHA256
sha -> SHA256 -> m SHA256
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SHA256
sha
      (BlobKey, ByteString) -> m (BlobKey, ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha256 (Word -> FileSize
FileSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
blob))), ByteString
blob)
  store :: ConduitT
  (a, ByteString)
  (a, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
store = ((a, ByteString)
 -> ResourceT (ReaderT SqlBackend (RIO env)) (a, ByteString))
-> ConduitT
     (a, ByteString)
     (a, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (a, ByteString)
-> ResourceT (ReaderT SqlBackend (RIO env)) (a, ByteString)
forall {t :: (* -> *) -> * -> *} {env} {a}.
(Monad (t (ReaderT SqlBackend (RIO env))), MonadTrans t) =>
(a, ByteString) -> t (ReaderT SqlBackend (RIO env)) (a, ByteString)
insertBlob
   where
    insertBlob :: (a, ByteString) -> t (ReaderT SqlBackend (RIO env)) (a, ByteString)
insertBlob original :: (a, ByteString)
original@(a
_key, ByteString
binary) = do
      (BlobId, BlobKey)
_ <- ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
-> t (ReaderT SqlBackend (RIO env)) (BlobId, BlobKey)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
forall env.
ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob ByteString
binary)
      (a, ByteString) -> t (ReaderT SqlBackend (RIO env)) (a, ByteString)
forall a. a -> t (ReaderT SqlBackend (RIO env)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, ByteString)
original