diff options
author | Joe Crayne <joe@jerkface.net> | 2019-07-06 15:19:04 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-07-06 15:19:04 -0400 |
commit | 2d001913d97ccc05af3b062b42b0df8b155d2a73 (patch) | |
tree | 6b3c4e5b3fda73df0c4ada4228ea7dcd0709f814 /lib/Kiki.hs | |
parent | b0967e64df7a4f4d1cd2af95ccda8a0ba3447138 (diff) |
Minor cleanup, comments.
Diffstat (limited to 'lib/Kiki.hs')
-rw-r--r-- | lib/Kiki.hs | 174 |
1 files changed, 88 insertions, 86 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs index e67c805..eabd8ed 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs | |||
@@ -14,6 +14,7 @@ import Data.ASN1.Types | |||
14 | import Data.Binary | 14 | import Data.Binary |
15 | import Data.Bool | 15 | import Data.Bool |
16 | import Data.Char | 16 | import Data.Char |
17 | import Data.Functor | ||
17 | import Data.List | 18 | import Data.List |
18 | import Data.Maybe | 19 | import Data.Maybe |
19 | import Data.OpenPGP | 20 | import Data.OpenPGP |
@@ -155,6 +156,35 @@ mkdirFor path = do | |||
155 | let dir = takeDirectory path | 156 | let dir = takeDirectory path |
156 | createDirectoryIfMissing True dir | 157 | createDirectoryIfMissing True dir |
157 | 158 | ||
159 | |||
160 | -- | Useful default KeyRingFile StreamInfo. | ||
161 | strm :: StreamInfo | ||
162 | strm = StreamInfo | ||
163 | { typ = KeyRingFile | ||
164 | , fill = KF_None | ||
165 | , spill = KF_All | ||
166 | , access = AutoAccess | ||
167 | , initializer = NoCreate | ||
168 | , transforms = [] | ||
169 | } | ||
170 | |||
171 | -- | Convenience constructor for StreamInfo | ||
172 | buildStreamInfo :: KeyFilter -> FileType -> StreamInfo | ||
173 | buildStreamInfo rtyp ftyp = strm { typ = ftyp , fill = rtyp } | ||
174 | |||
175 | -- | Convenience constuctor for Streaminfo generating a tagged subkey. | ||
176 | peminfo :: Int -- ^ bits | ||
177 | -> String -- ^ subkey tag. | ||
178 | -> StreamInfo | ||
179 | peminfo bits usage = StreamInfo | ||
180 | { typ = PEMFile | ||
181 | , fill = KF_None -- KF_Match usage | ||
182 | , spill = KF_Match usage | ||
183 | , access = Sec | ||
184 | , initializer = Internal (GenRSA $ bits `div` 8) | ||
185 | , transforms = [] | ||
186 | } | ||
187 | |||
158 | importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> SymmetricAlgorithm -> IO () | 188 | importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> SymmetricAlgorithm -> IO () |
159 | importAndRefresh root cmn cipher = do | 189 | importAndRefresh root cmn cipher = do |
160 | let rootdir = do guard (root "x" /= "x") | 190 | let rootdir = do guard (root "x" /= "x") |
@@ -165,54 +195,57 @@ importAndRefresh root cmn cipher = do | |||
165 | bool id (error "--chroot requires an argument") (rootdir==Just "") $ do | 195 | bool id (error "--chroot requires an argument") (rootdir==Just "") $ do |
166 | let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn) | 196 | let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn) |
167 | (fmap (++"/root/.gnupg") rootdir) | 197 | (fmap (++"/root/.gnupg") rootdir) |
198 | passfd = cap_passfd cmn | ||
168 | (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec | 199 | (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec |
169 | osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root" | 200 | osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root" |
170 | 201 | ||
171 | old_umask <- setFileCreationMask(0o077); | 202 | old_umask <- setFileCreationMask 0o077 -- Keyring files need to be created with proper mask. |
172 | -- Generate secring.gpg if it does not exist... | ||
173 | gotsec <- doesFileExist secring | 203 | gotsec <- doesFileExist secring |
174 | |||
175 | let passfd = cap_passfd cmn | ||
176 | |||
177 | (torgen,pwds) <- bool id (const $ return (Generate 0 $ GenRSA $ 1024 `div` 8, [])) gotsec $ do | 204 | (torgen,pwds) <- bool id (const $ return (Generate 0 $ GenRSA $ 1024 `div` 8, [])) gotsec $ do |
178 | {- ssh-keygen to create master key... | 205 | -- We have no secring.gpg (and thus no master key). |
179 | let mkpath = home ++ "/master-key" | 206 | -- Since 'runKeyRing' cannot currently cope with this situation, we will |
180 | mkdirFor mkpath | 207 | -- generate a master-key and very minimal secring.gpg file. |
181 | e <- systemEnv [ ("file",mkpath) ] (fromJust $ sshkeygen 4096) | 208 | master_un <- generateKey (GenRSA $ 4096 `div` 8 ) |
182 | case e of | 209 | <&> \k -> MappedPacket (k { is_subkey = False }) -- Set as master-key. |
183 | ExitFailure num -> error "ssh-keygen failed to create master key" | 210 | Map.empty -- Packet occurs in no files. |
184 | ExitSuccess -> return () | 211 | -- The user may desire the master key is encrypted on disk but this |
185 | [PEMPacket mk] <- readSecretPEMFile (ArgFile mkpath) | 212 | -- requires a password prompt. In order to have a decent prompt, it'd |
186 | writeInputFileL (InputFileContext secring pubring) | 213 | -- be nice if we could display the .onion hostname for the key. |
187 | HomeSec | 214 | -- Therefore, we generate the tor key early. |
188 | ( encode $ Message [mk { is_subkey = False }] ) | ||
189 | -} | ||
190 | master_un <- (\k -> MappedPacket (k { is_subkey = False }) Map.empty) <$> generateKey (GenRSA $ 4096 `div` 8 ) | ||
191 | tor_un <- generateKey (GenRSA $ 1024 `div` 8 ) | 215 | tor_un <- generateKey (GenRSA $ 1024 `div` 8 ) |
216 | -- However, we'll postpone writing the tor key to the keyring and | ||
217 | -- instead have the later all-in-one call to runKeyRing take care of | ||
218 | -- it. That interface does not currently provide a way to accept | ||
219 | -- in-memory input, so we'll create a fifo stream for it to read the | ||
220 | -- key in PEM format. | ||
192 | (read_tor,write_tor) <- Posix.createPipe | 221 | (read_tor,write_tor) <- Posix.createPipe |
193 | do rs <- writeKeyToFile (streaminfo { typ = PEMFile, access = Sec, spill = KF_Match "tor", fill = KF_All }) (FileDesc write_tor) tor_un | 222 | rs <- writeKeyToFile (streaminfo { typ = PEMFile |
194 | -- outputReport $ map (first show) rs | 223 | , access = Sec |
195 | return () | 224 | , spill = KF_Match "tor" |
196 | cipher's2k <- do | 225 | , fill = KF_All }) |
197 | IteratedSaltedS2K _ salt _ <- randomS2K SHA1 | 226 | (FileDesc write_tor) |
198 | -- (cipher {- AES128 -}, IteratedSaltedS2K SHA1 4073382889203176146 7864320) | 227 | tor_un |
199 | return $ (cipher {- AES128 -}, IteratedSaltedS2K SHA1 salt (15 * 2^19)) | 228 | -- -- Currently disabled: show warnings and errors from the PEM generation. |
229 | -- outputReport $ map (first show) rs | ||
230 | |||
200 | let ctx = InputFileContext secring pubring | 231 | let ctx = InputFileContext secring pubring |
201 | main_passwds = withAgent $ do pfd <- maybeToList passfd | 232 | -- Here we encrypt the master-key if neccessary. If no --passphrase-fd option |
202 | return $ PassphraseSpec Nothing Nothing pfd | 233 | -- was used, the user will receive prompts from gpg-agent. |
203 | passwordop = KeyRingOperation | 234 | (master0,transcoder) <- do |
204 | { opFiles = Map.empty | 235 | let main_passwds = withAgent $ do pfd <- maybeToList passfd |
205 | , opPassphrases = main_passwds | 236 | return $ PassphraseSpec Nothing Nothing pfd |
206 | , opHome = homespec | 237 | uidentry = Map.singleton (keykey $ packet master_un) |
207 | , opTransforms = [] | 238 | $ master_un { packet = Query (packet master_un) |
208 | } | 239 | (torUIDFromKey tor_un) |
209 | let uidentry = Map.singleton (keykey $ packet master_un) | 240 | Nothing } |
210 | $ master_un { packet = Query (packet master_un) | 241 | cipher's2k <- do |
211 | (torUIDFromKey tor_un) | 242 | IteratedSaltedS2K _ salt _ <- randomS2K SHA1 |
212 | Nothing | 243 | return $ (cipher {- AES128 -}, IteratedSaltedS2K SHA1 salt (15 * 2^19)) |
213 | } | 244 | transcoder <- makeMemoizingDecrypter main_passwds ctx (Just master_un, uidentry) |
214 | transcoder <- makeMemoizingDecrypter passwordop ctx (Just master_un, uidentry) | 245 | master <- transcoder cipher's2k master_un |
215 | master0 <- transcoder cipher's2k master_un | 246 | return (master,transcoder) |
247 | |||
248 | -- Finally, we write-out the secring.gpg file. | ||
216 | case master0 of | 249 | case master0 of |
217 | KikiSuccess master -> do | 250 | KikiSuccess master -> do |
218 | mkdirFor secring | 251 | mkdirFor secring |
@@ -229,7 +262,17 @@ importAndRefresh root cmn cipher = do | |||
229 | HomeSec | 262 | HomeSec |
230 | $ encode $ Message [packet master_un] | 263 | $ encode $ Message [packet master_un] |
231 | putStrLn "Wrote master key" | 264 | putStrLn "Wrote master key" |
265 | -- FIXME: Why are we re-generating the tor key here? Does this | ||
266 | -- code get triggered when the user cancels the agent prompt? | ||
267 | -- If so, he's likely canceling encryption, not the .onion name | ||
268 | -- he was already shown. | ||
232 | return (Generate 0 (GenRSA $ 1024 `div` 8 ), []) | 269 | return (Generate 0 (GenRSA $ 1024 `div` 8 ), []) |
270 | |||
271 | -- If the public ring does not exist, then creating an empty file is | ||
272 | -- sufficient to satisfy 'runKeyRing'. However, as we've already generated | ||
273 | -- a key above, GnuPG will not like the unsynced state we are leaving these | ||
274 | -- files. It's important at this point that, 'runKeyRing' actually occurs | ||
275 | -- to fix things up. | ||
233 | gotpub <- doesFileExist pubring | 276 | gotpub <- doesFileExist pubring |
234 | when (not gotpub) $ do | 277 | when (not gotpub) $ do |
235 | mkdirFor pubring | 278 | mkdirFor pubring |
@@ -237,49 +280,9 @@ importAndRefresh root cmn cipher = do | |||
237 | HomePub | 280 | HomePub |
238 | ( encode $ Message [] ) | 281 | ( encode $ Message [] ) |
239 | 282 | ||
240 | setFileCreationMask(old_umask); | 283 | setFileCreationMask old_umask -- We're done creating keyring files, so restore umask. |
241 | -- Old paths.. | 284 | |
242 | -- | 285 | let sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa" |
243 | -- Private | ||
244 | -- pem tor /var/lib/tor/samizdat/private_key | ||
245 | -- pem ssh-client %(home)/.ssh/id_rsa | ||
246 | -- pem ssh-server /etc/ssh/ssh_host_rsa_key | ||
247 | -- pem ipsec /etc/ipsec.d/private/%(onion).pem | ||
248 | |||
249 | -- Public | ||
250 | -- ssh-client %(home)/.ssh/id_rsa.pub | ||
251 | -- ssh-server /etc/ssh/ssh_host_rsa_key.pub | ||
252 | -- ipsec /etc/ipsec.d/certs/%(onion).pem | ||
253 | |||
254 | -- First, we ensure that the tor key exists and is imported | ||
255 | -- so that we know where to put the strongswan key. | ||
256 | let strm = | ||
257 | StreamInfo | ||
258 | { typ = KeyRingFile | ||
259 | , fill = KF_None | ||
260 | , spill = KF_All | ||
261 | , access = AutoAccess | ||
262 | , initializer = NoCreate | ||
263 | , transforms = [] | ||
264 | } | ||
265 | buildStreamInfo rtyp ftyp = | ||
266 | StreamInfo | ||
267 | { typ = ftyp | ||
268 | , fill = rtyp | ||
269 | , spill = KF_All | ||
270 | , access = AutoAccess | ||
271 | , initializer = NoCreate | ||
272 | , transforms = [] } | ||
273 | peminfo bits usage = | ||
274 | StreamInfo | ||
275 | { typ = PEMFile | ||
276 | , fill = KF_None -- KF_Match usage | ||
277 | , spill = KF_Match usage | ||
278 | , access = Sec | ||
279 | , initializer = Internal (GenRSA $ bits `div` 8) | ||
280 | , transforms = [] | ||
281 | } | ||
282 | sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa" | ||
283 | sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key" | 286 | sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key" |
284 | op = | 287 | op = |
285 | KeyRingOperation | 288 | KeyRingOperation |
@@ -306,7 +309,6 @@ importAndRefresh root cmn cipher = do | |||
306 | , opHome = homespec | 309 | , opHome = homespec |
307 | , opTransforms = [] | 310 | , opTransforms = [] |
308 | } | 311 | } |
309 | -- doNothing = return () | ||
310 | nop = | 312 | nop = |
311 | KeyRingOperation | 313 | KeyRingOperation |
312 | { opFiles = Map.empty | 314 | { opFiles = Map.empty |
@@ -314,14 +316,14 @@ importAndRefresh root cmn cipher = do | |||
314 | return $ PassphraseSpec Nothing Nothing pfd | 316 | return $ PassphraseSpec Nothing Nothing pfd |
315 | , opHome=homespec, opTransforms = [] | 317 | , opHome=homespec, opTransforms = [] |
316 | } | 318 | } |
317 | -- if bUnprivileged then doNothing else mkdirFor torpath | 319 | -- Run the all-in-one operation that generates or imports all subkeys. |
318 | KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op) | 320 | KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op) |
319 | outputReport report | 321 | outputReport report |
320 | rt <- case rt of | 322 | rt <- case rt of |
321 | BadPassphrase -> | 323 | BadPassphrase -> |
322 | error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)" | 324 | error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)" |
323 | _ -> unconditionally $ return rt | 325 | _ -> unconditionally $ return rt |
324 | 326 | -- Finally, we update /var/cache/kiki. | |
325 | when (not bUnprivileged) $ refreshCache rt rootdir | 327 | when (not bUnprivileged) $ refreshCache rt rootdir |
326 | 328 | ||
327 | -- Installs the cert file for the peer to the filesystem, and returns an | 329 | -- Installs the cert file for the peer to the filesystem, and returns an |