mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-11-30 02:51:10 +03:00
remote: shuffle reply serializers, extend ReplySError
This commit is contained in:
sorki
parent
7bdbab9c53
commit
a5dac6da5f
@ -44,10 +44,6 @@ module System.Nix.Store.Remote.Serializer
|
||||
, pathMetadata
|
||||
-- * OutputName
|
||||
, outputName
|
||||
-- * Realisation
|
||||
, derivationOutputTyped
|
||||
, realisation
|
||||
, realisationWithId
|
||||
-- * Signatures
|
||||
, signature
|
||||
, narSignature
|
||||
@ -63,7 +59,6 @@ module System.Nix.Store.Remote.Serializer
|
||||
, derivedPath
|
||||
-- * Build
|
||||
, buildMode
|
||||
, buildResult
|
||||
-- * Logger
|
||||
, LoggerSError(..)
|
||||
, activityID
|
||||
@ -89,6 +84,12 @@ module System.Nix.Store.Remote.Serializer
|
||||
, storeRequest
|
||||
-- ** Reply
|
||||
, ReplySError(..)
|
||||
-- *** Realisation
|
||||
, derivationOutputTyped
|
||||
, realisation
|
||||
, realisationWithId
|
||||
-- *** BuildResult
|
||||
, buildResult
|
||||
) where
|
||||
|
||||
import Control.Monad.Except (MonadError, throwError, )
|
||||
@ -620,28 +621,6 @@ outputName =
|
||||
System.Nix.OutputName.unOutputName
|
||||
text
|
||||
|
||||
-- * Realisation
|
||||
|
||||
derivationOutputTyped :: NixSerializer r SError (System.Nix.Realisation.DerivationOutput OutputName)
|
||||
derivationOutputTyped =
|
||||
mapPrismSerializer
|
||||
( Data.Bifunctor.first SError_DerivationOutput
|
||||
. System.Nix.Realisation.derivationOutputParser
|
||||
System.Nix.OutputName.mkOutputName
|
||||
)
|
||||
( Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
. System.Nix.Realisation.derivationOutputBuilder
|
||||
System.Nix.OutputName.unOutputName
|
||||
)
|
||||
text
|
||||
|
||||
realisation :: NixSerializer r SError Realisation
|
||||
realisation = json
|
||||
|
||||
realisationWithId :: NixSerializer r SError (System.Nix.Realisation.DerivationOutput OutputName, Realisation)
|
||||
realisationWithId = json
|
||||
|
||||
-- * Signatures
|
||||
|
||||
signature
|
||||
@ -804,64 +783,6 @@ derivedPath = Serializer
|
||||
buildMode :: NixSerializer r SError BuildMode
|
||||
buildMode = enum
|
||||
|
||||
buildResult
|
||||
:: ( HasProtoVersion r
|
||||
, HasStoreDir r
|
||||
)
|
||||
=> NixSerializer r SError BuildResult
|
||||
buildResult = Serializer
|
||||
{ getS = do
|
||||
pv <- Control.Monad.Reader.asks hasProtoVersion
|
||||
|
||||
buildResultStatus <- getS enum
|
||||
buildResultErrorMessage <- getS maybeText
|
||||
|
||||
( buildResultTimesBuilt
|
||||
, buildResultIsNonDeterministic
|
||||
, buildResultStartTime
|
||||
, buildResultStopTime
|
||||
) <-
|
||||
if protoVersion_minor pv >= 29
|
||||
then do
|
||||
tb <- (\case 0 -> Nothing; x -> Just x) <$> getS int
|
||||
nondet <- getS bool
|
||||
start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time
|
||||
end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time
|
||||
pure $ (tb, pure nondet, start, end)
|
||||
else pure $ (Nothing, Nothing, Nothing, Nothing)
|
||||
|
||||
buildResultBuiltOutputs <-
|
||||
if protoVersion_minor pv >= 28
|
||||
then
|
||||
pure
|
||||
. Data.Map.Strict.fromList
|
||||
. map (\(_, (a, b)) -> (a, b))
|
||||
. Data.Map.Strict.toList
|
||||
<$> getS (mapS derivationOutputTyped realisationWithId)
|
||||
else pure Nothing
|
||||
pure BuildResult{..}
|
||||
|
||||
, putS = \BuildResult{..} -> do
|
||||
pv <- Control.Monad.Reader.asks hasProtoVersion
|
||||
|
||||
putS enum buildResultStatus
|
||||
putS maybeText buildResultErrorMessage
|
||||
Control.Monad.when (protoVersion_minor pv >= 29) $ do
|
||||
putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt
|
||||
putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic
|
||||
putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime
|
||||
putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime
|
||||
Control.Monad.when (protoVersion_minor pv >= 28)
|
||||
$ putS (mapS derivationOutputTyped realisationWithId)
|
||||
$ Data.Map.Strict.fromList
|
||||
$ map (\(a, b) -> (a, (a, b)))
|
||||
$ Data.Map.Strict.toList
|
||||
$ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs
|
||||
}
|
||||
where
|
||||
t0 :: UTCTime
|
||||
t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
|
||||
-- * Logger
|
||||
|
||||
data LoggerSError
|
||||
@ -1414,5 +1335,103 @@ storeRequest = Serializer
|
||||
-- * Reply
|
||||
|
||||
data ReplySError
|
||||
= ReplySError_Prim SError
|
||||
= ReplySError_PrimGet SError
|
||||
| ReplySError_PrimPut SError
|
||||
| ReplySError_DerivationOutput SError
|
||||
| ReplySError_Realisation SError
|
||||
| ReplySError_RealisationWithId SError
|
||||
deriving (Eq, Ord, Generic, Show)
|
||||
|
||||
mapGetER
|
||||
:: Functor m
|
||||
=> SerialT r SError m a
|
||||
-> SerialT r ReplySError m a
|
||||
mapGetER = mapErrorST ReplySError_PrimGet
|
||||
|
||||
mapPutER
|
||||
:: Functor m
|
||||
=> SerialT r SError m a
|
||||
-> SerialT r ReplySError m a
|
||||
mapPutER = mapErrorST ReplySError_PrimPut
|
||||
|
||||
-- *** Realisation
|
||||
|
||||
derivationOutputTyped :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName)
|
||||
derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $
|
||||
mapPrismSerializer
|
||||
( Data.Bifunctor.first SError_DerivationOutput
|
||||
. System.Nix.Realisation.derivationOutputParser
|
||||
System.Nix.OutputName.mkOutputName
|
||||
)
|
||||
( Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
. System.Nix.Realisation.derivationOutputBuilder
|
||||
System.Nix.OutputName.unOutputName
|
||||
)
|
||||
text
|
||||
|
||||
realisation :: NixSerializer r ReplySError Realisation
|
||||
realisation = mapErrorS ReplySError_Realisation json
|
||||
|
||||
realisationWithId :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName, Realisation)
|
||||
realisationWithId = mapErrorS ReplySError_RealisationWithId json
|
||||
|
||||
-- *** BuildResult
|
||||
|
||||
buildResult
|
||||
:: ( HasProtoVersion r
|
||||
, HasStoreDir r
|
||||
)
|
||||
=> NixSerializer r ReplySError BuildResult
|
||||
buildResult = Serializer
|
||||
{ getS = do
|
||||
pv <- Control.Monad.Reader.asks hasProtoVersion
|
||||
|
||||
buildResultStatus <- mapGetER $ getS enum
|
||||
buildResultErrorMessage <- mapGetER $ getS maybeText
|
||||
|
||||
( buildResultTimesBuilt
|
||||
, buildResultIsNonDeterministic
|
||||
, buildResultStartTime
|
||||
, buildResultStopTime
|
||||
) <-
|
||||
if protoVersion_minor pv >= 29
|
||||
then mapGetER $ do
|
||||
tb <- (\case 0 -> Nothing; x -> Just x) <$> getS int
|
||||
nondet <- getS bool
|
||||
start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time
|
||||
end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time
|
||||
pure $ (tb, pure nondet, start, end)
|
||||
else pure $ (Nothing, Nothing, Nothing, Nothing)
|
||||
|
||||
buildResultBuiltOutputs <-
|
||||
if protoVersion_minor pv >= 28
|
||||
then
|
||||
pure
|
||||
. Data.Map.Strict.fromList
|
||||
. map (\(_, (a, b)) -> (a, b))
|
||||
. Data.Map.Strict.toList
|
||||
<$> getS (mapS derivationOutputTyped realisationWithId)
|
||||
else pure Nothing
|
||||
pure BuildResult{..}
|
||||
|
||||
, putS = \BuildResult{..} -> do
|
||||
pv <- Control.Monad.Reader.asks hasProtoVersion
|
||||
|
||||
mapPutER $ putS enum buildResultStatus
|
||||
mapPutER $ putS maybeText buildResultErrorMessage
|
||||
Control.Monad.when (protoVersion_minor pv >= 29) $ mapPutER $ do
|
||||
putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt
|
||||
putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic
|
||||
putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime
|
||||
putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime
|
||||
Control.Monad.when (protoVersion_minor pv >= 28)
|
||||
$ putS (mapS derivationOutputTyped realisationWithId)
|
||||
$ Data.Map.Strict.fromList
|
||||
$ map (\(a, b) -> (a, (a, b)))
|
||||
$ Data.Map.Strict.toList
|
||||
$ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs
|
||||
}
|
||||
where
|
||||
t0 :: UTCTime
|
||||
t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
|
||||
@ -23,7 +23,7 @@ instance StoreReply Bool where
|
||||
getReplyS = mapPrimE bool
|
||||
|
||||
instance StoreReply BuildResult where
|
||||
getReplyS = mapPrimE buildResult
|
||||
getReplyS = buildResult
|
||||
|
||||
instance StoreReply StorePath where
|
||||
getReplyS = mapPrimE storePath
|
||||
@ -31,4 +31,4 @@ instance StoreReply StorePath where
|
||||
mapPrimE
|
||||
:: NixSerializer r SError a
|
||||
-> NixSerializer r ReplySError a
|
||||
mapPrimE = mapErrorS ReplySError_Prim
|
||||
mapPrimE = mapErrorS ReplySError_PrimGet
|
||||
|
||||
Loading…
Reference in New Issue
Block a user