    {-# 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