mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-12-01 23:23:04 +03:00
remote: add gcResult serializer
This commit is contained in:
parent
5aa62fd8da
commit
77fe9f9acd
@ -90,6 +90,8 @@ module System.Nix.Store.Remote.Serializer
|
||||
, realisationWithId
|
||||
-- *** BuildResult
|
||||
, buildResult
|
||||
-- *** GCResult
|
||||
, gcResult
|
||||
) where
|
||||
|
||||
import Control.Monad.Except (MonadError, throwError, )
|
||||
@ -1338,6 +1340,7 @@ data ReplySError
|
||||
= ReplySError_PrimGet SError
|
||||
| ReplySError_PrimPut SError
|
||||
| ReplySError_DerivationOutput SError
|
||||
| ReplySError_GCResult SError
|
||||
| ReplySError_Realisation SError
|
||||
| ReplySError_RealisationWithId SError
|
||||
deriving (Eq, Ord, Generic, Show)
|
||||
@ -1435,3 +1438,18 @@ buildResult = Serializer
|
||||
where
|
||||
t0 :: UTCTime
|
||||
t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
|
||||
gcResult
|
||||
:: HasStoreDir r
|
||||
=> NixSerializer r ReplySError GCResult
|
||||
gcResult = mapErrorS ReplySError_GCResult $ Serializer
|
||||
{ getS = do
|
||||
gcResult_deletedPaths <- getS (hashSet storePath)
|
||||
gcResult_bytesFreed <- getS int
|
||||
Control.Monad.void $ getS (int @Word64) -- obsolete
|
||||
pure GCResult{..}
|
||||
, putS = \GCResult{..} -> do
|
||||
putS (hashSet storePath) gcResult_deletedPaths
|
||||
putS int gcResult_bytesFreed
|
||||
putS (int @Word64) 0 -- obsolete
|
||||
}
|
||||
|
@ -5,6 +5,7 @@ module System.Nix.Store.Remote.Types.StoreReply
|
||||
import System.Nix.Build (BuildResult)
|
||||
import System.Nix.StorePath (HasStoreDir(..), StorePath)
|
||||
import System.Nix.Store.Remote.Serializer
|
||||
import System.Nix.Store.Remote.Types.GC (GCResult)
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion)
|
||||
|
||||
-- | Get @NixSerializer@ for some type @a@
|
||||
@ -25,6 +26,9 @@ instance StoreReply Bool where
|
||||
instance StoreReply BuildResult where
|
||||
getReplyS = buildResult
|
||||
|
||||
instance StoreReply GCResult where
|
||||
getReplyS = gcResult
|
||||
|
||||
instance StoreReply StorePath where
|
||||
getReplyS = mapPrimE storePath
|
||||
|
||||
|
@ -149,6 +149,9 @@ spec = parallel $ do
|
||||
forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig)))
|
||||
$ roundtripSReader @TestStoreConfig storeRequest testStoreConfig
|
||||
|
||||
describe "StoreReply" $ do
|
||||
prop "GCResult" $ roundtripSReader @StoreDir gcResult
|
||||
|
||||
restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool
|
||||
restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False
|
||||
restrictProtoVersion _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty
|
||||
|
Loading…
Reference in New Issue
Block a user