Permalink
Browse files

wip

  • Loading branch information...
1 parent 82edc20 commit 6eed4b4099dfc6b6eb7780f84316eaa1ccfa529f @jystic committed Apr 2, 2013
Showing with 62 additions and 26 deletions.
  1. +55 −22 src/Main.hs
  2. +7 −4 sudo4win.cabal
View
@@ -3,41 +3,74 @@
module Main (main) where
+import Control.Applicative ((<$>))
+import Control.Exception (throw)
import Control.Concurrent
+import Control.Monad (forever)
+import System.Environment (getArgs)
import System.Win32.SystemServices.Services
import System.Win32.Types
+import Control.Distributed.Process
+import Control.Distributed.Process.Node
+import Network.Transport.TCP
+
+import Network (withSocketsDo)
+
main :: IO ()
-main = do
- gState <- newMVar (1, SERVICE_STATUS WIN32_OWN_PROCESS
- START_PENDING [] nO_ERROR 0 0 3000)
- mStop <- newEmptyMVar
+main = withSocketsDo $ do
+ args <- getArgs
+ case args of
+ ["--service"] -> runService
+ ["--server"] -> runServer
+ xs -> runClient xs
+
+------------------------------------------------------------------------
+-- Client
+
+runClient :: [String] -> IO ()
+runClient _ = do
+ transport <- either throw id <$>
+ createTransport "localhost" "30020" defaultTCPParameters
+ node <- newLocalNode transport initRemoteTable
+ runProcess node $ do
+ return ()
+
+------------------------------------------------------------------------
+-- Server
+
+runServer :: IO ()
+runServer = do
+ forkServer
+ putStrLn "Running sudo server..."
+ forever $ threadDelay 1000000
+
+forkServer :: IO ProcessId
+forkServer = do
+ transport <- either throw id <$>
+ createTransport "localhost" "30020" defaultTCPParameters
+ node <- newLocalNode transport initRemoteTable
+ print (localNodeId node)
+ forkProcess node $ forever $ do
+ str <- expect
+ liftIO (putStrLn str)
+
+------------------------------------------------------------------------
+-- Windows Service
+
+runService :: IO ()
+runService = do
+ gState <- newMVar (1, SERVICE_STATUS WIN32_OWN_PROCESS START_PENDING [] nO_ERROR 0 0 3000)
+ mStop <- newEmptyMVar
startServiceCtrlDispatcher "sudo4win" 3000
(svcCtrlHandler mStop gState)
(svcMain mStop gState)
-
svcMain :: MVar () -> MVar (DWORD, SERVICE_STATUS) -> ServiceMainFunction
svcMain mStop gState _ _ h = do
reportSvcStatus h RUNNING nO_ERROR 0 gState
- appendFile "c:\\test.txt" "1"
- threadDelay 1000000
- appendFile "c:\\test.txt" "2"
- threadDelay 1000000
- appendFile "c:\\test.txt" "3"
- threadDelay 1000000
- appendFile "c:\\test.txt" "4"
- threadDelay 1000000
- appendFile "c:\\test.txt" "5"
+ forkServer
takeMVar mStop
- threadDelay 1000000
- appendFile "c:\\test.txt" "."
- threadDelay 1000000
- appendFile "c:\\test.txt" "."
- threadDelay 1000000
- appendFile "c:\\test.txt" "."
- threadDelay 1000000
- appendFile "c:\\test.txt" "Stahp\n"
reportSvcStatus h STOPPED nO_ERROR 0 gState
reportSvcStatus :: HANDLE -> SERVICE_STATE -> DWORD -> DWORD
View
@@ -10,14 +10,17 @@ build-type: Simple
cabal-version: >=1.6
-Executable sudo4win
+Executable sudo
main-is: Main.hs
hs-source-dirs: src
build-depends:
- base == 4.*
- , Win32 == 2.3.*
- , Win32-services == 0.2.*
+ base == 4.*
+ , distributed-process == 0.4.*
+ , network-transport-tcp == 0.3.*
+ , network
+ , Win32
+ , Win32-services == 0.2.*
ghc-options: -Wall -threaded
ld-options: -enable-stdcall-fixup

0 comments on commit 6eed4b4

Please sign in to comment.