Cabal/src/Distribution/Utils/Structured.hs

   1 {-# LANGUAGE CPP                 #-}
   2 {-# LANGUAGE DefaultSignatures   #-}
   3 {-# LANGUAGE DeriveGeneric       #-}
   4 {-# LANGUAGE FlexibleContexts    #-}
   5 {-# LANGUAGE PolyKinds           #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE TypeFamilies        #-}
   8 {-# LANGUAGE TypeOperators       #-}
   9 #if __GLASGOW_HASKELL__ >= 711
  10 {-# LANGUAGE PatternSynonyms     #-}
  11 #endif
  12 #if __GLASGOW_HASKELL__ >= 800
  13 {-# LANGUAGE TypeInType          #-}
  14 #endif
  15 -- |
  16 --
  17 -- Copyright: (c) 2019 Oleg Grenrus
  18 --
  19 -- Structurally tag binary serialisaton stream.
  20 -- Useful when most 'Binary' instances are 'Generic' derived.
  21 --
  22 -- Say you have a data type
  23 --
  24 -- @
  25 -- data Record = Record
  26 --   { _recordFields  :: HM.HashMap Text (Integer, ByteString)
  27 --   , _recordEnabled :: Bool
  28 --   }
  29 --   deriving (Eq, Show, Generic)
  30 --
  31 -- instance 'Binary' Record
  32 -- instance 'Structured' Record
  33 -- @
  34 --
  35 -- then you can serialise and deserialise @Record@ values with a structure tag by simply
  36 --
  37 -- @
  38 -- 'structuredEncode' record :: 'LBS.ByteString'
  39 -- 'structuredDecode' lbs :: IO Record
  40 -- @
  41 --
  42 -- If structure of @Record@ changes in between, deserialisation will fail early.
  43 --
  44 -- Technically, 'Structured' is not related to 'Binary', and may
  45 -- be useful in other uses.
  46 --
  47 module Distribution.Utils.Structured (
  48     -- * Encoding and decoding
  49     -- | These functions operate like @binary@'s counterparts,
  50     -- but the serialised version has a structure hash in front.
  51     structuredEncode,
  52     structuredEncodeFile,
  53     structuredDecode,
  54     structuredDecodeOrFailIO,
  55     structuredDecodeFileOrFail,
  56     structuredDecodeTriple,
  57     -- * Structured class
  58     Structured (structure),
  59     MD5,
  60     structureHash,
  61     structureBuilder,
  62     genericStructure,
  63     GStructured,
  64     nominalStructure,
  65     containerStructure,
  66     -- * Structure type
  67     Structure (..),
  68     TypeName,
  69     ConstructorName,
  70     TypeVersion,
  71     SopStructure,
  72     hashStructure,
  73     typeVersion,
  74     typeName,
  75     ) where
  76
  77 import Data.Int           (Int16, Int32, Int64, Int8)
  78 import Data.List.NonEmpty (NonEmpty)
  79 import Data.Proxy         (Proxy (..))
  80 import Data.Ratio         (Ratio)
  81 import Data.Word          (Word, Word16, Word32, Word64, Word8)
  82
  83 import qualified Control.Monad.Trans.State.Strict as State
  84
  85 import Control.Exception (ErrorCall (..), catch, evaluate)
  86
  87 import GHC.Generics
  88
  89 import qualified Data.ByteString              as BS
  90 import qualified Data.ByteString.Lazy         as LBS
  91 #if MIN_VERSION_bytestring(0,10,4)
  92 import qualified Data.ByteString.Builder      as Builder
  93 #else
  94 import qualified Data.ByteString.Lazy.Builder as Builder
  95 #endif
  96 import qualified Data.IntMap                  as IM
  97 import qualified Data.IntSet                  as IS
  98 import qualified Data.Map                     as Map
  99 import qualified Data.Sequence                as Seq
 100 import qualified Data.Set                     as Set
 101 import qualified Data.Text                    as T
 102 import qualified Data.Text.Lazy               as LT
 103 import qualified Data.Time                    as Time
 104 import qualified Distribution.Compat.Binary   as Binary
 105 import Data.Binary.Get (runGetOrFail)
 106
 107 #ifdef MIN_VERSION_aeson
 108 import qualified Data.Aeson as Aeson
 109 #endif
 110
 111 #if __GLASGOW_HASKELL__ >= 800
 112 import Data.Kind (Type)
 113 #else
 114 #define Type *
 115 #endif
 116
 117 import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep)
 118 import Distribution.Utils.MD5
 119
 120 import Data.Monoid (mconcat)
 121
 122 import qualified Data.Semigroup
 123 import qualified Data.Foldable
 124
 125 #if !MIN_VERSION_base(4,8,0)
 126 import Control.Applicative (pure)
 127 import Data.Traversable (traverse)
 128 #endif
 129
 130 #if !MIN_VERSION_base(4,7,0)
 131 import Data.Typeable (Typeable1, typeOf1)
 132 #endif
 133
 134
 135 -------------------------------------------------------------------------------
 136 -- Types
 137 -------------------------------------------------------------------------------
 138
 139 type TypeName        = String
 140 type ConstructorName = String
 141
 142 -- | A sematic version of a data type. Usually 0.
 143 type TypeVersion     = Word32
 144
 145 -- | Structure of a datatype.
 146 --
 147 -- It can be infinite, as far as 'TypeRep's involved are finite.
 148 -- (e.g. polymorphic recursion might cause troubles).
 149 --
 150 data Structure
 151     = Nominal   !TypeRep !TypeVersion TypeName [Structure]  -- ^ nominal, yet can be parametrised by other structures.
 152     | Newtype   !TypeRep !TypeVersion TypeName Structure    -- ^ a newtype wrapper
 153     | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure
 154   deriving (Eq, Ord, Show, Generic)
 155
 156 type SopStructure = [(ConstructorName, [Structure])]
 157
 158 -- | A MD5 hash digest of 'Structure'.
 159 hashStructure :: Structure -> MD5
 160 hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder
 161
 162 -- | A van-Laarhoven lens into 'TypeVersion' of 'Structure'
 163 --
 164 -- @
 165 -- 'typeVersion' :: Lens' 'Structure' 'TypeVersion'
 166 -- @
 167 typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure
 168 typeVersion f (Nominal   t v n s) = fmap (\v' -> Nominal   t v' n s) (f v)
 169 typeVersion f (Newtype   t v n s) = fmap (\v' -> Newtype   t v' n s) (f v)
 170 typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v)
 171
 172 -- | A van-Laarhoven lens into 'TypeName' of 'Structure'
 173 --
 174 -- @
 175 -- 'typeName' :: Lens' 'Structure' 'TypeName'
 176 -- @
 177 typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure
 178 typeName f (Nominal   t v n s) = fmap (\n' -> Nominal   t v n' s) (f n)
 179 typeName f (Newtype   t v n s) = fmap (\n' -> Newtype   t v n' s) (f n)
 180 typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n)
 181
 182 -------------------------------------------------------------------------------
 183 -- Builder
 184 -------------------------------------------------------------------------------
 185
 186 -- | Flatten 'Structure' into something we can calculate hash of.
 187 --
 188 -- As 'Structure' can be potentially infinite. For mutually recursive types,
 189 -- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred
 190 -- another time.
 191 structureBuilder :: Structure -> Builder.Builder
 192 structureBuilder s0 = State.evalState (go s0) Map.empty where
 193     go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder
 194     go (Nominal   t v n s) = withTypeRep t $ do
 195         s' <- traverse go s
 196         return $ mconcat $ Builder.word8 1 : Builder.word32LE v :  Builder.stringUtf8 n : s'
 197
 198     go (Newtype   t v n s) = withTypeRep t $ do
 199         s' <- go s
 200         return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s']
 201
 202     go (Structure t v n s) = withTypeRep t $ do
 203         s' <- goSop s
 204         return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s']
 205
 206     withTypeRep t k = do
 207         acc <- State.get
 208         case insert t acc of
 209             Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ]
 210             Just acc' -> do
 211                 State.put acc'
 212                 k
 213
 214     goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder
 215     goSop sop = do
 216         parts <- traverse part sop
 217         return $ mconcat parts
 218
 219     part (cn, s) = do
 220         s' <- traverse go s
 221         return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ]
 222
 223     insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep))
 224     insert tr m = case Map.lookup trShown m of
 225         Nothing                              -> inserted
 226         Just ne | tr `Data.Foldable.elem` ne -> Nothing
 227                 | otherwise                  -> inserted
 228       where
 229         inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m)
 230         trShown  = show tr
 231
 232 -------------------------------------------------------------------------------
 233 -- Classes
 234 -------------------------------------------------------------------------------
 235
 236 -- | Class of types with a known 'Structure'.
 237 --
 238 -- For regular data types 'Structured' can be derived generically.
 239 --
 240 -- @
 241 -- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic')
 242 -- instance 'Structured' Record
 243 -- @
 244 --
 245 -- @since 3.2.0.0
 246 --
 247 class Typeable a => Structured a where
 248     structure :: Proxy a -> Structure
 249     default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure
 250     structure = genericStructure
 251
 252     -- This member is hidden. It's there to precalc
 253     structureHash' :: Tagged a MD5
 254     structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a)))
 255
 256 -- private Tagged
 257 newtype Tagged a b = Tagged { untag :: b }
 258
 259 -- | Semantically @'hashStructure' . 'structure'@.
 260 structureHash :: forall a. Structured a => Proxy a -> MD5
 261 structureHash _ = untag (structureHash' :: Tagged a MD5)
 262
 263 -------------------------------------------------------------------------------
 264 -- Functions
 265 -------------------------------------------------------------------------------
 266
 267 -- | Structured 'Binary.encode'.
 268 -- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'.
 269 -- Encoding starts with 16 byte large structure hash.
 270 structuredEncode
 271   :: forall a. (Binary.Binary a, Structured a)
 272   => a -> LBS.ByteString
 273 structuredEncode x = Binary.encode (Tag :: Tag a, x)
 274
 275 -- | Lazily serialise a value to a file
 276 structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO ()
 277 structuredEncodeFile f = LBS.writeFile f . structuredEncode
 278
 279 -- | Structured 'Binary.decode'.
 280 -- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure.
 281 -- Throws pure exception on invalid inputs.
 282 structuredDecode
 283   :: forall a. (Binary.Binary a, Structured a)
 284   => LBS.ByteString -> a
 285 structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a))
 286
 287 structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a)
 288 structuredDecodeOrFailIO bs =
 289     catch (evaluate (structuredDecode bs) >>= return . Right) handler
 290   where
 291 #if MIN_VERSION_base(4,9,0)
 292     handler (ErrorCallWithLocation str _) = return $ Left str
 293 #else
 294     handler (ErrorCall str) = return $ Left str
 295 #endif
 296
 297 -- | Lazily decode a triple, parsing the first two fields strictly and returning a lazy value containing either the last one or an error.
 298 -- This is helpful for cabal cache files where the first two components contain header data that lets one test if the cache is still valid,
 299 -- and the last (potentially large) component is the cached value itself. This way we can test for cache validity without needing to pay the cost
 300 -- of the decode of stale cache data.
 301 structuredDecodeTriple
 302   :: forall a b c. (Structured (a,b,c), Binary.Binary a, Binary.Binary b, Binary.Binary c)
 303   => LBS.ByteString -> Either String (a, b, Either String c)
 304 structuredDecodeTriple lbs =
 305   let partialDecode =
 306            (`runGetOrFail` lbs) $ do
 307               (_ :: Tag (a,b,c)) <- Binary.get
 308               (a :: a) <- Binary.get
 309               (b :: b) <- Binary.get
 310               pure (a, b)
 311       cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg)
 312       cleanEither (Right (_,_,v))     = Right v
 313
 314   in case partialDecode of
 315        Left (_, pos, msg) ->  Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg)
 316        Right (lbs', _, (x,y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs')
 317
 318
 319 -- | Lazily reconstruct a value previously written to a file.
 320 structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a)
 321 structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f
 322
 323 -------------------------------------------------------------------------------
 324 -- Helper data
 325 -------------------------------------------------------------------------------
 326
 327 data Tag a = Tag
 328
 329 instance Structured a => Binary.Binary (Tag a) where
 330     get = do
 331         actual <- binaryGetMD5
 332         if actual == expected
 333         then return Tag
 334         else fail $ concat
 335             [ "Non-matching structured hashes: "
 336             , showMD5 actual
 337             , "; expected: "
 338             , showMD5 expected
 339             ]
 340       where
 341         expected = untag (structureHash' :: Tagged a MD5)
 342
 343     put _ = binaryPutMD5 expected
 344       where
 345         expected = untag (structureHash' :: Tagged a MD5)
 346
 347 -------------------------------------------------------------------------------
 348 -- Smart constructors
 349 -------------------------------------------------------------------------------
 350
 351 -- | Use 'Typeable' to infer name
 352 nominalStructure :: Typeable a => Proxy a -> Structure
 353 nominalStructure p = Nominal tr 0 (show tr) [] where
 354     tr = typeRep p
 355
 356 #if MIN_VERSION_base(4,7,0)
 357 containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure
 358 containerStructure _ = Nominal faTypeRep 0 (show fTypeRep)
 359     [ structure (Proxy :: Proxy a)
 360     ]
 361   where
 362     fTypeRep  = typeRep (Proxy :: Proxy f)
 363     faTypeRep = typeRep (Proxy :: Proxy (f a))
 364
 365 #else
 366 containerStructure :: forall f a. (Typeable1 f, Structured a) => Proxy (f a) -> Structure
 367 containerStructure _ = Nominal faTypeRep 0 (show fTypeRep)
 368     [ structure (Proxy :: Proxy a)
 369     ]
 370   where
 371     fTypeRep  = typeOf1 (undefined :: f ())
 372     faTypeRep = typeRep (Proxy :: Proxy (f a))
 373 #endif
 374
 375 -------------------------------------------------------------------------------
 376 -- Generic
 377 -------------------------------------------------------------------------------
 378
 379 -- | Derive 'structure' genrically.
 380 genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure
 381 genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0
 382
 383 -- | Used to implement 'genericStructure'.
 384 class GStructured (f :: Type -> Type) where
 385     gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure
 386
 387 instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where
 388     gstructured tr _ v = case sop of
 389 #if MIN_VERSION_base(4,7,0)
 390         [(_, [s])] | isNewtype p -> Newtype tr v name s
 391 #endif
 392         _                        -> Structure tr v name sop
 393       where
 394         p    = undefined :: M1 i c f ()
 395         name = datatypeName p
 396         sop  = gstructuredSum (Proxy :: Proxy f) []
 397
 398 class GStructuredSum (f :: Type -> Type) where
 399     gstructuredSum :: Proxy f -> SopStructure -> SopStructure
 400
 401 instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where
 402     gstructuredSum _ xs = (name, prod) : xs
 403       where
 404         name = conName (undefined :: M1 i c f ())
 405         prod = gstructuredProd (Proxy :: Proxy f) []
 406
 407 instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where
 408     gstructuredSum _ xs
 409         = gstructuredSum (Proxy :: Proxy f)
 410         $ gstructuredSum (Proxy :: Proxy g) xs
 411
 412 instance GStructuredSum V1 where
 413     gstructuredSum _ = id
 414
 415 class GStructuredProd (f :: Type -> Type) where
 416     gstructuredProd :: Proxy f -> [Structure] -> [Structure]
 417
 418 instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where
 419     gstructuredProd _ = gstructuredProd (Proxy :: Proxy f)
 420
 421 instance Structured c => GStructuredProd (K1 i c) where
 422     gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs
 423
 424 instance GStructuredProd U1 where
 425     gstructuredProd _ = id
 426
 427 instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where
 428     gstructuredProd _ xs
 429         = gstructuredProd (Proxy :: Proxy f)
 430         $ gstructuredProd (Proxy :: Proxy g) xs
 431
 432 -------------------------------------------------------------------------------
 433 -- instances
 434 -------------------------------------------------------------------------------
 435
 436 instance Structured ()
 437 instance Structured Bool
 438 instance Structured Ordering
 439
 440 instance Structured Char    where structure = nominalStructure
 441 instance Structured Int     where structure = nominalStructure
 442 instance Structured Integer where structure = nominalStructure
 443
 444 instance Structured Data.Word.Word where structure = nominalStructure
 445
 446 instance Structured Int8  where structure = nominalStructure
 447 instance Structured Int16 where structure = nominalStructure
 448 instance Structured Int32 where structure = nominalStructure
 449 instance Structured Int64 where structure = nominalStructure
 450
 451 instance Structured Word8  where structure = nominalStructure
 452 instance Structured Word16 where structure = nominalStructure
 453 instance Structured Word32 where structure = nominalStructure
 454 instance Structured Word64 where structure = nominalStructure
 455
 456 instance Structured Float  where structure = nominalStructure
 457 instance Structured Double where structure = nominalStructure
 458
 459 instance Structured a => Structured (Maybe a)
 460 instance (Structured a, Structured b) => Structured (Either a b)
 461 instance Structured a => Structured (Ratio a) where structure = containerStructure
 462 instance Structured a => Structured [a] where structure = containerStructure
 463 instance Structured a => Structured (NonEmpty a) where structure = containerStructure
 464
 465 instance (Structured a1, Structured a2) => Structured (a1, a2)
 466 instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3)
 467 instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4)
 468 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5)
 469 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6)
 470 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7)
 471
 472 instance Structured BS.ByteString where structure = nominalStructure
 473 instance Structured LBS.ByteString where structure = nominalStructure
 474
 475 instance Structured T.Text where structure = nominalStructure
 476 instance Structured LT.Text where structure = nominalStructure
 477
 478 instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ]
 479 instance (Structured k) => Structured (Set.Set k) where structure = containerStructure
 480 instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure
 481 instance Structured IS.IntSet where structure = nominalStructure
 482 instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure
 483
 484 instance Structured Time.UTCTime         where structure = nominalStructure
 485 instance Structured Time.DiffTime        where structure = nominalStructure
 486 instance Structured Time.UniversalTime   where structure = nominalStructure
 487 instance Structured Time.NominalDiffTime where structure = nominalStructure
 488 instance Structured Time.Day             where structure = nominalStructure
 489 instance Structured Time.TimeZone        where structure = nominalStructure
 490 instance Structured Time.TimeOfDay       where structure = nominalStructure
 491 instance Structured Time.LocalTime       where structure = nominalStructure
 492
 493 -- Proxy isn't Typeable in base-4.8 / base
 494
 495 -- #if __GLASGOW_HASKELL__ >= 800
 496 -- instance (Typeable k, Typeable (a :: k)) => Structured (Proxy a)
 497 -- #else
 498 -- instance (Typeable a) => Structured (Proxy a) where
 499 --     structure p = Structure (typeRep p) 0 "Proxy" [("Proxy",[])]
 500 -- #endif