Commits

nakamura committed 2962661

new subcommand: udon edit

Comments (0)

Files changed (6)

 
 import Prelude hiding (catch)
 import Control.Arrow ((>>>), (&&&), (***))
+import Control.Applicative ((<$>))
 import Control.Monad (forM_)
 import Control.Monad.Reader (ReaderT, runReaderT, ask, asks, MonadReader, MonadIO)
+import Data.Char (toLower)
 import Data.List (intercalate, mapAccumL)
 import Data.Time (UTCTime, getCurrentTime, diffUTCTime)
 import Network.Socket (socket, Family(AF_UNIX), SocketType(Stream), defaultProtocol, connect, SockAddr(SockAddrUnix), socketToHandle, Socket)
 import System.Environment (getProgName, getArgs)
 import System.Exit (exitFailure)
 import System.FilePath ((</>), takeBaseName)
-import System.IO (Handle, IOMode(ReadWriteMode), hSetBuffering, BufferMode(LineBuffering), hGetLine, hPutStrLn, stderr)
+import System.IO (Handle, IOMode(ReadWriteMode), hSetBuffering, BufferMode(LineBuffering), hGetLine, hPutStrLn, stderr, openTempFile, hPutStr, hClose, hFlush, stdout)
 import System.IO.Error (catch)
 import System.Posix (usleep)
 import System.Posix.Directory (getWorkingDirectory)
 import System.Posix.Env (getEnvironment)
+import System.Posix.Files (removeLink)
 import System.Posix.Process (executeFile)
 import Text.Printf (printf)
 
 import Data.Version (showVersion)
 
 import Common
