Reaktor.API: make configurable

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