summaryrefslogtreecommitdiff
path: root/Propellor/Property/Docker.hs
blob: 1f9917092876ec934f6fe2880f6fcf388fb18115 (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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
{-# LANGUAGE RankNTypes #-}

module Propellor.Property.Docker where

import Propellor
import Propellor.CmdLine
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Utility.SafeCommand

dockercmd :: String
dockercmd = "docker.io"

-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io.
configured :: Property
configured = Property "docker configured" go `requires` installed
  where
	go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ 
		"/root/.dockercfg" `File.hasContent` (lines cfg)

installed :: Property
installed = Apt.installed ["docker.io"]

-- | Parameters to pass to `docker run` when creating a container.
type RunParam = String

data Containerized a = Containerized [RunParam] a

getRunParams :: [Containerized a] -> [RunParam]
getRunParams l = concatMap get l
  where
	get (Containerized ps _) = ps

fromContainerized :: forall a. [Containerized a] -> [a]
fromContainerized l = map get l
  where
	get (Containerized _ a) = a

-- | A docker image, that can be used to run a container.
type Image = String

type ContainerName = String

-- | A container is identified by its name, and the host
-- on which it's deployed.
data ContainerId = ContainerId HostName ContainerName
	deriving (Read, Show, Eq)

toContainerId :: String -> Maybe ContainerId
toContainerId s = case separate (== '@') s of
	(cn, hn)
		| null hn || null cn -> Nothing
		| otherwise -> Just $ ContainerId hn cn

fromContainerId :: ContainerId -> String
fromContainerId (ContainerId hn cn) = cn++"@"++hn

data Container = Container Image [Containerized Property]

containerFromImage :: Image -> [Containerized Property] -> Container
containerFromImage = Container

containerProperties
	:: (HostName -> ContainerName -> Maybe (Container))
	-> (HostName -> Maybe [Property])
containerProperties findcontainer = \h -> case toContainerId h of
	Nothing -> Nothing
	Just (ContainerId hn cn) ->
		case findcontainer hn cn of
			Nothing -> Nothing
			Just (Container _ cprops) -> 
				Just $ fromContainerized cprops

-- | Ensures that a docker container is set up and running. The container
-- has its own Properties which are handled by running propellor
-- inside the container.
hasContainer
	:: HostName
	-> ContainerName
	-> (HostName -> ContainerName -> Maybe (Container))
	-> Property
hasContainer hn cn findcontainer =
	case findcontainer hn cn of
		Nothing -> Property desc $ do
			warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
			return FailedChange
		Just (Container image containerprops) ->
			running image containerprops
  where
  	cid = ContainerId hn cn

  	desc = "docker container " ++ fromContainerId cid

	-- Start the container, if it's not already running.
	running image containerprops = Property desc $ do
		let runps = getRunParams $ containerprops ++
			-- expose propellor directory inside the container
			[ volume (localdir++":"++localdir)
			-- name the container in a predictable way so we
			-- and the user can easily find it later
			, name (fromContainerId cid)
			-- cd to propellor directory
			, workdir localdir
			]
		let ident = ContainerIdent image cid runps
		let runit img = ifM (runContainer cid img runps ident)
			( do
				r <- runinside
				return $ MadeChange <> r
			, return FailedChange
			)
		l <- listRunningContainers
		if cid `elem` l
			then do
				runningident <- readish <$> readContainerCommand cid "cat" ["/.propeller-ident"]
				if runningident == Just ident
					then runinside
					else do
						void $ stopContainer cid
						oldimage <- fromMaybe image <$> commitContainer cid
						removeContainer cid
						runit oldimage
			else do
				removeContainer cid
				runit image

	-- Use propellor binary exposed inside the container
	-- (assumes libc compatablity), and run it, passing it the
	-- container@hostname so it knows what to do.
	-- Read its Result code and propigate
	runinside :: IO Result
	runinside = fromMaybe FailedChange . readish
		<$> readContainerCommand cid "./propellor" [show params]
	  where
	  	-- Using Continue avoids auto-update of the binary inside
		-- the container.
		params = Continue $ Run $ fromContainerId cid

-- | Two containers with the same ContainerIdent were started from
-- the same base image (possibly a different version though), and
-- with the same RunParams.
data ContainerIdent = ContainerIdent Image ContainerId [RunParam]
	deriving (Read, Show, Eq)

-- | The ContainerIdent of a container is written to
-- /.propeller-ident inside it. This can be checked to see if
-- the container has the same ident later.
propellerIdent :: FilePath
propellerIdent = "/.propeller-ident"

stopContainer :: ContainerId -> IO Bool
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]

removeContainer :: ContainerId -> IO ()
removeContainer cid = void $ boolSystem "sh"
	[Param "-c", Param $ dockercmd ++ " rm " ++ fromContainerId cid ]

runContainer :: ContainerId -> Image -> [RunParam] -> ContainerIdent -> IO Bool
runContainer cid image ps ident = do
	ok <- boolSystem dockercmd undefined
	when ok $
		void $ readContainerCommand cid "sh"
			["-c", "echo '" ++ show ident ++ "' > " ++ propellerIdent]
	return ok

-- | Runs a command inside the container.
readContainerCommand :: ContainerId -> String -> [String] -> IO String
readContainerCommand cid command params = undefined

commitContainer :: ContainerId -> IO (Maybe Image)
commitContainer cid = catchMaybeIO $
	readProcess dockercmd ["commit", fromContainerId cid]

-- | Only lists propellor managed containers.
listRunningContainers :: IO [ContainerId]
listRunningContainers = undefined -- docker.io ps

-- | Only lists propellor managed containers.
listContainers :: IO [ContainerId]
listContainers = undefined

listImages :: IO [ContainerId]
listImages = undefined -- docker.io images --no-trunc

runProp :: String -> RunParam -> Containerized Property
runProp field val = Containerized [param] (Property param (return NoChange))
  where
	param = field++"="++val

-- | Lift a Property to run inside the container.
inside :: Property -> Containerized Property
inside p = Containerized [] p

-- | Set custom dns server for container.
dns :: String -> Containerized Property
dns = runProp "dns"

-- | Set container host name.
hostname :: String -> Containerized Property
hostname = runProp "hostname"

-- | Set name for container. (Normally done automatically.)
name :: String -> Containerized Property
name = runProp "name"

-- | Publish a container's port to the host
-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
publish :: String -> Containerized Property
publish = runProp "publish"

-- | Username or UID for container.
user :: String -> Containerized Property
user = runProp "user"

-- | Bind mount a volume
volume :: String -> Containerized Property
volume = runProp "volume"

-- | Work dir inside the container. 
-- Must contain ./propellor! (Normally set automatically.)
workdir :: String -> Containerized Property
workdir = runProp "workdir"

-- | Memory limit for container.
--Format: <number><optional unit>, where unit = b, k, m or g
memory :: String -> Containerized Property
memory = runProp "memory"