1-- -fno-cse is here because of anonymousNamedPrim - see the comments on that
2{-# OPTIONS_GHC -fno-cse #-}
3-- | Wrapper for prim patches to give them an identity derived from the identity
4-- of the containined Named patch.
5module Darcs.Patch.Prim.Named
6    ( NamedPrim
7    -- accessors
8    , PrimPatchId
9    , namedPrim
10    , positivePrimPatchIds
11    , anonymousNamedPrim
12    -- for testing
13    , unsafePrimPatchId
14    , prop_primPatchIdNonZero
15    ) where
16
17import Control.Monad ( mzero )
18
19import qualified Data.ByteString.Char8 as BC
20import qualified Data.ByteString.Lazy as BL
21
22import qualified Data.Binary as Binary
23import Crypto.Random ( getRandomBytes )
24import System.IO.Unsafe ( unsafePerformIO )
25
26import Darcs.Prelude hiding ( take )
27
28import Darcs.Patch.Ident ( PatchId, SignedId(..), StorableId(..) )
29import Darcs.Patch.Info ( PatchInfo, makePatchname )
30import Darcs.Patch.Prim.WithName ( PrimWithName(..) )
31import Darcs.Patch.Show ( ShowPatchFor(..) )
32
33import Darcs.Test.TestOnly
34import Darcs.Util.Hash ( SHA1, sha1Show, sha1Read )
35import Darcs.Util.Parser
36import Darcs.Util.Printer
37
38-- TODO [V3INTEGRATION]:
39-- Review whether we can use a PatchInfo directly here instead of a SHA1
40-- Unless we can use observable sharing, this might be significantly
41-- slower/less space efficient.
42-- | Signed patch identity.
43-- The 'SHA1' hash of the non-inverted meta data ('PatchInfo') plus an 'Int'
44-- for the sequence number within the named patch, starting with 1. The 'Int'
45-- gets inverted together with the patch and must never be 0 else we could not
46-- distinguish between the patch and its inverse.
47data PrimPatchId = PrimPatchId !Int !SHA1
48  deriving (Eq, Ord, Show)
49
50-- | This should only be used for testing, as it exposes the internal structure
51-- of a 'PrimPatchId'.
52unsafePrimPatchId :: TestOnly => Int -> SHA1 -> PrimPatchId
53unsafePrimPatchId = PrimPatchId
54
55prop_primPatchIdNonZero :: PrimPatchId -> Bool
56prop_primPatchIdNonZero (PrimPatchId i _) = i /= 0
57
58instance SignedId PrimPatchId where
59  positiveId (PrimPatchId i _) = i > 0
60  invertId (PrimPatchId i h) = PrimPatchId (- i) h
61
62-- | Create an infinite list of positive 'PrimPatchId's.
63positivePrimPatchIds :: PatchInfo -> [PrimPatchId]
64positivePrimPatchIds info = map (flip PrimPatchId (makePatchname info)) [1..]
65
66type NamedPrim = PrimWithName PrimPatchId
67
68namedPrim :: PrimPatchId -> p wX wY -> NamedPrim p wX wY
69namedPrim = PrimWithName
70
71type instance PatchId (NamedPrim p) = PrimPatchId
72
73-- TODO [V3INTEGRATION]:
74-- It might be nice to elide the patch identifiers from the
75-- on-disk format when they are the same as that of the containing patch
76-- (which is the common case when there are no conflicts).
77-- It's not that easy to implement as it requires refactoring to pass
78-- the patch identifier downwards.
79-- The sequence numbers could also be inferred from position.
80instance StorableId PrimPatchId where
81  readId = do
82    lexString (BC.pack "hash")
83    i <- int
84    skipSpace
85    x <- take 40
86    liftMaybe $ PrimPatchId i <$> sha1Read x
87   where
88     liftMaybe = maybe mzero return
89
90  showId ForStorage (PrimPatchId i h) =
91    text "hash" <+> text (show i) <+> packedString (sha1Show h)
92  showId ForDisplay _ = mempty
93
94-- Because we are using unsafePerformIO, we need -fno-cse for
95-- this module. We don't need -fno-full-laziness because the
96-- body of the unsafePerformIO mentions 'p' so can't float outside
97-- the scope of 'p'.
98-- http://hackage.haskell.org/package/base-4.12.0.0/docs/System-IO-Unsafe.html
99{-# NOINLINE anonymousNamedPrim #-}
100anonymousNamedPrim :: p wX wY -> NamedPrim p wX wY
101anonymousNamedPrim p =
102  unsafePerformIO $ do
103    b20 <- getRandomBytes 20
104    b8 <- getRandomBytes 8
105    return $
106      PrimWithName
107        (PrimPatchId
108           (abs (Binary.decode $ BL.fromStrict b8))
109           (Binary.decode $ BL.fromStrict b20))
110        p
111