git.iko.soy/rowtype-yoga/purescript-native
on ebbc4e4 help sign in
rowtype-yoga/purescript-native/psc-ide-server/Main.hs
173 lines 6.3 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Main
4-- Description : The server accepting commands for psc-ide
5-- Copyright : Christoph Hegemann 2016
6-- License : MIT (http://opensource.org/licenses/MIT)
7--
8-- Maintainer : Christoph Hegemann <christoph.hegemann1337@gmail.com>
9-- Stability : experimental
10--
11-- |
12-- The server accepting commands for psc-ide
13-----------------------------------------------------------------------------
15{-# LANGUAGE ConstraintKinds #-}
16{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE MultiParamTypeClasses #-}
18{-# LANGUAGE OverloadedStrings #-}
19{-# LANGUAGE PackageImports #-}
20{-# LANGUAGE TemplateHaskell #-}
22module Main where
24import Prelude ()
25import Prelude.Compat
27import Control.Concurrent (forkFinally)
28import Control.Concurrent.STM
29import Control.Exception (bracketOnError, catchJust)
30import Control.Monad
31import Control.Monad.Error.Class
32import "monad-logger" Control.Monad.Logger
33import Control.Monad.Reader
34import Control.Monad.Trans.Except
35import qualified Data.Text as T
36import qualified Data.Text.IO as T
37import Data.Version (showVersion)
38import Language.PureScript.Ide
39import Language.PureScript.Ide.Util
40import Language.PureScript.Ide.Error
41import Language.PureScript.Ide.Types
42import Language.PureScript.Ide.Watcher
43import Network hiding (socketPort)
44import Network.BSD (getProtocolNumber)
45import Network.Socket hiding (PortNumber, Type,
46 accept, sClose)
47import Options.Applicative
48import System.Directory
49import System.FilePath
50import System.IO
51import System.IO.Error (isEOFError)
53import qualified Paths_purescript as Paths
55-- "Borrowed" from the Idris Compiler
56-- Copied from upstream impl of listenOn
57-- bound to localhost interface instead of iNADDR_ANY
58listenOnLocalhost :: PortID -> IO Socket
59listenOnLocalhost (PortNumber port) = do
60 proto <- getProtocolNumber "tcp"
61 localhost <- inet_addr "127.0.0.1"
62 bracketOnError
63 (socket AF_INET Stream proto)
64 sClose
65 (\sock -> do
66 setSocketOption sock ReuseAddr 1
67 bindSocket sock (SockAddrInet port localhost)
68 listen sock maxListenQueue
69 pure sock)
70listenOnLocalhost _ = error "Wrong Porttype"
72data Options = Options
73 { optionsDirectory :: Maybe FilePath
74 , optionsOutputPath :: FilePath
75 , optionsPort :: PortID
76 , optionsDebug :: Bool
77 }
79main :: IO ()
80main = do
81 Options dir outputPath port debug <- execParser opts
82 maybe (pure ()) setCurrentDirectory dir
83 serverState <- newTVarIO emptyPscIdeState
84 cwd <- getCurrentDirectory
85 let fullOutputPath = cwd </> outputPath
87 doesDirectoryExist fullOutputPath
88 >>= flip unless
89 (do putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath)
90 createDirectory fullOutputPath
91 putStrLn "This usually means you didn't compile your project yet."
92 putStrLn "psc-ide needs you to compile your project (for example by running pulp build)"
93 )
95 _ <- forkFinally (watcher serverState fullOutputPath) print
96 let conf =
97 Configuration
98 {
99 confDebug = debug
100 , confOutputPath = outputPath
101 }
102 let env =
103 PscIdeEnvironment
104 {
105 envStateVar = serverState
106 , envConfiguration = conf
107 }
108 startServer port env
109 where
110 parser =
111 Options <$>
112 optional (strOption (long "directory" <> short 'd')) <*>
113 strOption (long "output-directory" <> value "output/") <*>
114 (PortNumber . fromIntegral <$>
115 option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*>
116 switch (long "debug")
117 opts = info (version <*> helper <*> parser) mempty
118 version = abortOption
119 (InfoMsg (showVersion Paths.version))
120 (long "version" <> help "Show the version number")
122startServer :: PortID -> PscIdeEnvironment -> IO ()
123startServer port env = withSocketsDo $ do
124 sock <- listenOnLocalhost port
125 runLogger (runReaderT (forever (loop sock)) env)
126 where
127 runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (envConfiguration env))
129 loop :: (PscIde m, MonadLogger m) => Socket -> m ()
130 loop sock = do
131 accepted <- runExceptT $ acceptCommand sock
132 case accepted of
133 Left err -> $(logDebug) err
134 Right (cmd, h) -> do
135 case decodeT cmd of
136 Just cmd' -> do
137 result <- runExceptT (handleCommand cmd')
138 -- $(logDebug) ("Answer was: " <> T.pack (show result))
139 liftIO (hFlush stdout)
140 case result of
141 -- What function can I use to clean this up?
142 Right r -> liftIO $ T.hPutStrLn h (encodeT r)
143 Left err -> liftIO $ T.hPutStrLn h (encodeT err)
144 Nothing -> do
145 $(logDebug) ("Parsing the command failed. Command: " <> cmd)
146 liftIO $ do
147 T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))
148 hFlush stdout
149 liftIO (hClose h)
152acceptCommand :: (MonadIO m, MonadLogger m, MonadError T.Text m)
153 => Socket -> m (T.Text, Handle)
154acceptCommand sock = do
155 h <- acceptConnection
156 $(logDebug) "Accepted a connection"
157 cmd' <- liftIO (catchJust
158 -- this means that the connection was
159 -- terminated without receiving any input
160 (\e -> if isEOFError e then Just () else Nothing)
161 (Just <$> T.hGetLine h)
162 (const (pure Nothing)))
163 case cmd' of
164 Nothing -> throwError "Connection was closed before any input arrived"
165 Just cmd -> do
166 $(logDebug) cmd
167 pure (cmd, h)
168 where
169 acceptConnection = liftIO $ do
170 (h,_,_) <- accept sock
171 hSetEncoding h utf8
172 hSetBuffering h LineBuffering
173 pure h