Initial commit

.gitignore

@@ -0,0 +1 @@
+/dist/

AUTHORS

@@ -0,0 +1 @@
+Bit Connor <mutantlemon@gmail.com>

LICENSE

@@ -0,0 +1,19 @@
+Copyright (C) 2012 The hdevtools Authors (see AUTHORS file)
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

hdevtools.cabal

@@ -0,0 +1,26 @@
+name:                hdevtools
+version:             0.1.0.0
+synopsis:            TODO ...
+-- description:         
+license:             MIT
+license-file:        LICENSE
+author:              Bit Connor
+maintainer:          mutantlemon@gmail.com
+-- copyright:           
+category:            Development
+build-type:          Simple
+cabal-version:       >=1.8
+
+executable hdevtools
+  hs-source-dirs:      src
+  main-is:             Main.hs
+  ghc-options:         -Wall
+  cpp-options:         -DCABAL
+  -- other-modules:       
+  build-depends:       base,
+                       cmdargs,
+                       directory,
+                       network,
+                       ghc,
+                       ghc-paths,
+                       time

src/Client.hs

@@ -0,0 +1,59 @@
+module Client
+    ( getServerStatus
+    , stopServer
+    , serverCommand
+    ) where
+
+import Network (PortID(UnixSocket), connectTo)
+import System.Exit (exitFailure, exitWith)
+import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, stderr)
+
+import Types (ClientDirective(..), Command(..), ServerDirective(..))
+import Util (readMaybe)
+
+connect :: FilePath -> IO Handle
+connect sock = do
+    connectTo "" (UnixSocket sock)
+
+getServerStatus :: FilePath -> IO ()
+getServerStatus sock = do
+    h <- connect sock
+    hPutStrLn h $ show SrvStatus
+    hFlush h
+    startClientReadLoop h
+
+stopServer :: FilePath -> IO ()
+stopServer sock = do
+    h <- connect sock
+    hPutStrLn h $ show SrvExit
+    hFlush h
+    startClientReadLoop h
+
+serverCommand :: FilePath -> Command -> [String] -> IO ()
+serverCommand sock cmd ghcOpts = do
+    h <- connect sock
+    hPutStrLn h $ show (SrvCommand cmd ghcOpts)
+    hFlush h
+    startClientReadLoop h
+
+startClientReadLoop :: Handle -> IO ()
+startClientReadLoop h = do
+    msg <- hGetLine h
+    let clientDirective = readMaybe msg
+    case clientDirective of
+        Just (ClientStdout out) -> putStrLn out >> startClientReadLoop h
+        Just (ClientStderr err) -> hPutStrLn stderr err >> startClientReadLoop h
+        Just (ClientExit exitCode) -> hClose h >> exitWith exitCode
+        Just (ClientUnexpectedError err) -> hClose h >> unexpectedError err
+        Nothing -> do
+            hClose h
+            unexpectedError $
+                "The server sent an invalid message to the client: " ++ show msg
+
+unexpectedError :: String -> IO ()
+unexpectedError err = do
+    hPutStrLn stderr banner
+    hPutStrLn stderr err
+    hPutStrLn stderr banner
+    exitFailure
+    where banner = replicate 78 '*'

src/CommandArgs.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
+module CommandArgs
+    ( HDevTools(..)
+    , loadHDevTools
+    )
+where
+
+import System.Console.CmdArgs.Implicit
+import System.Environment (getProgName)
+
+#ifdef CABAL
+import Data.Version (showVersion)
+import Paths_hdevtools (version)
+#endif
+
+programVersion :: String
+programVersion =
+#ifdef CABAL
+    "version " ++ showVersion version
+#else
+    "unknown-version (not built with cabal)"
+#endif
+
+data HDevTools
+    = Admin
+        { socket :: Maybe FilePath
+        , start_server :: Bool
+        , noDaemon :: Bool
+        , status :: Bool
+        , stop_server :: Bool
+        }
+    | Check
+        { socket :: Maybe FilePath
+        , ghcOpts :: [String]
+        , file :: String
+        }
+    deriving (Show, Data, Typeable)
+
+dummyAdmin :: HDevTools
+dummyAdmin = Admin
+    { socket = Nothing
+    , start_server = False
+    , noDaemon = False
+    , status = False
+    , stop_server = False
+    }
+
+dummyCheck :: HDevTools
+dummyCheck = Check
+    { socket = Nothing
+    , ghcOpts = []
+    , file = ""
+    }
+
+admin :: Annotate Ann
+admin = record dummyAdmin
+    [ socket   := def += typFile += help "socket file to use"
+    , start_server   := def            += help "start server"
+    , noDaemon := def            += help "do not daemonize (only if --server)"
+    , status   := def            += help "show status of server"
+    , stop_server := def         += help "shutdown the server"
+    ] += help "Interactions with the server"
+
+check :: Annotate Ann
+check = record dummyCheck
+    [ socket   := def += typFile += help "socket file to use"
+    , ghcOpts  := def += typ "OPTION"   += help "ghc options"
+    , file     := def += typFile      += argPos 0 += opt ""
+    ] += help "Check a haskell source file for errors and warnings"
+
+full :: String -> Annotate Ann
+full progName = modes_ [admin += auto, check]
+        += verbosity
+        += helpArg [name "h", groupname "Help"]
+        += versionArg [groupname "Help"]
+        += program progName
+        += summary (progName ++ ": " ++ programVersion)
+
+loadHDevTools :: IO HDevTools
+loadHDevTools = do
+    progName <- getProgName
+    (cmdArgs_ (full progName) :: IO HDevTools)

