{-# 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) =
  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
    Maybe (CasaRepoPrefix, Int)
mCasaConfig <- 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 -> Maybe (CasaRepoPrefix, Int)
pcCasaConfig
    case Maybe (CasaRepoPrefix, Int)
mCasaConfig of
      Just (CasaRepoPrefix
pullUrl, Int
maxPerRequest) -> do
        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
              }
          )
      Maybe (CasaRepoPrefix, Int)
Nothing -> 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 = 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