summaryrefslogtreecommitdiff
path: root/lib/Kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Kiki.hs')
-rw-r--r--lib/Kiki.hs97
1 files changed, 51 insertions, 46 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index cb77e2a..2af7779 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,3 +1,4 @@
1{-# LANGUAGE ViewPatterns #-}
1{-# LANGUAGE CPP #-} 2{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE OverloadedStrings #-}
3module Kiki 4module Kiki
@@ -367,41 +368,45 @@ ipsecKeyPath = ipsecPath "private"
367ipsecCertPath :: Char8.ByteString -> FilePath 368ipsecCertPath :: Char8.ByteString -> FilePath
368ipsecCertPath = ipsecPath "certs" 369ipsecCertPath = ipsecPath "certs"
369 370
370write' :: FileWriter -> (FilePath -> t -> IO b) -> FilePath -> t -> IO b 371makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter
371write' fw@(FileWriter mkpath _) wr (mkpath -> f) bs = do 372makeFileWriter p c =
372 createDirectoryIfMissing True $ takeDirectory f 373 FileWriter
373 wr f bs 374 { pathMaker = p
374 375 , fileWriterCommit = c
375write :: FileWriter -> FilePath -> String -> IO () 376 , write = write' writeFile
376write fw = write' fw writeFile 377 , writeL = write' L.writeFile
377 378 , writeL077 =
378writeL :: FileWriter -> FilePath -> Char8.ByteString -> IO () 379 \f bs -> do
379writeL fw = write' fw L.writeFile 380 old_umask <- setFileCreationMask 0o077
380 381 write' L.writeFile f bs
381writeL077 :: FileWriter -> FilePath -> Char8.ByteString -> IO FileMode 382 setFileCreationMask old_umask
382writeL077 fw f bs = do 383 }
383 old_umask <- setFileCreationMask 0o077 384 where
384 writeL fw f bs 385 write' wr (p -> f) bs = do
385 setFileCreationMask old_umask 386 createDirectoryIfMissing True $ takeDirectory f
387 wr f bs
386 388
387data FileWriter = FileWriter { 389data FileWriter = FileWriter {
388 pathMaker :: FilePath -> FilePath, 390 pathMaker :: FilePath -> FilePath,
389 fileWriterCommit :: IO () 391 fileWriterCommit :: IO (),
392 write :: FilePath -> String -> IO (),
393 writeL :: FilePath -> Char8.ByteString -> IO (),
394 writeL077 :: FilePath -> Char8.ByteString -> IO FileMode
390} 395}
391 396
392getMkPathAndCommit :: FilePath -> IO (FileWriter) 397getMkPathAndCommit :: FilePath -> IO (FileWriter)
393getMkPathAndCommit destdir = do 398getMkPathAndCommit destdir = do
394 let cachedir = takeDirectory destdir 399 let cachedir = takeDirectory destdir
395 unslash ('/':xs) = xs 400 unslash ('/':xs) = xs
396 unslash xs = xs 401 unslash xs = xs
397 timeout = -1 -- TODO: set milisecond timeout on dotlock 402 timeout = -1 -- TODO: set milisecond timeout on dotlock
398 createDirectoryIfMissing True cachedir 403 createDirectoryIfMissing True cachedir
399 tmpdir <- createTempDirectory cachedir (takeBaseName destdir ++ ".") 404 tmpdir <- createTempDirectory cachedir (takeBaseName destdir ++ ".")
400 createSymbolicLink (makeRelative cachedir tmpdir) (tmpdir ++ ".link") 405 createSymbolicLink (makeRelative cachedir tmpdir) (tmpdir ++ ".link")
401 lock <- dotlock_create destdir 0 406 lock <- dotlock_create destdir 0
402 T.mapM (flip dotlock_take timeout) lock 407 T.mapM (flip dotlock_take timeout) lock
403 let mkpath pth = tmpdir </> unslash (makeRelative destdir pth) 408 let mkpath pth = tmpdir </> unslash (makeRelative destdir pth)
404 commit = do 409 commit = do
405 oldcommit <- (Just <$> readSymbolicLink destdir) 410 oldcommit <- (Just <$> readSymbolicLink destdir)
406 `catch` \e -> do 411 `catch` \e -> do
407 when (not $ isDoesNotExistError e) $ warn (show e) 412 when (not $ isDoesNotExistError e) $ warn (show e)
@@ -409,29 +414,29 @@ getMkPathAndCommit destdir = do
409 -- Note: Files not written to are considered deleted, 414 -- Note: Files not written to are considered deleted,
410 -- otherwise call readyReadBeforeWrite on them. 415 -- otherwise call readyReadBeforeWrite on them.
411 rename (tmpdir ++ ".link") destdir 416 rename (tmpdir ++ ".link") destdir
412 er <- T.mapM dotlock_release lock 417 er <- T.mapM dotlock_release lock
413 void $ T.mapM removeDirectoryRecursive (FilePath.combine cachedir <$> oldcommit) 418 void $ T.mapM removeDirectoryRecursive (FilePath.combine cachedir <$> oldcommit)
414 -- Present transaction is Write only (or Write-Before-Read) which is fine. 419 -- Present transaction is Write only (or Write-Before-Read) which is fine.
415 -- If ever Read-Before-Write is required, uncomment and use: 420 -- If ever Read-Before-Write is required, uncomment and use:
416 -- let readyReadBeforeWrite pth = do 421 -- let readyReadBeforeWrite pth = do
417 -- let copyIt = do 422 -- let copyIt = do
418 -- createDirectoryIfMissing True (takeDirectory (mkpath pth)) 423 -- createDirectoryIfMissing True (takeDirectory (mkpath pth))
419 -- copyFile (destdir </> unslash (makeRelative destdir pth) (mkpath pth) 424 -- copyFile (destdir </> unslash (makeRelative destdir pth) (mkpath pth)
420 -- doesFileExist (mkpath pth) >>= flip when copyIt 425 -- doesFileExist (mkpath pth) >>= flip when copyIt
421 -- return (mkpath pth) 426 -- return (mkpath pth)
422 return $ FileWriter mkpath commit 427 return $ makeFileWriter mkpath commit
423 428
424generateHostsFile :: FileWriter -> KeyRingRuntime -> IO () 429generateHostsFile :: FileWriter -> KeyRingRuntime -> IO ()
425generateHostsFile (FileWriter mkpath _) rt = do 430generateHostsFile fw rt = do
426 let hostspath = mkpath "hosts" 431 let hostspath = pathMaker fw "hosts"
427 op = KeyRingOperation 432 op = KeyRingOperation
428 { opFiles = Map.fromList $ 433 { opFiles = Map.fromList $
429 [ ( HomePub, streaminfo { typ=KeyRingFile, spill=KF_All, access=Pub } ) 434 [ ( HomePub, streaminfo { typ=KeyRingFile, spill=KF_All, access=Pub } )
430 , ( ArgFile hostspath, streaminfo { typ=Hosts, spill=KF_None, fill=KF_All, access=Pub } ) 435 , ( ArgFile hostspath, streaminfo { typ=Hosts, spill=KF_None, fill=KF_All, access=Pub } )
431 ] 436 ]
432 , opPassphrases = [] 437 , opPassphrases = []
433 , opHome = Just $ takeDirectory (rtPubring rt) 438 , opHome = Just $ takeDirectory (rtPubring rt)
434 , opTransforms = [] 439 , opTransforms = []
435 } 440 }
436 KikiResult _ report <- runKeyRing op 441 KikiResult _ report <- runKeyRing op
437 outputReport report 442 outputReport report
@@ -441,14 +446,14 @@ names rt = do wk <- rtWorkingKey rt
441 -- XXX unnecessary signature check 446 -- XXX unnecessary signature check
442 return $ getHostnames (rtKeyDB rt Map.! keykey wk) 447 return $ getHostnames (rtKeyDB rt Map.! keykey wk)
443 448
444getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString 449getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString
445getssh (contactname,_addr,kd) = do 450getssh (contactname,_addr,kd) = do
446 let their_master = packet $ keyMappedPacket kd 451 let their_master = packet $ keyMappedPacket kd
447 sshs :: [Packet] 452 sshs :: [Packet]
448 sshs = sortOn (Down . timestamp) 453 sshs = sortOn (Down . timestamp)
449 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" 454 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server"
450 blobs = mapMaybe sshblobFromPacketL sshs 455 blobs = mapMaybe sshblobFromPacketL sshs
451 taggedblobs = map (\b -> contactname <> " " <> b) blobs 456 taggedblobs = map (\b -> contactname <> " " <> b) blobs
452 Char8.unlines taggedblobs 457 Char8.unlines taggedblobs
453 458
454 459
@@ -480,7 +485,7 @@ installIpsecConf fw wkaddr (certBasename) cs = do
480 485
481refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () 486refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
482refreshCache rt rootdir = do 487refreshCache rt rootdir = do
483 fw@(FileWriter mkpath _) <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config") 488 fw <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config")
484 generateHostsFile fw rt 489 generateHostsFile fw rt
485 fromMaybe (error "No working key.") $ do 490 fromMaybe (error "No working key.") $ do
486 Hostnames wkaddr onames _ _ <- names rt 491 Hostnames wkaddr onames _ _ <- names rt
@@ -506,7 +511,7 @@ refreshCache rt rootdir = do
506 ] 511 ]
507 } 512 }
508 send usage path warning = 513 send usage path warning =
509 ( ArgFile (mkpath path), StreamInfo { typ = PEMFile 514 ( ArgFile (pathMaker fw path), StreamInfo { typ = PEMFile
510 , fill = KF_Match usage 515 , fill = KF_Match usage
511 , spill = KF_None 516 , spill = KF_None
512 , access = Sec 517 , access = Sec
@@ -525,7 +530,7 @@ rethrowKikiErrors BadPassphrase =
525rethrowKikiErrors rt = unconditionally $ return rt 530rethrowKikiErrors rt = unconditionally $ return rt
526 531
527writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> Char8.ByteString -> SockAddr -> IO () 532writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> Char8.ByteString -> SockAddr -> IO ()
528writePublicKeyFiles rt fw@(FileWriter _ commit) grip oname wkaddr = do 533writePublicKeyFiles rt fw grip oname wkaddr = do
529 534
530 -- Finally, export public keys if they do not exist. 535 -- Finally, export public keys if they do not exist.
531 either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) 536 either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt)
@@ -548,7 +553,7 @@ writePublicKeyFiles rt fw@(FileWriter _ commit) grip oname wkaddr = do
548 writeL fw "ssh_known_hosts" known_hosts 553 writeL fw "ssh_known_hosts" known_hosts
549 554
550 installIpsecConf fw wkaddr (Char8.pack $ takeBaseName $ ipsecCertPath oname) cs 555 installIpsecConf fw wkaddr (Char8.pack $ takeBaseName $ ipsecCertPath oname) cs
551 commit 556 fileWriterCommit fw
552 557
553sshKeyToHostname :: Packet -> IO Char8.ByteString 558sshKeyToHostname :: Packet -> IO Char8.ByteString
554sshKeyToHostname sshkey = do 559sshKeyToHostname sshkey = do