summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Atomic.hs
blob: 096e51cb4bd1e17246808bff965736561cff9441 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}

module Propellor.Property.Atomic (
	atomicDirUpdate,
	atomicUpdate,
	atomicDirSync
) where

import Propellor.Base
import Propellor.Types.Core
import Propellor.Types.MetaTypes
import Propellor.EnsureProperty
import Propellor.Property.File
import Propellor.Property.Rsync (syncDir)

import System.Posix.Files

-- | A pair of resources, one active and one inactive, which can swap
-- positions atomically.
data AtomicResourcePair a = AtomicResourcePair
	{ activeAtomicResource :: a
	, inactiveAtomicResource :: a
	}

flipAtomicResourcePair :: AtomicResourcePair a -> AtomicResourcePair a
flipAtomicResourcePair a = AtomicResourcePair
	{ activeAtomicResource = inactiveAtomicResource a
	, inactiveAtomicResource = activeAtomicResource a
	}

-- | Action that activates the inactiveAtomicResource, and deactivates
-- the activeAtomicResource. This action must be fully atomic.
type SwapAtomicResourcePair a = AtomicResourcePair a -> Propellor ()

-- | Checks which of the pair of resources is currently active and
-- which is inactive, and puts them in the correct poisition in
-- the AtomicResourcePair.
type CheckAtomicResourcePair a = AtomicResourcePair a -> Propellor (AtomicResourcePair a)

-- | Makes a non-atomic Property be atomic, by applying it to the 
-- inactiveAtomicResource, and if it was successful,
-- atomically activating that resource.
atomicUpdate
	-- Constriaints inherited from ensureProperty.
	:: ( Cannot_ensureProperty_WithInfo t ~ 'True
	   , (Targets t `NotSuperset` Targets t) ~ 'CanCombine
	   )
	=> SingI t
	=> AtomicResourcePair a
	-> CheckAtomicResourcePair a
	-> SwapAtomicResourcePair a
	-> (a -> Property (MetaTypes t))
	-> Property (MetaTypes t)
atomicUpdate rbase rcheck rswap mkp = property' d $ \w -> do
	r <- rcheck rbase
	res <- ensureProperty w $ mkp $ inactiveAtomicResource r
	case res of
		FailedChange -> return FailedChange
		NoChange -> return NoChange
		MadeChange -> do
			rswap r
			return res
  where
	d = getDesc $ mkp $ activeAtomicResource rbase

-- | Applies a Property to a directory such that the directory is updated
-- fully atomically; there is no point in time in which the directory will
-- be in an inconsistent state.
--
-- For example, git repositories are not usually updated atomically,
-- and so while the repository is being updated, the files in it can be a
-- mixture of two different versions, which could cause unexpected
-- behavior to consumers. To avoid such problems:
--
-- >	& atomicDirUpdate "/srv/web/example.com"
-- >		(\d -> Git.pulled "joey" "http://.." d Nothing)
--
-- This operates by making a second copy of the directory, and passing it
-- to the Property, which can make whatever changes it needs to that copy,
-- non-atomically. After the Property successfully makes a change, the
-- copy is swapped into place, fully atomically.
--
-- This necessarily uses double the disk space of the directory, since its
-- copy is preserved. Note that the directory must not already exist,
-- or symlink creation will fail.
--
-- The parent directory will actually contain three children, a symlink
-- with the name of the directory itself, and two copies of the directory,
-- with names suffixed with ".1" and ".2"
atomicDirUpdate
	-- Constriaints inherited from ensureProperty.
	:: ( Cannot_ensureProperty_WithInfo t ~ 'True
	   , (Targets t `NotSuperset` Targets t) ~ 'CanCombine
	   )
	=> SingI t
	=> FilePath
	-> (FilePath -> Property (MetaTypes t))
	-> Property (MetaTypes t)
atomicDirUpdate d = atomicUpdate (mkDirLink d) (checkDirLink d) (swapDirLink d)

mkDirLink :: FilePath -> AtomicResourcePair FilePath
mkDirLink d = AtomicResourcePair
	{ activeAtomicResource = addext ".1"
	, inactiveAtomicResource = addext ".2"
	}
  where
	addext = addExtension (dropTrailingPathSeparator d)

inactiveLinkTarget :: AtomicResourcePair FilePath -> FilePath
inactiveLinkTarget = takeFileName . inactiveAtomicResource

swapDirLink :: FilePath -> SwapAtomicResourcePair FilePath
swapDirLink d rp = liftIO $ createSymbolicLink (inactiveLinkTarget rp)
	`viaStableTmp` d

checkDirLink :: FilePath -> CheckAtomicResourcePair FilePath
checkDirLink d rp = liftIO $ do
	v <- tryIO $ readSymbolicLink d
	return $ case v of
		Right t | t == inactiveLinkTarget rp ->
			flipAtomicResourcePair rp
		_ -> rp

-- | This can optionally be used after atomicDirUpdate to rsync the changes
-- that were made over to the other copy of the directory. It's not
-- necessary to use this, but it can improve efficiency.
--
-- For example:
--
-- >	& atomicDirUpdate "/srv/web/example.com"
-- >		(\d -> Git.pulled "joey" "http://.." d Nothing)
-- >		`onChange` atomicDirSync "/srv/web/example.com"
--
-- Using atomicDirSync in the above example lets git only download
-- the changes once, rather than the same changes being downloaded a second
-- time to update the other copy of the directory the next time propellor
-- runs.
atomicDirSync :: FilePath -> Property (DebianLike + ArchLinux)
atomicDirSync d = syncDir (activeAtomicResource rp) (inactiveAtomicResource rp)
  where
	rp = mkDirLink d