diff options
| -rw-r--r-- | reaktor2.cabal | 5 | ||||
| -rw-r--r-- | src/Reaktor.hs | 2 | ||||
| -rw-r--r-- | src/Reaktor/API.hs | 52 |
3 files changed, 58 insertions, 1 deletions
diff --git a/reaktor2.cabal b/reaktor2.cabal index 6757561..2c227dd 100644 --- a/reaktor2.cabal +++ b/reaktor2.cabal @@ -26,6 +26,7 @@ executable reaktor pcre-light, process, random, + servant-server, string-conversions, stringsearch, text, @@ -34,7 +35,9 @@ executable reaktor unagi-chan, unix, unordered-containers, - vector + vector, + wai, + warp default-language: Haskell2010 ghc-options: -O2 -Wall -threaded hs-source-dirs: src diff --git a/src/Reaktor.hs b/src/Reaktor.hs index 0910e0b..0d4e42c 100644 --- a/src/Reaktor.hs +++ b/src/Reaktor.hs @@ -26,6 +26,7 @@ import qualified Network.Simple.TCP as TCP import qualified Network.Simple.TCP.TLS as TLS import Network.Socket as Exports (HostName,ServiceName) import Prelude.Extended +import qualified Reaktor.API as API import Reaktor.Internal import Reaktor.Internal as Exports (Actions(..)) import Reaktor.Internal as Exports (Message(Message,Start)) @@ -83,6 +84,7 @@ run Config{..} getPlugins = plugins <- getPlugins actions threads <- mapM (\f -> forkIO $ f `finally` shutdown) [ + API.main actions, receiver actions putInMsg sockRecv, logger cLogHandle takeLog, pinger aSend, diff --git a/src/Reaktor/API.hs b/src/Reaktor/API.hs new file mode 100644 index 0000000..3fff464 --- /dev/null +++ b/src/Reaktor/API.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +module Reaktor.API where + +import Blessings +import Control.Monad.IO.Class +import Data.Proxy (Proxy) +import qualified Data.Text as T +import Network.Wai +import Network.Wai.Handler.Warp +import Reaktor.Internal +import Reaktor.IRC +import Servant + + +type API = + ReqBody '[JSON] Message :> PostAccepted '[JSON] NoContent + + +api :: Proxy API +api = Proxy + + +main :: Actions -> IO () +main Actions{..} = do + run 7777 + where + app :: Application + app = serve api server + + server :: Server API + server = + serveTest + + serveTest :: Message -> Handler NoContent + serveTest = \case + -- Allowing just private messages to (registered) channels for now. + msg@(Message Nothing PRIVMSG [msgtarget,_]) | isChannelName msgtarget -> do + liftIO $ aSend msg + return NoContent + _ -> + throwError err403 + where + -- Channel names are defined in RFC 2812, 1.3 + isChannelName msgtarget = + case T.uncons msgtarget of + Just (c, _) -> c `elem` ("&#+!" :: String) + Nothing -> False |