mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-10-26 21:56:29 +03:00
remote: delete obsolete serialization prims and instances
This commit is contained in:
parent
28d279b614
commit
4123d963b6
@ -81,8 +81,6 @@ library
|
|||||||
, System.Nix.Store.Remote.Client.Core
|
, System.Nix.Store.Remote.Client.Core
|
||||||
, System.Nix.Store.Remote.Logger
|
, System.Nix.Store.Remote.Logger
|
||||||
, System.Nix.Store.Remote.MonadStore
|
, System.Nix.Store.Remote.MonadStore
|
||||||
, System.Nix.Store.Remote.Serialize
|
|
||||||
, System.Nix.Store.Remote.Serialize.Prim
|
|
||||||
, System.Nix.Store.Remote.Serializer
|
, System.Nix.Store.Remote.Serializer
|
||||||
, System.Nix.Store.Remote.Server
|
, System.Nix.Store.Remote.Server
|
||||||
, System.Nix.Store.Remote.Socket
|
, System.Nix.Store.Remote.Socket
|
||||||
@ -174,7 +172,6 @@ test-suite remote
|
|||||||
Data.SerializerSpec
|
Data.SerializerSpec
|
||||||
EnumSpec
|
EnumSpec
|
||||||
NixSerializerSpec
|
NixSerializerSpec
|
||||||
SerializeSpec
|
|
||||||
build-tool-depends:
|
build-tool-depends:
|
||||||
hspec-discover:hspec-discover
|
hspec-discover:hspec-discover
|
||||||
build-depends:
|
build-depends:
|
||||||
@ -183,14 +180,11 @@ test-suite remote
|
|||||||
, hnix-store-remote
|
, hnix-store-remote
|
||||||
, hnix-store-tests
|
, hnix-store-tests
|
||||||
, bytestring
|
, bytestring
|
||||||
, cereal
|
|
||||||
, crypton
|
, crypton
|
||||||
, some > 1.0.5 && < 2
|
, some > 1.0.5 && < 2
|
||||||
, text
|
|
||||||
, time
|
, time
|
||||||
, hspec
|
, hspec
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
, unordered-containers
|
|
||||||
|
|
||||||
test-suite remote-io
|
test-suite remote-io
|
||||||
import: tests
|
import: tests
|
||||||
|
@ -39,13 +39,19 @@ import Data.ByteString (ByteString)
|
|||||||
import Data.Int (Int8)
|
import Data.Int (Int8)
|
||||||
import Data.GADT.Show (GShow(..), defaultGshowsPrec)
|
import Data.GADT.Show (GShow(..), defaultGshowsPrec)
|
||||||
import Data.Kind (Type)
|
import Data.Kind (Type)
|
||||||
import Data.Type.Equality
|
import Data.Type.Equality (TestEquality(..), (:~:)(Refl))
|
||||||
import Data.Serialize.Get (getInt8)
|
import Data.Serialize.Get (Get, getInt8)
|
||||||
import Data.Serialize.Put (putInt8)
|
import Data.Serialize.Put (Putter, PutM, putInt8)
|
||||||
import Data.Serializer
|
import Data.Serializer
|
||||||
|
( Serializer(..)
|
||||||
|
, GetSerializerError
|
||||||
|
, runGetS
|
||||||
|
, runPutS
|
||||||
|
, transformGetError
|
||||||
|
, transformPutError
|
||||||
|
)
|
||||||
import Data.Some (Some(..))
|
import Data.Some (Some(..))
|
||||||
import GHC.Generics
|
import GHC.Generics (Generic)
|
||||||
import System.Nix.Store.Remote.Serialize.Prim (getBool, putBool, getEnum, putEnum)
|
|
||||||
|
|
||||||
import Test.QuickCheck (Arbitrary(..), oneof)
|
import Test.QuickCheck (Arbitrary(..), oneof)
|
||||||
|
|
||||||
@ -274,3 +280,40 @@ cmdSRest = Serializer
|
|||||||
else lift (putInt8 i)
|
else lift (putInt8 i)
|
||||||
Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b)
|
Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
-- Primitives helpers
|
||||||
|
|
||||||
|
getInt :: Integral a => Get a
|
||||||
|
getInt = fromIntegral <$> getInt8
|
||||||
|
|
||||||
|
putInt :: Integral a => Putter a
|
||||||
|
putInt = putInt8 . fromIntegral
|
||||||
|
|
||||||
|
-- | Deserialize @Bool@ from integer
|
||||||
|
getBool :: Get Bool
|
||||||
|
getBool = (getInt :: Get Int8) >>= \case
|
||||||
|
0 -> pure False
|
||||||
|
1 -> pure True
|
||||||
|
x -> fail $ "illegal bool value " ++ show x
|
||||||
|
|
||||||
|
-- | Serialize @Bool@ into integer
|
||||||
|
putBool :: Putter Bool
|
||||||
|
putBool True = putInt (1 :: Int8)
|
||||||
|
putBool False = putInt (0 :: Int8)
|
||||||
|
|
||||||
|
-- | Utility toEnum version checking bounds using Bounded class
|
||||||
|
toEnumCheckBounds :: Enum a => Int -> Either String a
|
||||||
|
toEnumCheckBounds = \case
|
||||||
|
x | x < minBound -> Left $ "enum out of min bound " ++ show x
|
||||||
|
x | x > maxBound -> Left $ "enum out of max bound " ++ show x
|
||||||
|
x | otherwise -> Right $ toEnum x
|
||||||
|
|
||||||
|
-- | Deserialize @Enum@ to integer
|
||||||
|
getEnum :: Enum a => Get a
|
||||||
|
getEnum =
|
||||||
|
toEnumCheckBounds <$> getInt
|
||||||
|
>>= either fail pure
|
||||||
|
|
||||||
|
-- | Serialize @Enum@ to integer
|
||||||
|
putEnum :: Enum a => Putter a
|
||||||
|
putEnum = putInt . fromEnum
|
||||||
|
@ -1,185 +0,0 @@
|
|||||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
||||||
{-|
|
|
||||||
Description : Serialize instances for complex types
|
|
||||||
Maintainer : srk <srk@48.io>
|
|
||||||
|-}
|
|
||||||
module System.Nix.Store.Remote.Serialize where
|
|
||||||
|
|
||||||
import Data.Serialize (Serialize(..))
|
|
||||||
import Data.Serialize.Get (Get)
|
|
||||||
import Data.Serialize.Put (Putter)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Word (Word8, Word32)
|
|
||||||
|
|
||||||
import qualified Control.Monad
|
|
||||||
import qualified Data.Bits
|
|
||||||
import qualified Data.Map
|
|
||||||
import qualified Data.Set
|
|
||||||
import qualified Data.Text
|
|
||||||
import qualified Data.Vector
|
|
||||||
|
|
||||||
import System.Nix.Build (BuildMode, BuildStatus)
|
|
||||||
import System.Nix.Derivation (Derivation(..), DerivationOutput(..))
|
|
||||||
import System.Nix.StorePath (StoreDir, StorePath)
|
|
||||||
import System.Nix.Store.Remote.Serialize.Prim
|
|
||||||
import System.Nix.Store.Remote.Types
|
|
||||||
|
|
||||||
instance Serialize Text where
|
|
||||||
get = getText
|
|
||||||
put = putText
|
|
||||||
|
|
||||||
-- * Build
|
|
||||||
|
|
||||||
instance Serialize BuildMode where
|
|
||||||
get = getEnum
|
|
||||||
put = putEnum
|
|
||||||
|
|
||||||
instance Serialize BuildStatus where
|
|
||||||
get = getEnum
|
|
||||||
put = putEnum
|
|
||||||
|
|
||||||
-- * GCAction
|
|
||||||
--
|
|
||||||
instance Serialize GCAction where
|
|
||||||
get = getEnum
|
|
||||||
put = putEnum
|
|
||||||
|
|
||||||
-- * ProtoVersion
|
|
||||||
|
|
||||||
-- protoVersion_major & 0xFF00
|
|
||||||
-- protoVersion_minor & 0x00FF
|
|
||||||
instance Serialize ProtoVersion where
|
|
||||||
get = do
|
|
||||||
v <- getInt @Word32
|
|
||||||
pure ProtoVersion
|
|
||||||
{ protoVersion_major = fromIntegral $ Data.Bits.shiftR v 8
|
|
||||||
, protoVersion_minor = fromIntegral $ v Data.Bits..&. 0x00FF
|
|
||||||
}
|
|
||||||
put p =
|
|
||||||
putInt @Word32
|
|
||||||
$ ((Data.Bits.shiftL (fromIntegral $ protoVersion_major p :: Word32) 8)
|
|
||||||
Data.Bits..|. fromIntegral (protoVersion_minor p))
|
|
||||||
|
|
||||||
-- * Derivation
|
|
||||||
|
|
||||||
getDerivation
|
|
||||||
:: StoreDir
|
|
||||||
-> Get (Derivation StorePath Text)
|
|
||||||
getDerivation storeDir = do
|
|
||||||
outputs <-
|
|
||||||
Data.Map.fromList
|
|
||||||
<$> (getMany $ do
|
|
||||||
outputName <- get
|
|
||||||
path <- getPathOrFail storeDir
|
|
||||||
hashAlgo <- get
|
|
||||||
hash <- get
|
|
||||||
pure (outputName, DerivationOutput{..})
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Our type is Derivation, but in Nix
|
|
||||||
-- the type sent over the wire is BasicDerivation
|
|
||||||
-- which omits inputDrvs
|
|
||||||
inputDrvs <- pure mempty
|
|
||||||
inputSrcs <-
|
|
||||||
Data.Set.fromList
|
|
||||||
<$> getMany (getPathOrFail storeDir)
|
|
||||||
|
|
||||||
platform <- get
|
|
||||||
builder <- get
|
|
||||||
args <-
|
|
||||||
Data.Vector.fromList
|
|
||||||
<$> getMany get
|
|
||||||
|
|
||||||
env <-
|
|
||||||
Data.Map.fromList
|
|
||||||
<$> getMany ((,) <$> get <*> get)
|
|
||||||
pure Derivation{..}
|
|
||||||
|
|
||||||
putDerivation :: StoreDir -> Putter (Derivation StorePath Text)
|
|
||||||
putDerivation storeDir Derivation{..} = do
|
|
||||||
flip putMany (Data.Map.toList outputs)
|
|
||||||
$ \(outputName, DerivationOutput{..}) -> do
|
|
||||||
putText outputName
|
|
||||||
putPath storeDir path
|
|
||||||
putText hashAlgo
|
|
||||||
putText hash
|
|
||||||
|
|
||||||
putMany (putPath storeDir) inputSrcs
|
|
||||||
putText platform
|
|
||||||
putText builder
|
|
||||||
putMany putText args
|
|
||||||
|
|
||||||
flip putMany (Data.Map.toList env)
|
|
||||||
$ \(a1, a2) -> putText a1 *> putText a2
|
|
||||||
|
|
||||||
-- * Logger
|
|
||||||
|
|
||||||
instance Serialize Activity where
|
|
||||||
get =
|
|
||||||
toEnumCheckBounds . (+(-100)) <$> getInt
|
|
||||||
>>= either fail pure
|
|
||||||
put = putInt . (+100) . fromEnum
|
|
||||||
|
|
||||||
instance Serialize ActivityID where
|
|
||||||
get = ActivityID <$> getInt
|
|
||||||
put (ActivityID aid) = putInt aid
|
|
||||||
|
|
||||||
instance Serialize ActivityResult where
|
|
||||||
get =
|
|
||||||
toEnumCheckBounds . (+(-100)) <$> getInt
|
|
||||||
>>= either fail pure
|
|
||||||
put = putInt . (+100) . fromEnum
|
|
||||||
|
|
||||||
instance Serialize Field where
|
|
||||||
get = (getInt :: Get Word8) >>= \case
|
|
||||||
0 -> Field_LogInt <$> getInt
|
|
||||||
1 -> Field_LogStr <$> getText
|
|
||||||
x -> fail $ "Unknown log field type: " <> show x
|
|
||||||
put (Field_LogInt x) = putInt (0 :: Word8) >> putInt x
|
|
||||||
put (Field_LogStr x) = putInt (1 :: Word8) >> putText x
|
|
||||||
|
|
||||||
instance Serialize Trace where
|
|
||||||
get = do
|
|
||||||
tracePosition <- (\case 0 -> Nothing; x -> Just x) <$> getInt @Int
|
|
||||||
traceHint <- get
|
|
||||||
pure Trace{..}
|
|
||||||
put Trace{..} = do
|
|
||||||
maybe (putInt @Int 0) putInt $ tracePosition
|
|
||||||
put traceHint
|
|
||||||
|
|
||||||
instance Serialize BasicError where
|
|
||||||
get = do
|
|
||||||
basicErrorMessage <- get
|
|
||||||
basicErrorExitStatus <- getInt
|
|
||||||
pure BasicError{..}
|
|
||||||
put BasicError{..} = do
|
|
||||||
put basicErrorMessage
|
|
||||||
putInt basicErrorExitStatus
|
|
||||||
|
|
||||||
instance Serialize ErrorInfo where
|
|
||||||
get = do
|
|
||||||
etyp <- get @Text
|
|
||||||
Control.Monad.unless (etyp == Data.Text.pack "Error")
|
|
||||||
$ fail
|
|
||||||
$ "get ErrorInfo: received unknown error type" ++ show etyp
|
|
||||||
errorInfoLevel <- get
|
|
||||||
_name <- get @Text -- removed error name
|
|
||||||
errorInfoMessage <- get
|
|
||||||
errorInfoPosition <- (\case 0 -> Nothing; x -> Just x) <$> getInt @Int
|
|
||||||
errorInfoTraces <- getMany get
|
|
||||||
pure ErrorInfo{..}
|
|
||||||
put ErrorInfo{..} = do
|
|
||||||
put $ Data.Text.pack "Error"
|
|
||||||
put errorInfoLevel
|
|
||||||
put $ Data.Text.pack "Error" -- removed error name
|
|
||||||
put errorInfoMessage
|
|
||||||
maybe (putInt @Int 0) putInt $ errorInfoPosition
|
|
||||||
putMany put errorInfoTraces
|
|
||||||
|
|
||||||
instance Serialize LoggerOpCode where
|
|
||||||
get = getInt >>= either fail pure . word64ToLoggerOpCode
|
|
||||||
put = putInt . loggerOpCodeToWord64
|
|
||||||
|
|
||||||
instance Serialize Verbosity where
|
|
||||||
get = getEnum
|
|
||||||
put = putEnum
|
|
@ -1,215 +0,0 @@
|
|||||||
{-|
|
|
||||||
Description : Nix-like serialization primitives
|
|
||||||
Maintainer : srk <srk@48.io>
|
|
||||||
|-}
|
|
||||||
module System.Nix.Store.Remote.Serialize.Prim where
|
|
||||||
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.Fixed (Uni)
|
|
||||||
import Data.HashSet (HashSet)
|
|
||||||
import Data.Serialize.Get (Get)
|
|
||||||
import Data.Serialize.Put (Putter)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Time (NominalDiffTime, UTCTime)
|
|
||||||
import Data.Word (Word8)
|
|
||||||
import System.Nix.StorePath (StoreDir, StorePath, InvalidPathError)
|
|
||||||
|
|
||||||
import qualified Control.Monad
|
|
||||||
import qualified Data.Either
|
|
||||||
import qualified Data.HashSet
|
|
||||||
import qualified Data.Serialize.Get
|
|
||||||
import qualified Data.Serialize.Put
|
|
||||||
import qualified Data.ByteString
|
|
||||||
import qualified Data.Text.Encoding
|
|
||||||
import qualified Data.Time.Clock.POSIX
|
|
||||||
import qualified System.Nix.StorePath
|
|
||||||
|
|
||||||
-- * Int
|
|
||||||
|
|
||||||
-- | Deserialize Nix like integer
|
|
||||||
getInt :: Integral a => Get a
|
|
||||||
getInt = fromIntegral <$> Data.Serialize.Get.getWord64le
|
|
||||||
|
|
||||||
-- | Serialize Nix like integer
|
|
||||||
putInt :: Integral a => Putter a
|
|
||||||
putInt = Data.Serialize.Put.putWord64le . fromIntegral
|
|
||||||
|
|
||||||
-- * Bool
|
|
||||||
|
|
||||||
-- | Deserialize @Bool@ from integer
|
|
||||||
getBool :: Get Bool
|
|
||||||
getBool = (getInt :: Get Word8) >>= \case
|
|
||||||
0 -> pure False
|
|
||||||
1 -> pure True
|
|
||||||
x -> fail $ "illegal bool value " ++ show x
|
|
||||||
|
|
||||||
-- | Serialize @Bool@ into integer
|
|
||||||
putBool :: Putter Bool
|
|
||||||
putBool True = putInt (1 :: Int)
|
|
||||||
putBool False = putInt (0 :: Int)
|
|
||||||
|
|
||||||
-- * Enum
|
|
||||||
|
|
||||||
-- | Utility toEnum version checking bounds using Bounded class
|
|
||||||
toEnumCheckBounds :: Enum a => Int -> Either String a
|
|
||||||
toEnumCheckBounds = \case
|
|
||||||
x | x < minBound -> Left $ "enum out of min bound " ++ show x
|
|
||||||
x | x > maxBound -> Left $ "enum out of max bound " ++ show x
|
|
||||||
x | otherwise -> Right $ toEnum x
|
|
||||||
|
|
||||||
-- | Deserialize @Enum@ to integer
|
|
||||||
getEnum :: Enum a => Get a
|
|
||||||
getEnum =
|
|
||||||
toEnumCheckBounds <$> getInt
|
|
||||||
>>= either fail pure
|
|
||||||
|
|
||||||
-- | Serialize @Enum@ to integer
|
|
||||||
putEnum :: Enum a => Putter a
|
|
||||||
putEnum = putInt . fromEnum
|
|
||||||
|
|
||||||
-- * UTCTime
|
|
||||||
|
|
||||||
-- | Deserialize @UTCTime@ from integer
|
|
||||||
-- Only 1 second precision.
|
|
||||||
getTime :: Get UTCTime
|
|
||||||
getTime =
|
|
||||||
Data.Time.Clock.POSIX.posixSecondsToUTCTime
|
|
||||||
. seconds
|
|
||||||
<$> getInt
|
|
||||||
where
|
|
||||||
-- fancy (*10^12), from Int to Uni to Pico(seconds)
|
|
||||||
seconds :: Int -> NominalDiffTime
|
|
||||||
seconds n = realToFrac (toEnum n :: Uni)
|
|
||||||
|
|
||||||
-- | Serialize @UTCTime@ to integer
|
|
||||||
-- Only 1 second precision.
|
|
||||||
putTime :: Putter UTCTime
|
|
||||||
putTime =
|
|
||||||
putInt
|
|
||||||
. seconds
|
|
||||||
. Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds
|
|
||||||
where
|
|
||||||
-- fancy (`div`10^12), from Pico to Uni to Int
|
|
||||||
seconds :: NominalDiffTime -> Int
|
|
||||||
seconds = (fromEnum :: Uni -> Int) . realToFrac
|
|
||||||
|
|
||||||
-- * Combinators
|
|
||||||
|
|
||||||
-- | Deserialize a list
|
|
||||||
getMany :: Get a -> Get [a]
|
|
||||||
getMany parser = do
|
|
||||||
count <- getInt
|
|
||||||
Control.Monad.replicateM count parser
|
|
||||||
|
|
||||||
-- | Serialize a list
|
|
||||||
putMany :: Foldable t => Putter a -> Putter (t a)
|
|
||||||
putMany printer xs = do
|
|
||||||
putInt (length xs)
|
|
||||||
mapM_ printer xs
|
|
||||||
|
|
||||||
-- * ByteString
|
|
||||||
|
|
||||||
-- | Deserialize length prefixed string
|
|
||||||
-- into @ByteString@, checking for correct padding
|
|
||||||
getByteString :: Get ByteString
|
|
||||||
getByteString = do
|
|
||||||
len <- getInt
|
|
||||||
st <- Data.Serialize.Get.getByteString len
|
|
||||||
Control.Monad.when (len `mod` 8 /= 0) $ do
|
|
||||||
pads <- unpad $ fromIntegral $ 8 - (len `mod` 8)
|
|
||||||
Control.Monad.unless
|
|
||||||
(all (== 0) pads)
|
|
||||||
$ fail $ "No zeroes" <> show (st, len, pads)
|
|
||||||
pure st
|
|
||||||
where unpad x = Control.Monad.replicateM x Data.Serialize.Get.getWord8
|
|
||||||
|
|
||||||
-- | Serialize @ByteString@ using length
|
|
||||||
-- prefixed string packing with padding to 8 bytes
|
|
||||||
putByteString :: Putter ByteString
|
|
||||||
putByteString x = do
|
|
||||||
putInt len
|
|
||||||
Data.Serialize.Put.putByteString x
|
|
||||||
Control.Monad.when
|
|
||||||
(len `mod` 8 /= 0)
|
|
||||||
$ pad $ 8 - (len `mod` 8)
|
|
||||||
where
|
|
||||||
len :: Int
|
|
||||||
len = fromIntegral $ Data.ByteString.length x
|
|
||||||
pad count = Control.Monad.replicateM_ count (Data.Serialize.Put.putWord8 0)
|
|
||||||
|
|
||||||
-- | Deserialize a list of @ByteString@s
|
|
||||||
getByteStrings :: Get [ByteString]
|
|
||||||
getByteStrings = getMany getByteString
|
|
||||||
|
|
||||||
-- | Serialize a list of @ByteString@s
|
|
||||||
putByteStrings :: Foldable t => Putter (t ByteString)
|
|
||||||
putByteStrings = putMany putByteString
|
|
||||||
|
|
||||||
-- * Text
|
|
||||||
|
|
||||||
-- | Deserialize @Text@
|
|
||||||
getText :: Get Text
|
|
||||||
getText = Data.Text.Encoding.decodeUtf8 <$> getByteString
|
|
||||||
|
|
||||||
-- | Serialize @Text@
|
|
||||||
putText :: Putter Text
|
|
||||||
putText = putByteString . Data.Text.Encoding.encodeUtf8
|
|
||||||
|
|
||||||
-- | Deserialize a list of @Text@s
|
|
||||||
getTexts :: Get [Text]
|
|
||||||
getTexts = fmap Data.Text.Encoding.decodeUtf8 <$> getByteStrings
|
|
||||||
|
|
||||||
-- | Serialize a list of @Text@s
|
|
||||||
putTexts :: (Functor f, Foldable f) => Putter (f Text)
|
|
||||||
putTexts = putByteStrings . fmap Data.Text.Encoding.encodeUtf8
|
|
||||||
|
|
||||||
-- * StorePath
|
|
||||||
|
|
||||||
-- | Deserialize @StorePath@, checking
|
|
||||||
-- that @StoreDir@ matches expected value
|
|
||||||
getPath :: StoreDir -> Get (Either InvalidPathError StorePath)
|
|
||||||
getPath sd =
|
|
||||||
System.Nix.StorePath.parsePath sd <$> getByteString
|
|
||||||
|
|
||||||
-- | Deserialize @StorePath@, checking
|
|
||||||
-- that @StoreDir@ matches expected value
|
|
||||||
getPathOrFail :: StoreDir -> Get StorePath
|
|
||||||
getPathOrFail sd =
|
|
||||||
getPath sd
|
|
||||||
>>= either
|
|
||||||
(fail . show)
|
|
||||||
pure
|
|
||||||
|
|
||||||
-- | Serialize @StorePath@ with its associated @StoreDir@
|
|
||||||
putPath :: StoreDir -> Putter StorePath
|
|
||||||
putPath storeDir =
|
|
||||||
putByteString
|
|
||||||
. System.Nix.StorePath.storePathToRawFilePath storeDir
|
|
||||||
|
|
||||||
-- | Deserialize a @HashSet@ of @StorePath@s
|
|
||||||
getPaths :: StoreDir -> Get (HashSet (Either InvalidPathError StorePath))
|
|
||||||
getPaths sd =
|
|
||||||
Data.HashSet.fromList
|
|
||||||
. fmap (System.Nix.StorePath.parsePath sd)
|
|
||||||
<$> getByteStrings
|
|
||||||
|
|
||||||
-- | Deserialize @StorePath@, checking
|
|
||||||
-- that @StoreDir@ matches expected value
|
|
||||||
getPathsOrFail :: StoreDir -> Get (HashSet StorePath)
|
|
||||||
getPathsOrFail sd = do
|
|
||||||
eps <-
|
|
||||||
fmap (System.Nix.StorePath.parsePath sd)
|
|
||||||
<$> getByteStrings
|
|
||||||
Control.Monad.when (any Data.Either.isLeft eps)
|
|
||||||
$ fail
|
|
||||||
$ show
|
|
||||||
$ Data.Either.lefts eps
|
|
||||||
pure $ Data.HashSet.fromList $ Data.Either.rights eps
|
|
||||||
|
|
||||||
-- | Serialize a @HashSet@ of @StorePath@s
|
|
||||||
putPaths :: StoreDir -> Putter (HashSet StorePath)
|
|
||||||
putPaths storeDir =
|
|
||||||
putByteStrings
|
|
||||||
. Data.HashSet.toList
|
|
||||||
. Data.HashSet.map
|
|
||||||
(System.Nix.StorePath.storePathToRawFilePath storeDir)
|
|
@ -1,97 +0,0 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module SerializeSpec (spec) where
|
|
||||||
|
|
||||||
import Data.Serialize (Serialize(..))
|
|
||||||
import Data.Serialize.Get (Get, runGet)
|
|
||||||
import Data.Serialize.Put (Putter, runPut)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Test.Hspec (Expectation, Spec, describe, parallel)
|
|
||||||
import Test.Hspec.QuickCheck (prop)
|
|
||||||
import Test.Hspec.Nix (roundtrips)
|
|
||||||
|
|
||||||
import qualified Data.Either
|
|
||||||
import qualified Data.HashSet
|
|
||||||
|
|
||||||
import System.Nix.Arbitrary ()
|
|
||||||
import System.Nix.Build (BuildMode(..), BuildStatus(..))
|
|
||||||
import System.Nix.Derivation (Derivation(inputDrvs))
|
|
||||||
import System.Nix.Store.Remote.Arbitrary ()
|
|
||||||
import System.Nix.Store.Remote.Serialize (getDerivation, putDerivation)
|
|
||||||
import System.Nix.Store.Remote.Serialize.Prim
|
|
||||||
import System.Nix.Store.Remote.Types
|
|
||||||
|
|
||||||
-- | Test for roundtrip using @Putter@ and @Get@ functions
|
|
||||||
roundtrips2
|
|
||||||
:: ( Eq a
|
|
||||||
, Show a
|
|
||||||
)
|
|
||||||
=> Putter a
|
|
||||||
-> Get a
|
|
||||||
-> a
|
|
||||||
-> Expectation
|
|
||||||
roundtrips2 putter getter =
|
|
||||||
roundtrips
|
|
||||||
(runPut . putter)
|
|
||||||
(runGet getter)
|
|
||||||
|
|
||||||
-- | Test for roundtrip using @Serialize@ instance
|
|
||||||
roundtripS
|
|
||||||
:: ( Eq a
|
|
||||||
, Serialize a
|
|
||||||
, Show a
|
|
||||||
)
|
|
||||||
=> a
|
|
||||||
-> Expectation
|
|
||||||
roundtripS =
|
|
||||||
roundtrips
|
|
||||||
(runPut . put)
|
|
||||||
(runGet get)
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = parallel $ do
|
|
||||||
describe "Prim" $ do
|
|
||||||
prop "Int" $ roundtrips2 putInt (getInt @Int)
|
|
||||||
prop "Bool" $ roundtrips2 putBool getBool
|
|
||||||
prop "ByteString" $ roundtrips2 putByteString getByteString
|
|
||||||
|
|
||||||
describe "Combinators" $ do
|
|
||||||
prop "Many" $ roundtrips2 (putMany putInt) (getMany (getInt @Int))
|
|
||||||
prop "[ByteString]" $ roundtrips2 putByteStrings getByteStrings
|
|
||||||
prop "Text" $ roundtrips2 putText getText
|
|
||||||
prop "[Text]" $ roundtrips2 putTexts getTexts
|
|
||||||
|
|
||||||
prop "StorePath" $ \sd ->
|
|
||||||
roundtrips2
|
|
||||||
(putPath sd)
|
|
||||||
(Data.Either.fromRight undefined <$> getPath sd)
|
|
||||||
|
|
||||||
prop "HashSet StorePath" $ \sd ->
|
|
||||||
roundtrips2
|
|
||||||
(putPaths sd)
|
|
||||||
(Data.HashSet.map (Data.Either.fromRight undefined) <$> getPaths sd)
|
|
||||||
|
|
||||||
describe "Serialize instances" $ do
|
|
||||||
prop "Text" $ roundtripS @Text
|
|
||||||
prop "BuildMode" $ roundtripS @BuildMode
|
|
||||||
prop "BuildStatus" $ roundtripS @BuildStatus
|
|
||||||
|
|
||||||
prop "ProtoVersion" $ roundtripS @ProtoVersion
|
|
||||||
|
|
||||||
prop "Derivation StorePath Text" $ \sd ->
|
|
||||||
roundtrips2
|
|
||||||
(putDerivation sd)
|
|
||||||
(getDerivation sd)
|
|
||||||
-- inputDrvs is not used in remote protocol serialization
|
|
||||||
. (\drv -> drv { inputDrvs = mempty })
|
|
||||||
|
|
||||||
describe "Logger" $ do
|
|
||||||
prop "Activity" $ roundtripS @Activity
|
|
||||||
prop "ActivityID" $ roundtripS @ActivityID
|
|
||||||
prop "Activity" $ roundtripS @Activity
|
|
||||||
prop "Field" $ roundtripS @Field
|
|
||||||
prop "Trace" $ roundtripS @Trace
|
|
||||||
prop "BasicError" $ roundtripS @BasicError
|
|
||||||
prop "ErrorInfo" $ roundtripS @ErrorInfo
|
|
||||||
prop "LoggerOpCode" $ roundtripS @LoggerOpCode
|
|
||||||
prop "Verbosity" $ roundtripS @Verbosity
|
|
Loading…
Reference in New Issue
Block a user