periodic-server-1.1.7.1: app/periodicd.hs

{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Main
  ( main
  ) where


import           Control.Monad                  (when)
import           Data.Maybe                     (fromMaybe)
import           Data.String                    (fromString)
import           Metro.SocketServer             (socketServer)
import           Metro.TP.TLS                   (makeServerParams', tlsConfig)
import           Metro.TP.WebSockets            (serverConfig)
import           Metro.TP.XOR                   (xorConfig)
import           Metro.Utils                    (setupLog)
import           Periodic.Server                (startServer)
import           Periodic.Server.Persist        (Persist, PersistConfig)
import           Periodic.Server.Persist.PSQL   (PSQL)
import           Periodic.Server.Persist.SQLite (SQLite)
import           System.Environment             (getArgs, lookupEnv)
import           System.Exit                    (exitSuccess)
import           System.Log                     (Priority (..))

data Options = Options
    { host      :: String
    , xorFile   :: FilePath
    , storePath :: FilePath
    , useTls    :: Bool
    , useWs     :: Bool
    , certKey   :: FilePath
    , cert      :: FilePath
    , caStore   :: FilePath
    , showHelp  :: Bool
    , logLevel  :: Priority
    }

options :: Maybe String -> Maybe String -> Options
options h f = Options
  { host    = fromMaybe "unix:///tmp/periodic.sock" h
  , xorFile = fromMaybe "" f
  , storePath = "data.sqlite"
  , useTls = False
  , useWs = False
  , certKey = "server-key.pem"
  , cert = "server.pem"
  , caStore = "ca.pem"
  , showHelp  = False
  , logLevel = ERROR
  }

parseOptions :: [String] -> Options -> Options
parseOptions []                  opt = opt
parseOptions ("-H":x:xs)         opt = parseOptions xs opt { host      = x }
parseOptions ("--host":x:xs)     opt = parseOptions xs opt { host      = x }
parseOptions ("--xor":x:xs)      opt = parseOptions xs opt { xorFile   = x }
parseOptions ("-p":x:xs)         opt = parseOptions xs opt { storePath = x }
parseOptions ("--path":x:xs)     opt = parseOptions xs opt { storePath = x }
parseOptions ("-h":xs)           opt = parseOptions xs opt { showHelp  = True }
parseOptions ("--help":xs)       opt = parseOptions xs opt { showHelp  = True }
parseOptions ("--tls":xs)        opt = parseOptions xs opt { useTls = True }
parseOptions ("--ws":xs)         opt = parseOptions xs opt { useWs = True }
parseOptions ("--cert-key":x:xs) opt = parseOptions xs opt { certKey = x }
parseOptions ("--cert":x:xs)     opt = parseOptions xs opt { cert = x }
parseOptions ("--ca":x:xs)       opt = parseOptions xs opt { caStore = x }
parseOptions ("--log":x:xs)      opt = parseOptions xs opt { logLevel = read x }
parseOptions (_:xs)              opt = parseOptions xs opt

printHelp :: IO ()
printHelp = do
  putStrLn "periodicd - Periodic task system server"
  putStrLn ""
  putStrLn "Usage: periodicd [--host|-H HOST] [--path|-p PATH] [--xor FILE|--ws|--tls [--hostname HOSTNAME] [--cert-key FILE] [--cert FILE] [--ca FILE]]"
  putStrLn ""
  putStrLn "Available options:"
  putStrLn "  -H --host     Socket path [$PERIODIC_PORT]"
  putStrLn "                eg: tcp://:5000 (optional: unix:///tmp/periodic.sock) "
  putStrLn "  -p --path     State store path (optional: data.sqlite)"
  putStrLn "                eg: file://data.sqlite"
  putStrLn "                eg: postgres://host='127.0.0.1' port=5432 dbname='periodicd' user='postgres' password=''"
  putStrLn "     --xor      XOR Transport encode file [$XOR_FILE]"
  putStrLn "     --tls      Use tls transport"
  putStrLn "     --ws       Use websockets transport"
  putStrLn "     --cert-key Private key associated"
  putStrLn "     --cert     Public certificate (X.509 format)"
  putStrLn "     --ca       Server will use these certificates to validate clients"
  putStrLn "     --log      Set log level DEBUG INFO NOTICE WARNING ERROR CRITICAL ALERT EMERGENCY (optional: ERROR)"
  putStrLn "  -h --help     Display help message"
  putStrLn ""
  putStrLn "Version: v1.1.7.0"
  putStrLn ""
  exitSuccess

main :: IO ()
main = do
  h <- lookupEnv "PERIODIC_PORT"
  f <- lookupEnv "XOR_FILE"

  opts@Options {..} <- flip parseOptions (options h f) <$> getArgs

  when showHelp printHelp

  setupLog logLevel

  if take 11 storePath == "postgres://" then
    run opts (fromString $ drop 11 storePath :: PersistConfig PSQL)
  else if take 7 storePath == "file://" then
    run opts (fromString $ drop 7 storePath :: PersistConfig SQLite)
  else
    run opts (fromString storePath :: PersistConfig SQLite)

run :: Persist db => Options -> PersistConfig db -> IO ()
run Options {useTls = True, ..} config = do
    prms <- makeServerParams' cert [] certKey caStore
    startServer config (tlsConfig prms) (socketServer host)

run Options {useWs = True, host} config =
    startServer config serverConfig (socketServer host)

run Options {xorFile = "", host} config =
    startServer config id (socketServer host)

run Options {xorFile = f, host} config =
    startServer config (xorConfig f) (socketServer host)