src/CommandLoop.hs

@@ -0,0 +1,83 @@
+module CommandLoop where
+
+import Data.Time (getCurrentTime)
+import ErrUtils (Message, mkLocMessage)
+import GHC (Ghc, HscTarget(HscInterpreted), LoadHowMuch(LoadAllTargets), Severity, SrcSpan, SuccessFlag(Succeeded, Failed), getSessionDynFlags, guessTarget, handleSourceError, hscTarget, load, log_action, noLoc, parseDynamicFlags, printException, runGhc, setSessionDynFlags, setTargets)
+import GHC.Paths (libdir)
+import MonadUtils (MonadIO, liftIO)
+import Outputable (PprStyle, renderWithStyle)
+import System.Exit (ExitCode(ExitFailure, ExitSuccess))
+
+import Types (ClientDirective(..), Command(..))
+
+type CommandObj = (Command, [String])
+
+type ClientSend = ClientDirective -> IO ()
+
+startCommandLoop :: ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe Command -> IO ()
+startCommandLoop clientSend getNextCommand initialGhcOpts mbInitial = do
+    let processNextCommand :: Ghc (Maybe CommandObj)
+        processNextCommand = do
+            mbNextCmd <- liftIO getNextCommand
+            case mbNextCmd of
+                Nothing ->
+                    -- Exit
+                    return Nothing
+                Just (cmd, ghcOpts) ->
+                    if ghcOpts /= initialGhcOpts
+                        then return (Just (cmd, ghcOpts))
+                        else runCommand clientSend cmd >> processNextCommand
+
+    continue <- runGhc (Just libdir) $ do
+        configSession clientSend initialGhcOpts
+        case mbInitial of
+            Just initialCmd -> runCommand clientSend initialCmd
+            Nothing -> return ()
+        processNextCommand
+
+    case continue of
+        Nothing ->
+            -- Exit
+            return ()
+        Just (cmd, ghcOpts) -> startCommandLoop clientSend getNextCommand ghcOpts (Just cmd)
+
+configSession :: ClientSend -> [String] -> Ghc ()
+configSession clientSend ghcOpts = do
+    info "Reading initial DynFlags"
+    initialDynFlags <- getSessionDynFlags
+    let updatedDynFlags = initialDynFlags
+            { log_action = logAction clientSend
+            , hscTarget = HscInterpreted
+            }
+    info "Parsing ghcOpts DynFlags"
+    (finalDynFlags, _, _) <- parseDynamicFlags updatedDynFlags (map noLoc ghcOpts)
+    info "Setting final DynFlags"
+    _ <- setSessionDynFlags finalDynFlags
+    return ()
+
+runCommand :: ClientSend -> Command -> Ghc ()
+runCommand clientSend (CmdCheck file) = do
+    info $ "Guessing Target: " ++ file
+    let noPhase = Nothing
+    target <- guessTarget file noPhase
+    info "Setting target list"
+    setTargets [target]
+    info "Loading all targets"
+    let handler err = printException err >> return Failed
+    flag <- handleSourceError handler (load LoadAllTargets)
+    liftIO $ case flag of
+        Succeeded -> clientSend (ClientExit ExitSuccess)
+        Failed -> clientSend (ClientExit (ExitFailure 1))
+
+logAction :: ClientSend -> Severity -> SrcSpan -> PprStyle -> Message -> IO ()
+logAction clientSend severity srcspan style msg =
+    let out = renderWithStyle fullMsg style
+        _ = severity
+    in clientSend (ClientStdout out)
+    where fullMsg = mkLocMessage srcspan msg
+
+
+info :: MonadIO m => String -> m ()
+info msg = liftIO $ do
+    now <- getCurrentTime
+    putStrLn $ show now ++ " " ++ msg

