{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

-- | Utils for the other Stack.Storage modules

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

import qualified Data.Set as Set
import           Database.Persist
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
       )
    => (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) =>
(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 =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set value
old forall a. Eq a => a -> a -> Bool
/= Set value
new) forall a b. (a -> b) -> a -> b
$ do
        forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere
            [ EntityField record parentid
parentFieldCons forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. parentid
parentId
            , EntityField record value
valueFieldCons forall v typ.
PersistField typ =>
EntityField v typ -> [typ] -> Filter v
<-. forall a. Set a -> [a]
Set.toList (forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set value
old Set value
new)
            ]
        forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[record] -> ReaderT backend m ()
insertMany_ forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (parentid -> value -> record
recordCons parentid
parentId) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList (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
       )
    => (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) =>
(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 =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([value]
old forall a. Eq a => a -> a -> Bool
/= [value]
new) forall a b. (a -> b) -> a -> b
$ do
        let oldSet :: Set (Int, value)
oldSet = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [value]
old)
            newSet :: Set (Int, value)
newSet = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [value]
new)
        forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere
            [ EntityField record parentid
parentFieldCons forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. parentid
parentId
            , EntityField record Int
indexFieldCons forall v typ.
PersistField typ =>
EntityField v typ -> [typ] -> Filter v
<-.
              forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set (Int, value)
oldSet Set (Int, value)
newSet)
            ]
        forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[record] -> ReaderT backend m ()
insertMany_ forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ parentid -> Int -> value -> record
recordCons parentid
parentId) forall a b. (a -> b) -> a -> b
$
            forall a. Set a -> [a]
Set.toList (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 <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try RIO env a
inner
    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 ->
                        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
                            forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$ Text -> Path Abs File -> SomeException -> StoragePrettyException
StorageMigrationFailure Text
desc Path Abs File
fp SomeException
ex
                    PantryException
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
e
        )
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Either PantryException a
eres