-import Process (parseSignal, runCommand, waitChild')
+import Parser (parseDaemon)
+import Process (parseSignal, runCommand, waitChild', system)
 import Utils (readMaybeIO, hPutStrLnM, putStrLnM, printM, hPrintM, hGetLineM)
 
 type ErrorMessage = String
 client ("ping":[])              = runCCommand commandPing
 client ("register":args)        = runCCommand (commandRegister args)
 client ("unregister":daemon:[]) = runCCommand (commandUnregister daemon)
+client ("edit":daemon:[])       = runCCommand (commandEdit daemon)
 client ("start":daemon:[])      = runCCommand (commandStart daemon)
 client ("stop":daemon:[])       = runCCommand (commandStop daemon "SIGTERM")
 client ("stop":daemon:sig:[])   = runCCommand (commandStop daemon sig)
         , "    ping:                                     pong"
         , "    register [-n <name>] <cmd> [cmdargs...]:  register <cmd> as daemon"
         , "    unregister <daemon>:                      unregister daemon"
+        , "    edit <daemon>:                            edit daemon"
         , "    start <daemon>:                           start <daemon>"
         , "    stop <daemon> [<signal>]:                 stop <daemon> with <signal>"
         , "    kill <daemon> [<signal>]:                 send <signal> to <daemon>"
     hPrintM h $ UnregisterDaemon dn
     assertResponseOK =<< hGetResponse h
 
+commandEdit :: String -> ClientCommand
+commandEdit dn =
+    withDaemonStatus dn $ \(dst, lst) -> do
+        md <- io $ editDaemon $ pprintDaemon $ dsDaemon dst
+        case md of
+            Just d  -> simpleCommand $ UpdateDaemon (dName d) d
+            Nothing -> return $ Left ""
+  where
+    editDaemon cs = do
+        cs' <- editString cs
+        case parseDaemon cs' of
+            Left e -> do
+                putStrLn "parse error"
+                print e
+                putStr "edit this file again? (Y|n): "
+                hFlush stdout
+                ans <- getLine
+                case map toLower ans of
+                    'n':_ -> return Nothing
+                    _     -> editDaemon cs'
+            Right d -> return $ Just d
+
 commandStart :: String -> ClientCommand
 commandStart dn = do
     h <- connectMaster
 assertResponseOK (Just OK)     = return $ Right "OK"
 assertResponseOK (Just r)      = return $ Left ("Invalid Response: " ++ show r)
 
+simpleCommand :: Request -> ClientCommand
+simpleCommand req = do
+    h <- connectMaster
+    hPrintM h req
+    assertResponseOK =<< hGetResponse h
+
 withDaemonStatus :: String -> ((DaemonState, LoggerState) -> ClientCommand) -> ClientCommand
 withDaemonStatus dn c = do
     h <- connectMaster
 secToDHMS :: Integer -> (Integer, Integer, Integer, Integer)
 secToDHMS i = let (d, [s, m, h]) = mapAccumL divMod i [60, 60, 24]
               in (d, h, m, s)
+
+editString :: String -> IO String
+editString cs = do
+    (fp, h) <- openTempFile "/tmp" "udon-tmp.txt"
+    hPutStr h cs
+    hClose h
+    runEditor fp
+    cs' <- readFile fp
+    removeLink fp
+    return cs'
+
+runEditor :: FilePath -> IO ()
+runEditor fp = do
+    ed <- getEditor
+    system ed [fp]
+    return ()
+
+getEditor :: IO String
+getEditor = do
+    med <- lookup "EDITOR" <$> getEnvironment
+    case med of
+        Just ed  -> return ed
+        Nothing -> return "vi"
                   | Initializing
                   | NotStarted
                   | Deleting
+                  | Updating
                   | Resuming DaemonStatus
     deriving (Eq, Ord, Show, Read)
 
 data Request = Ping
              | RegisterDaemon Daemon
              | UnregisterDaemon String
+             | UpdateDaemon String Daemon
              | StartDaemon String
              | KillDaemon String Signal
              | SetAutoStart String Bool
 
                     hPrintM h OK
 
+handleRequest (UpdateDaemon dn d) h = do
+    p "[handleRequest] UpdateDaemon"
+    -- TODO: deal with the case of dn /= dName d
+    mdl <- gets $ lookup dn
+    case mdl of
+        Nothing  -> hPrintM h $ NG ("no such daemon: " ++ dn)
+        Just (DaemonLogger _ _ tds _) -> do
+            ed <- io $ atomically $ errorToEither $ do
+                       ds@(DaemonState d dst _ _) <- takeTMVar tds
+                       case dst of
+                           Running _ _  -> fail "daemon still running"
+                           Initializing -> fail "daemon initializing"
+                           Deleting     -> fail "daemon deleting"
+                           _            -> do
+                               putTMVar tds $ ds { dsStatus = Updating }
+                               return d
+            case ed of
+                Left e  -> hPrintM h $ NG e
+                Right old -> do
+                    p "[handleRequest] updating daemon' run file ..."
+                    deleteDaemon old
+                    saveDaemon d
+                    p "[handleRequest] done"
+
+                    p "[handleRequest] updating daemon state ..."
+                    io $ atomically $ do
+                        ds <- takeTMVar tds
+                        putTMVar tds $ ds { dsDaemon = d, dsStatus = NotStarted }
+                    p "[handleRequest] done"
+
+                    hPrintM h OK
+
 handleRequest GetListDaemons     h = do
     p "[handleRequest] GetListDaemons"
     dls <- gets (map snd)
             (Running _ _, _)  -> fail "daemon already running"
             (Initializing, _) -> fail "daemon now initializing"
             (Deleting, _)     -> fail "daemon now deleting"
+            (Updating, _)     -> retry
             (_, False)        -> retry
             _                 -> do
                 let ds' = ds { dsStatus = Initializing }
 {-# LANGUAGE PatternGuards #-}
-module Parser where
+module Parser
+    ( parseDaemonFile
+    , parseDaemon
+    , daemon
+    ) where
 
 import Control.Applicative ((<*), (*>), (<$>), (<*>))
 import Data.List (intercalate)
     | otherwise = fs
 
 parseDaemonFile :: FilePath -> IO (Either ParseError Daemon)
-parseDaemonFile fp = parseFromFile parseDaemon fp
+parseDaemonFile fp = parseFromFile daemon fp
 
-parseDaemon :: Parser Daemon
-parseDaemon = do
+parseDaemon :: String -> Either ParseError Daemon
+parseDaemon = parse daemon ""
+
+daemon :: Parser Daemon
+daemon = do
     spaces
     string "Daemon"
     spaces
 module Process
     ( runCommand
     , runCommandWithFd
+    , system
     , systemWithInput
     , forkDaemon
     , waitChild
     closeFd devNull
     return pid
 
+system :: String           -- ^ Command name
+       -> [String]         -- ^ Command arguments
+       -> IO ProcessStatus
+system cmd args = do
+    cwd <- getWorkingDirectory
+    envs <- getEnvironment
+    pid <- runCommandWithFd cmd args cwd envs (Just stdInput) (Just stdOutput) (Just stdError)
+    Just ps <- waitChild pid
+    return ps
+
 systemWithInput :: String           -- ^ Command name
                 -> [String]         -- ^ Command arguments
                 -> String           -- ^ Input data
 
 executable udon
     hs-source-dirs:      src
-    build-depends:       base >= 4 && < 5, bytestring, containers, directory, filepath, mtl, network, stm, time, unix
+    build-depends:       base >= 4 && < 5, bytestring, containers, directory, filepath, mtl, network, parsec >= 3, stm, time, unix
     main-is:             Main-Client.hs
     ghc-options:         -O2