src/Main.hs

@@ -0,0 +1,43 @@
+module Main where
+
+import System.Environment (getProgName)
+import System.IO (hPutStrLn, stderr)
+
+import Client (getServerStatus, serverCommand, stopServer)
+import CommandArgs
+import Server (startServer)
+import Types (Command(..))
+
+defaultSocketFilename :: FilePath
+defaultSocketFilename = ".hdevtools.sock"
+
+getSocketFilename :: Maybe FilePath -> FilePath
+getSocketFilename Nothing = defaultSocketFilename
+getSocketFilename (Just f) = f
+
+main :: IO ()
+main = do
+    args <- loadHDevTools
+    let sock = getSocketFilename (socket args)
+    case args of
+        Admin {} -> doAdmin sock args
+        Check {} -> doCheck sock args
+
+doAdmin :: FilePath -> HDevTools -> IO ()
+doAdmin sock args
+    | start_server args = startServer sock
+    | status args = getServerStatus sock
+    | stop_server args = stopServer sock
+    | otherwise = do
+        progName <- getProgName
+        hPutStrLn stderr "You must provide a command. See:"
+        hPutStrLn stderr $ progName ++ " --help"
+
+doCheck :: FilePath -> HDevTools -> IO ()
+doCheck sock args
+    | null (file args) = do
+        progName <- getProgName
+        hPutStrLn stderr "You must provide a haskell source file. See:"
+        hPutStrLn stderr $ progName ++ " check --help"
+    | otherwise = do
+        serverCommand sock (CmdCheck (file args)) (ghcOpts args)

src/Server.hs

@@ -0,0 +1,73 @@
+module Server where
+
+import Control.Exception (bracket, tryJust)
+import Control.Monad (guard)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Network (PortID(UnixSocket), Socket, accept, listenOn, sClose)
+import System.Directory (removeFile)
+import System.Exit (ExitCode(ExitSuccess))
+import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn)
+import System.IO.Error (isDoesNotExistError)
+
+import CommandLoop (startCommandLoop)
+import Types (ClientDirective(..), Command, ServerDirective(..))
+import Util (readMaybe)
+
+startServer :: FilePath -> IO ()
+startServer socketPath = do
+    let removeSocketFile :: IO ()
+        removeSocketFile = do
+            -- Ignore possible error if socket file does not exist
+            _ <- tryJust (guard . isDoesNotExistError) $ removeFile socketPath
+            return ()
+
+    bracket
+        (listenOn (UnixSocket socketPath))
+        (\sock -> sClose sock >> removeSocketFile)
+        $ \sock -> do
+            currentClient <- newIORef Nothing
+            startCommandLoop (clientSend currentClient) (getNextCommand currentClient sock) [] Nothing
+
+clientSend :: IORef (Maybe Handle) -> ClientDirective -> IO ()
+clientSend currentClient clientDirective = do
+    mbH <- readIORef currentClient
+    case mbH of
+        Just h -> do
+            -- TODO catch exception
+            hPutStrLn h (show clientDirective)
+            hFlush h
+        Nothing -> error "This is impossible"
+
+getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, [String]))
+getNextCommand currentClient sock = do
+    checkCurrent <- readIORef currentClient
+    case checkCurrent of
+        Just h -> hClose h
+        Nothing -> return ()
+    (h, _, _) <- accept sock
+    writeIORef currentClient (Just h)
+    msg <- hGetLine h -- TODO catch exception
+    putStrLn msg
+    let serverDirective = readMaybe msg
+    case serverDirective of
+        Nothing -> do
+            clientSend currentClient $ ClientUnexpectedError $
+                "The client sent an invalid message to the server: " ++ show msg
+            getNextCommand currentClient sock
+        Just (SrvCommand cmd ghcOpts) -> do
+            return $ Just (cmd, ghcOpts)
+        Just SrvStatus -> do
+            mapM_ (clientSend currentClient) $
+                [ ClientStdout "Server is running."
+                , ClientExit ExitSuccess
+                ]
+            getNextCommand currentClient sock
+        Just SrvExit -> do
+            mapM_ (clientSend currentClient) $
+                [ ClientStdout "Shutting down server."
+                , ClientExit ExitSuccess
+                ]
+            -- Must close the handle here because we are exiting the loop so it
+            -- won't be closed in the code above
+            hClose h
+            return Nothing