Server.hs

-- | RELP (Reliable Event Logging Protocol) simple server
{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
module Network.RELP.Server
  (
    -- * Running a standalone RELP server
    RelpServerOpts(..), RelpMessageHandler
  , runRelpServer
  , runTLSServer, runTLSServer'
  , RelpFlow
  , buildRelpServerHandle
  )
  where

import Prelude hiding (getContents, take)
import Network.Socket (PortNumber, AddrInfo(..),
  AddrInfoFlag(..), SocketType(..), SocketOption(..))
import qualified Network.Socket as S
import Network.Socket.ByteString.Lazy ( getContents, sendAll )
import qualified Data.ByteString as B
import Network.TLS
import Network.Simple.TCP.TLS
import Data.X509.CertificateStore
import Data.Attoparsec.ByteString (parseOnly, string, take,
  takeWhile1, word8, many', Parser)
import qualified Data.Attoparsec.ByteString.Lazy as LBP
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.Default
import Data.ByteString (ByteString)
import Data.ByteString.UTF8 (toString)
import Data.Functor ( ($>), (<&>), void )
import Control.Applicative ( Alternative((<|>)) )
import Control.Monad (forever)
import Control.Concurrent
import System.IO hiding (getContents)
import Control.Exception (SomeException)
import qualified Control.Exception as E

-- | Relp server options
data RelpFlow s =>  RelpServerOpts s = RelpServerPrefs
  { relpServerReport :: s -> SockAddr -> String -> String -> IO ()
  , relpServerAccept :: s -> SockAddr -> RelpOffers -> IO Bool
  , relpServerNotify :: s -> RelpMessageHandler
  , relpServerReduce :: s -> SockAddr -> IO ()
  , relpServerFinish :: s -> SockAddr -> IO ()
  }

-- | Relp server options stub
instance RelpFlow s => Default (RelpServerOpts s) where
  def = RelpServerPrefs
    (\_ a t -> hPutStrLn stderr . ((show a <> " " <> t <> ": ")<>))
    (\_ _ _ -> pure True)
    (\_ _ _ -> pure True)
    (\_ _ -> pure ())
    (\_ _ -> pure ())

-- | Message handler callback.
type RelpMessageHandler =
  SockAddr -- ^ Client connection address
  -> ByteString -- ^ Log message
  -> IO Bool -- ^ Reject message (reply error RSP) if False

data RelpCommand = RelpRSP | RelpOPEN | RelpSYSLOG | RelpCLOSE
  | RelpCommand ByteString
  deriving (Show, Eq)

data RelpMessage = RelpMessage
  { relpTxnr :: Int
  , relpCommand :: RelpCommand
  , relpData :: ByteString
  } deriving (Show, Eq)

type RelpOffers = [(ByteString, ByteString)]

class RelpFlow a where
  flowRecv :: a -> IO B8.ByteString
  flowSend :: a -> B8.ByteString -> IO ()
  flowClose :: a -> IO ()

instance RelpFlow Socket where
  flowRecv = getContents
  flowSend = sendAll
  flowClose = S.close

instance RelpFlow Context where
  flowRecv = fmap B8.fromStrict . recvData
  flowSend = sendData
  flowClose = bye

-- | Provides a simple RELP server.
runRelpServer :: PortNumber -> RelpMessageHandler -> IO ()
runRelpServer portnum hdl = srv where
  srv = runTCPServer Nothing portnum shl
  shl = buildRelpServerHandle def{relpServerNotify = const hdl}
  runTCPServer mhost port server = withSocketsDo $ do
      addr <- resolve
      E.bracket (open addr) S.close loop
    where
      resolve = do
          let hints = S.defaultHints {
                  addrFlags = [AI_PASSIVE]
                , addrSocketType = Stream
                }
          head <$> S.getAddrInfo (Just hints) mhost (Just $ show port)
      open addr = E.bracketOnError (S.openSocket addr) S.close $ \sock -> do
          S.setSocketOption sock ReuseAddr 1
          S.withFdSocket sock S.setCloseOnExecIfNeeded
          S.bind sock $ addrAddress addr
          S.listen sock 1024
          return sock
      loop sock = forever $ E.bracketOnError (S.accept sock) (S.close . fst)
          $ \(conn, peer) -> void $
              forkFinally (server conn peer) (const (S.gracefulClose conn 5000))

-- | Provides a simple TLS RELP server.
runTLSServer' :: FilePath -> FilePath -> FilePath
              -> ServiceName -> RelpServerOpts Context -> IO ()
runTLSServer' fca fcr fky snm cb = lcrd >>= \cr ->
  readCertificateStore fca >>= \ca ->
  runTLSServer (makeServerParams cr ca) HostAny snm cb where
    lcrd = credentialLoadX509Chain fcr [fca] fky <&> either (error . show) id

-- | Provides a TLS RELP server
runTLSServer :: ServerParams -> HostPreference
             -> String -> RelpServerOpts Context -> IO ()
runTLSServer params hostprefs servicename opts = srv where
  srv = listen hostprefs servicename acp
  acp (sock, _peer) = forever (acceptFork params sock opn)
  opn (ctx, peer) = buildRelpServerHandle opts ctx peer

-- | Build relp messages handler.
buildRelpServerHandle :: RelpFlow s
                      => RelpServerOpts s -- ^ Server options
                      -> s -- ^ Some server socket
                      -> SockAddr -- ^ Client address
                      -> IO () -- ^ Never returns
buildRelpServerHandle RelpServerPrefs{..} = safeRun where
  safeRun s a = E.try (handleMessage s a) >>= check s a

  check s a (Right ()) = relpServerFinish s a
  check s a (Left (e :: SomeException)) =
    relpServerReport s a "ERROR" (show e) >> relpServerFinish s a

  handleMessage s a = do
    status <- flowRecv s >>= processMessage s a
    if status then handleMessage s a else handleClose s a
  
  handleClose s a = relpServerReduce s a >> flowClose s

  processMessage s a = parseLazy_ err process relpParser where
    err e = relpServerReport s a "ERROR" ("parser: " ++ show e) $> False
    process msg@RelpMessage{ relpCommand = RelpOPEN, relpData = txt } = do
      let offers = parse_ (const []) id relpOffersParser txt
      -- NOTE only version 0 supported!
      let versionValid = (Just "0" ==) $ lookup "relp_version" offers
      if versionValid then do
          relpRsp s msg $ "200 OK "
            ++ "relp_version=0\nrelp_software=hsRELP\ncommands="
            ++ maybe "syslog" toString (lookup "commands" offers)
          relpServerAccept s a offers
        else do
          relpServerReport s a "ERROR" ("unsupported version " <> show offers)
          relpNAck s msg "unsupported RELP version" >> return False
    process msg@RelpMessage{ relpCommand = RelpSYSLOG, relpData = txt } = do
      status <- relpServerNotify s a txt
      if status then relpAck s msg else relpNAck s msg "rejected"
      return status
    process msg = do
      relpServerReport s a "ERROR" ("strange message command: " ++ show msg)
      relpNAck s msg "unexpected message command"
      return False

relpParser :: Parser RelpMessage
relpParser = do
  txnr <- decimal <* space
  command <- parseCommand <* space
  datalen <- decimal <* space
  content <- take datalen
  return $ RelpMessage txnr command content
  where
  decimal :: Integral a => Parser a
  decimal = B.foldl' step 0 `fmap` takeWhile1 isDecimal where
    step a c = a * 10 + fromIntegral (c - 48)
    isDecimal c = c >= 48 && c <= 57
  space = word8 32
  parseCommand =
    string "syslog" $> RelpSYSLOG
    <|> string "close" $> RelpCLOSE
    <|> string "open" $> RelpOPEN
    <|> string "rsp" $> RelpRSP
    <|> RelpCommand <$> takeWhile1 (/= 32)

relpOffersParser :: Parser RelpOffers
relpOffersParser = many' $ pair <* word8 sep
  where
  sep = 10 -- \n
  der = 61 -- '='
  pair = liftA2 (,)
    (takeWhile1 (\c-> c /= der && c /= sep))
    (word8 der *> takeWhile1 (/= sep) <|> return "")

relpRsp :: RelpFlow s => s -> RelpMessage -> String -> IO ()
relpRsp sock msg reply = flowSend sock mkReply
  -- putStrLn $ prettyHex $ B8.toStrict mkReply
  where
  mkReply = B8.pack $ show (relpTxnr msg) ++ " rsp "
    ++ show (length reply) ++ " " ++ reply ++ "\n"

relpAck :: RelpFlow s => s -> RelpMessage -> IO ()
relpAck sock msg = relpRsp sock msg "200 OK"

relpNAck :: RelpFlow s => s -> RelpMessage -> String -> IO ()
relpNAck sock msg err = relpRsp sock msg $ "500 " ++ err

-- just shortcuts
parse_ :: (String -> c) -> (b -> c) -> Parser b -> ByteString -> c
parse_ err ok p = either err ok . parseOnly p

parseLazy_ :: (String -> c) -> (b -> c) -> Parser b -> B8.ByteString -> c
parseLazy_ err ok p = either err ok . LBP.eitherResult . LBP.parse p