{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE TypeFamilies          #-}

-- | Utils for the other Stack.Storage modules

module Stack.Storage.Util
  ( handleMigrationException
  , updateList
  , updateSet
  ) where

import qualified Data.Set as Set
import           Database.Persist
                   ( BaseBackend, EntityField, PersistEntity
                   , PersistEntityBackend, PersistField, PersistQueryWrite
                   , SafeToInsert, (<-.), (==.), deleteWhere, insertMany_
                   )
import           Stack.Prelude
import           Stack.Types.Storage ( StoragePrettyException (..) )

-- | Efficiently update a set of values stored in a database table

updateSet ::
     ( PersistEntityBackend record ~ BaseBackend backend
     , PersistField parentid
     , PersistField value
     , Ord value
     , PersistEntity record
     , MonadIO m
     , PersistQueryWrite backend
     , SafeToInsert record
     )
  => (parentid -> value -> record)
  -> EntityField record parentid
  -> parentid
  -> EntityField record value
  -> Set value
  -> Set value
  -> ReaderT backend m ()
updateSet :: forall record backend parentid value (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistField parentid, PersistField value, Ord value,
 PersistEntity record, MonadIO m, PersistQueryWrite backend,
 SafeToInsert record) =>
(parentid -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record value
-> Set value
-> Set value
-> ReaderT backend m ()
updateSet parentid -> value -> record
recordCons EntityField record parentid
parentFieldCons parentid
parentId EntityField record value
valueFieldCons Set value
old Set value
new =
  Bool -> ReaderT backend m () -> ReaderT backend m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set value
old Set value -> Set value -> Bool
forall a. Eq a => a -> a -> Bool
/= Set value
new) (ReaderT backend m () -> ReaderT backend m ())
-> ReaderT backend m () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ do
    [Filter record] -> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere
      [ EntityField record parentid
parentFieldCons EntityField record parentid -> parentid -> Filter record
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. parentid
parentId
      , EntityField record value
valueFieldCons EntityField record value -> [value] -> Filter record
forall v typ.
PersistField typ =>
EntityField v typ -> [typ] -> Filter v
<-. Set value -> [value]
forall a. Set a -> [a]
Set.toList (Set value -> Set value -> Set value
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set value
old Set value
new)
      ]
    [record] -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend,
 SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ ([record] -> ReaderT backend m ())
-> [record] -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$
      (value -> record) -> [value] -> [record]
forall a b. (a -> b) -> [a] -> [b]
map (parentid -> value -> record
recordCons parentid
parentId) ([value] -> [record]) -> [value] -> [record]
forall a b. (a -> b) -> a -> b
$ Set value -> [value]
forall a. Set a -> [a]
Set.toList (Set value -> Set value -> Set value
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set value
new Set value
old)

-- | Efficiently update a list of values stored in a database table.

updateList ::
     ( PersistEntityBackend record ~ BaseBackend backend
     , PersistField parentid
     , Ord value
     , PersistEntity record
     , MonadIO m
     , PersistQueryWrite backend
     , SafeToInsert record
     )
  => (parentid -> Int -> value -> record)
  -> EntityField record parentid
  -> parentid
  -> EntityField record Int
  -> [value]
  -> [value]
  -> ReaderT backend m ()
updateList :: forall record backend parentid value (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistField parentid, Ord value, PersistEntity record, MonadIO m,
 PersistQueryWrite backend, SafeToInsert record) =>
(parentid -> Int -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record Int
-> [value]
-> [value]
-> ReaderT backend m ()
updateList parentid -> Int -> value -> record
recordCons EntityField record parentid
parentFieldCons parentid
parentId EntityField record Int
indexFieldCons [value]
old [value]
new =
  Bool -> ReaderT backend m () -> ReaderT backend m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([value]
old [value] -> [value] -> Bool
forall a. Eq a => a -> a -> Bool
/= [value]
new) (ReaderT backend m () -> ReaderT backend m ())
-> ReaderT backend m () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ do
    let oldSet :: Set (Int, value)
oldSet = [(Int, value)] -> Set (Int, value)
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> [value] -> [(Int, value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [value]
old)
        newSet :: Set (Int, value)
newSet = [(Int, value)] -> Set (Int, value)
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> [value] -> [(Int, value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [value]
new)
    [Filter record] -> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere
      [ EntityField record parentid
parentFieldCons EntityField record parentid -> parentid -> Filter record
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. parentid
parentId
      , EntityField record Int
indexFieldCons EntityField record Int -> [Int] -> Filter record
forall v typ.
PersistField typ =>
EntityField v typ -> [typ] -> Filter v
<-.
        ((Int, value) -> Int) -> [(Int, value)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, value) -> Int
forall a b. (a, b) -> a
fst (Set (Int, value) -> [(Int, value)]
forall a. Set a -> [a]
Set.toList (Set (Int, value) -> [(Int, value)])
-> Set (Int, value) -> [(Int, value)]
forall a b. (a -> b) -> a -> b
$ Set (Int, value) -> Set (Int, value) -> Set (Int, value)
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set (Int, value)
oldSet Set (Int, value)
newSet)
      ]
    [record] -> ReaderT backend m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
[record] -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend,
 SafeToInsert record) =>
[record] -> ReaderT backend m ()
insertMany_ ([record] -> ReaderT backend m ())
-> [record] -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$
      ((Int, value) -> record) -> [(Int, value)] -> [record]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> value -> record) -> (Int, value) -> record
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> value -> record) -> (Int, value) -> record)
-> (Int -> value -> record) -> (Int, value) -> record
forall a b. (a -> b) -> a -> b
$ parentid -> Int -> value -> record
recordCons parentid
parentId) ([(Int, value)] -> [record]) -> [(Int, value)] -> [record]
forall a b. (a -> b) -> a -> b
$
      Set (Int, value) -> [(Int, value)]
forall a. Set a -> [a]
Set.toList (Set (Int, value) -> Set (Int, value) -> Set (Int, value)
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set (Int, value)
newSet Set (Int, value)
oldSet)

handleMigrationException :: HasLogFunc env => RIO env a -> RIO env a
handleMigrationException :: forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException RIO env a
inner = do
  Either PantryException a
eres <- RIO env a -> RIO env (Either PantryException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try RIO env a
inner
  (PantryException -> RIO env a)
-> (a -> RIO env a) -> Either PantryException a -> RIO env a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    ( \PantryException
e -> case PantryException
e :: PantryException of
              MigrationFailure Text
desc Path Abs File
fp SomeException
ex ->
                StoragePrettyException -> RIO env a
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (StoragePrettyException -> RIO env a)
-> StoragePrettyException -> RIO env a
forall a b. (a -> b) -> a -> b
$ Text -> Path Abs File -> SomeException -> StoragePrettyException
StorageMigrationFailure Text
desc Path Abs File
fp SomeException
ex
              PantryException
_ -> PantryException -> RIO env a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
e
    )
    a -> RIO env a
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Either PantryException a
eres