{-# LANGUAGE DisambiguateRecordFields #-}

-- | Integration with the Casa server.


module Pantry.Casa where

import qualified Casa.Client as Casa
import qualified Casa.Types as Casa
import           Conduit
import qualified Data.HashMap.Strict as HM
import qualified Pantry.SHA256 as SHA256
import           Pantry.Storage hiding ( findOrGenerateCabalFile )
import           Pantry.Types as P
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.
Exception e =>
e
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     a
forall (m :: * -> *) e a. (MonadThrow m, 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. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, 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