From ce6bd99d43a3d7c77cbec0272da1abd071b5bd5d Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Wed, 10 Jul 2019 07:07:18 -0400 Subject: improve FileWriter --- lib/Kiki.hs | 97 ++++++++++++++++++++++++++++++++----------------------------- 1 file 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 @@ +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Kiki @@ -367,41 +368,45 @@ ipsecKeyPath = ipsecPath "private" ipsecCertPath :: Char8.ByteString -> FilePath ipsecCertPath = ipsecPath "certs" -write' :: FileWriter -> (FilePath -> t -> IO b) -> FilePath -> t -> IO b -write' fw@(FileWriter mkpath _) wr (mkpath -> f) bs = do - createDirectoryIfMissing True $ takeDirectory f - wr f bs - -write :: FileWriter -> FilePath -> String -> IO () -write fw = write' fw writeFile - -writeL :: FileWriter -> FilePath -> Char8.ByteString -> IO () -writeL fw = write' fw L.writeFile - -writeL077 :: FileWriter -> FilePath -> Char8.ByteString -> IO FileMode -writeL077 fw f bs = do - old_umask <- setFileCreationMask 0o077 - writeL fw f bs - setFileCreationMask old_umask +makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter +makeFileWriter p c = + FileWriter + { pathMaker = p + , fileWriterCommit = c + , write = write' writeFile + , writeL = write' L.writeFile + , writeL077 = + \f bs -> do + old_umask <- setFileCreationMask 0o077 + write' L.writeFile f bs + setFileCreationMask old_umask + } + where + write' wr (p -> f) bs = do + createDirectoryIfMissing True $ takeDirectory f + wr f bs data FileWriter = FileWriter { - pathMaker :: FilePath -> FilePath, - fileWriterCommit :: IO () + pathMaker :: FilePath -> FilePath, + fileWriterCommit :: IO (), + write :: FilePath -> String -> IO (), + writeL :: FilePath -> Char8.ByteString -> IO (), + writeL077 :: FilePath -> Char8.ByteString -> IO FileMode } -getMkPathAndCommit :: FilePath -> IO (FileWriter) -getMkPathAndCommit destdir = do - let cachedir = takeDirectory destdir - unslash ('/':xs) = xs - unslash xs = xs - timeout = -1 -- TODO: set milisecond timeout on dotlock +getMkPathAndCommit :: FilePath -> IO (FileWriter) +getMkPathAndCommit destdir = do + let cachedir = takeDirectory destdir + unslash ('/':xs) = xs + unslash xs = xs + timeout = -1 -- TODO: set milisecond timeout on dotlock createDirectoryIfMissing True cachedir - tmpdir <- createTempDirectory cachedir (takeBaseName destdir ++ ".") + tmpdir <- createTempDirectory cachedir (takeBaseName destdir ++ ".") createSymbolicLink (makeRelative cachedir tmpdir) (tmpdir ++ ".link") - lock <- dotlock_create destdir 0 + lock <- dotlock_create destdir 0 T.mapM (flip dotlock_take timeout) lock - let mkpath pth = tmpdir unslash (makeRelative destdir pth) - commit = do + let mkpath pth = tmpdir unslash (makeRelative destdir pth) + commit = do oldcommit <- (Just <$> readSymbolicLink destdir) `catch` \e -> do when (not $ isDoesNotExistError e) $ warn (show e) @@ -409,29 +414,29 @@ getMkPathAndCommit destdir = do -- Note: Files not written to are considered deleted, -- otherwise call readyReadBeforeWrite on them. rename (tmpdir ++ ".link") destdir - er <- T.mapM dotlock_release lock + er <- T.mapM dotlock_release lock void $ T.mapM removeDirectoryRecursive (FilePath.combine cachedir <$> oldcommit) -- Present transaction is Write only (or Write-Before-Read) which is fine. -- If ever Read-Before-Write is required, uncomment and use: -- let readyReadBeforeWrite pth = do - -- let copyIt = do + -- let copyIt = do -- createDirectoryIfMissing True (takeDirectory (mkpath pth)) -- copyFile (destdir unslash (makeRelative destdir pth) (mkpath pth) -- doesFileExist (mkpath pth) >>= flip when copyIt -- return (mkpath pth) - return $ FileWriter mkpath commit + return $ makeFileWriter mkpath commit generateHostsFile :: FileWriter -> KeyRingRuntime -> IO () -generateHostsFile (FileWriter mkpath _) rt = do - let hostspath = mkpath "hosts" - op = KeyRingOperation - { opFiles = Map.fromList $ +generateHostsFile fw rt = do + let hostspath = pathMaker fw "hosts" + op = KeyRingOperation + { opFiles = Map.fromList $ [ ( HomePub, streaminfo { typ=KeyRingFile, spill=KF_All, access=Pub } ) , ( ArgFile hostspath, streaminfo { typ=Hosts, spill=KF_None, fill=KF_All, access=Pub } ) ] , opPassphrases = [] - , opHome = Just $ takeDirectory (rtPubring rt) - , opTransforms = [] + , opHome = Just $ takeDirectory (rtPubring rt) + , opTransforms = [] } KikiResult _ report <- runKeyRing op outputReport report @@ -441,14 +446,14 @@ names rt = do wk <- rtWorkingKey rt -- XXX unnecessary signature check return $ getHostnames (rtKeyDB rt Map.! keykey wk) -getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString +getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString getssh (contactname,_addr,kd) = do - let their_master = packet $ keyMappedPacket kd + let their_master = packet $ keyMappedPacket kd sshs :: [Packet] - sshs = sortOn (Down . timestamp) + sshs = sortOn (Down . timestamp) $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" - blobs = mapMaybe sshblobFromPacketL sshs - taggedblobs = map (\b -> contactname <> " " <> b) blobs + blobs = mapMaybe sshblobFromPacketL sshs + taggedblobs = map (\b -> contactname <> " " <> b) blobs Char8.unlines taggedblobs @@ -480,7 +485,7 @@ installIpsecConf fw wkaddr (certBasename) cs = do refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO () refreshCache rt rootdir = do - fw@(FileWriter mkpath _) <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config") + fw <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config") generateHostsFile fw rt fromMaybe (error "No working key.") $ do Hostnames wkaddr onames _ _ <- names rt @@ -506,7 +511,7 @@ refreshCache rt rootdir = do ] } send usage path warning = - ( ArgFile (mkpath path), StreamInfo { typ = PEMFile + ( ArgFile (pathMaker fw path), StreamInfo { typ = PEMFile , fill = KF_Match usage , spill = KF_None , access = Sec @@ -525,7 +530,7 @@ rethrowKikiErrors BadPassphrase = rethrowKikiErrors rt = unconditionally $ return rt writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> Char8.ByteString -> SockAddr -> IO () -writePublicKeyFiles rt fw@(FileWriter _ commit) grip oname wkaddr = do +writePublicKeyFiles rt fw grip oname wkaddr = do -- Finally, export public keys if they do not exist. 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 writeL fw "ssh_known_hosts" known_hosts installIpsecConf fw wkaddr (Char8.pack $ takeBaseName $ ipsecCertPath oname) cs - commit + fileWriterCommit fw sshKeyToHostname :: Packet -> IO Char8.ByteString sshKeyToHostname sshkey = do -- cgit v1.2.3