aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Network/Socket/Extended.hs78
-rw-r--r--src/Reaktor.hs6
-rw-r--r--src/Reaktor/API.hs49
-rw-r--r--src/System/Posix/Files/Extended.hs17
-rw-r--r--src/main.hs7
5 files changed, 149 insertions, 8 deletions
diff --git a/src/Network/Socket/Extended.hs b/src/Network/Socket/Extended.hs
new file mode 100644
index 0000000..8d71956
--- /dev/null
+++ b/src/Network/Socket/Extended.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+module Network.Socket.Extended
+ ( module Exports
+ , openSocket
+ , closeSocket
+ , getAddrFamily
+ , getAddrPort
+ , readListenString
+ ) where
+
+import qualified Network.Socket as Exports
+
+import Network.Socket
+import Network.URI
+import Network.Wai.Handler.Warp (Port)
+import System.Posix.Files.Extended (removeIfExists)
+
+openSocket :: SockAddr -> IO Socket
+openSocket sockAddr = do
+ let family = getAddrFamily sockAddr
+ case sockAddr of
+ SockAddrUnix sockFile -> removeIfExists sockFile
+ _ -> return ()
+ socket family Stream defaultProtocol
+
+closeSocket :: Socket -> IO ()
+closeSocket sock = do
+ name <- getSocketName sock
+ close sock
+ case name of
+ SockAddrUnix sockFile -> removeIfExists sockFile
+ _ -> return ()
+
+getAddrFamily :: SockAddr -> Family
+getAddrFamily = \case
+ SockAddrInet _ _ -> AF_INET
+ SockAddrInet6 _ _ _ _ -> AF_INET6
+ SockAddrUnix _ -> AF_UNIX
+ sockAddr -> error ("getAddrFamily: don't know family of " <> show sockAddr)
+
+getAddrPort :: SockAddr -> Port
+getAddrPort = \case
+ SockAddrInet portNumber _ -> fromIntegral portNumber
+ SockAddrInet6 portNumber _ _ _ -> fromIntegral portNumber
+ _ -> 0
+
+readListenString :: String -> IO (Either String SockAddr)
+readListenString cListen =
+ case parseURI cListen of
+ Just URI{..} ->
+ case uriScheme of
+ "inet:" ->
+ case uriAuthority of
+ Just URIAuth{..} -> do
+ let
+ hostName =
+ if uriRegName == "" then
+ Nothing
+ else
+ Just uriRegName
+ serviceName =
+ if uriPort == "" then
+ Nothing
+ else
+ Just (tail uriPort)
+ AddrInfo{..}:_ <-
+ getAddrInfo Nothing hostName serviceName
+ return (Right addrAddress)
+ Nothing ->
+ return (Left "could not parse inet listen string")
+ "unix:" ->
+ return (Right (SockAddrUnix uriPath))
+ invalid ->
+ return (Left ("unsupported listen scheme: " <> invalid))
+ Nothing ->
+ return (Left "could not parse listen string")
+
diff --git a/src/Reaktor.hs b/src/Reaktor.hs
index 0d4e42c..cc93109 100644
--- a/src/Reaktor.hs
+++ b/src/Reaktor.hs
@@ -41,8 +41,8 @@ import System.IO (hIsTerminalDevice)
import System.Posix.Signals
-run :: Config -> (Actions -> IO [Message -> IO ()]) -> IO ()
-run Config{..} getPlugins =
+run :: Config -> Maybe API.Config -> (Actions -> IO [Message -> IO ()]) -> IO ()
+run Config{..} apiConfig getPlugins =
if cUseTLS then do
s <- TLS.getDefaultClientSettings (cHostName, BS.pack cServiceName)
TLS.connect s cHostName cServiceName $ \(ctx, sockAddr) ->
@@ -84,7 +84,7 @@ run Config{..} getPlugins =
plugins <- getPlugins actions
threads <- mapM (\f -> forkIO $ f `finally` shutdown) [
- API.main actions,
+ API.main actions apiConfig,
receiver actions putInMsg sockRecv,
logger cLogHandle takeLog,
pinger aSend,
diff --git a/src/Reaktor/API.hs b/src/Reaktor/API.hs
index 3fff464..4cc4fe9 100644
--- a/src/Reaktor/API.hs
+++ b/src/Reaktor/API.hs
@@ -7,12 +7,19 @@
module Reaktor.API where
import Blessings
+import Control.Concurrent
+import Control.Exception (bracket)
+import Control.Monad
import Control.Monad.IO.Class
+import Data.Aeson
+import Data.Aeson.Types (typeMismatch)
+import Data.Function ((&))
import Data.Proxy (Proxy)
import qualified Data.Text as T
+import Network.Socket.Extended
import Network.Wai
import Network.Wai.Handler.Warp
-import Reaktor.Internal
+import Reaktor.Internal (Actions(..),Message(..))
import Reaktor.IRC
import Servant
@@ -21,14 +28,48 @@ type API =
ReqBody '[JSON] Message :> PostAccepted '[JSON] NoContent
+data Config = Config
+ { cListen :: String
+ }
+instance FromJSON Config where
+ parseJSON = \case
+ Object v -> do
+ cListen <- v .: "listen"
+ pure Config{..}
+ invalid -> typeMismatch "Config" invalid
+
+
api :: Proxy API
api = Proxy
-main :: Actions -> IO ()
-main Actions{..} = do
- run 7777
+main :: Actions -> Maybe Config -> IO ()
+main Actions{..} = \case
+ Just Config{..} ->
+ either disable enable =<< readListenString cListen
+ Nothing ->
+ disable "no configuration"
where
+ enable sockAddr =
+ bracket
+ (openSocket sockAddr)
+ closeSocket
+ $ \sock -> do
+ aLog $ SGR [38,5,155]
+ ("* enabling API on " <> Plain (T.pack $ show sockAddr))
+ let port = getAddrPort sockAddr
+ settings = defaultSettings & setPort port
+ bind sock sockAddr
+ listen sock maxListenQueue
+ runSettingsSocket settings sock
+ $ app
+
+ disable :: String -> IO ()
+ disable reason = do
+ aLog $ SGR [38,5,196]
+ ("! disabling API due to " <> Plain (T.pack reason))
+ forever $ threadDelay 60000
+
app :: Application
app = serve api server
diff --git a/src/System/Posix/Files/Extended.hs b/src/System/Posix/Files/Extended.hs
new file mode 100644
index 0000000..da82359
--- /dev/null
+++ b/src/System/Posix/Files/Extended.hs
@@ -0,0 +1,17 @@
+module System.Posix.Files.Extended
+ ( module Exports
+ , removeIfExists
+ ) where
+
+import qualified System.Posix.Files as Exports
+
+import Control.Exception (catch, throwIO)
+import System.IO.Error (isDoesNotExistError)
+import System.Posix.Files (removeLink)
+
+removeIfExists :: FilePath -> IO ()
+removeIfExists fileName = removeLink fileName `catch` handleExists
+ where handleExists e
+ | isDoesNotExistError e = return ()
+ | otherwise = throwIO e
+
diff --git a/src/main.hs b/src/main.hs
index 89966c2..51bc17c 100644
--- a/src/main.hs
+++ b/src/main.hs
@@ -23,7 +23,7 @@ main = do
v <- preview _Value <$> readFile configPath
- Reaktor.run (reaktorConfig v) $ \actions ->
+ Reaktor.run (reaktorConfig v) (apiConfig v) $ \actions ->
mapM id [
Reaktor.Plugins.Mention.new actions,
Reaktor.Plugins.Ping.new actions,
@@ -32,6 +32,11 @@ main = do
]
+apiConfig :: (FromJSON b) => Maybe Value -> Maybe b
+apiConfig = \case
+ Just v -> maybe Nothing parseOrDie (v ^? key "API")
+ Nothing -> Nothing
+
reaktorConfig :: (FromJSON b, Default b) => Maybe Value -> b
reaktorConfig = maybe def parseOrDie
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 00:18:02 +0000