improve FileWriter

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 @@
+{-# 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