{-# LANGUAGE OverloadedStrings #-}
{-# 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
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) =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing))
    (forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
      (forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource (forall a. a -> Identity a
Identity BlobKey
key) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing))
  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd)
    (forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource (forall a. a -> Identity a
Identity BlobKey
key) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 = forall {i}.
ConduitT
  i
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
source 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 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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
      CasaRepoPrefix
pullUrl <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> CasaRepoPrefix
pcCasaRepoPrefix
      Int
maxPerRequest <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Int
pcCasaMaxPerRequest
      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 = forall (f :: * -> *).
Foldable f =>
f BlobKey -> HashMap BlobKey Int
toBlobKeyMap f BlobKey
keys
           , sourceConfigMaxBlobsPerRequest :: Int
sourceConfigMaxBlobsPerRequest = Int
maxPerRequest
           })
      where
        toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int
        toBlobKeyMap :: forall (f :: * -> *).
Foldable f =>
f BlobKey -> HashMap BlobKey Int
toBlobKeyMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {b}. Num b => BlobKey -> (BlobKey, b)
unpackBlobKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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), forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
fileSize)
    convert :: ConduitT
  (BlobKey, ByteString)
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
convert = forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC 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 -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SHA256Exception
e
              Right SHA256
sha -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SHA256
sha
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha256 (Word -> FileSize
FileSize (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 = forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC 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)
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall env.
ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob ByteString
binary)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, ByteString)
original