{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DisambiguateRecordFields #-}
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
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)))
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))))
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