Initial commit

2022-04-09 21:36:23 +02:00
commit 6fa9746f36
12 changed files with 619 additions and 0 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module Main where
+
+import Soostone ( app, middleWare, AppState(AppState, sqliteFile) )
+
+import Control.Monad ( void, when )
+import Data.Version (showVersion)
+import Database.SQLite.Simple ( execute_, open, Connection )
+import Network.Wai.Handler.Warp ( run )
+import Options.Applicative
+    ( fullDesc,
+      execParser,
+      progDesc,
+      helper,
+      (<**>),
+      info,
+      command,
+      subparser,
+      strOption,
+      value,
+      showDefault,
+      metavar,
+      eitherReader,
+      option,
+      hidden,
+      help,
+      long,
+      infoOption,
+      Parser )
+import Paths_soostone ( version )
+import Prometheus ( register )
+import Prometheus.Metric.GHC ( ghcMetrics )
+import Prometheus.Metric.Proc ( procMetrics )
+import Text.Read ( readEither )
+
+
+versioner :: Parser (a -> a)
+versioner = infoOption (showVersion version) (long "version" <> help "Show version" <> hidden)
+
+data Command = Run ServerConfig
+             | Create ServerConfig
+
+data Config = Config {
+    serverCommand  :: Command
+  }
+
+parseConfig :: Parser Config
+parseConfig = Config <$> parseCommands
+
+data ServerConfig = ServerConfig {
+    serverPort :: Int
+  , sqliteDB   :: FilePath
+  }
+
+parseServerConf :: Parser ServerConfig
+parseServerConf = ServerConfig
+      <$> option
+            (eitherReader (readEither @Int))
+            (long "server-port" <> metavar "SERVER_PORT" <> help
+              "Port to use for the REST server"
+              <> showDefault
+              <> value 9000
+            )
+      <*> strOption
+          ( long "sqlite-db"
+         <> metavar "SQLITE_DB"
+         <> help "SQLite relation/database"
+         <> showDefault
+         <> value "soostone.sqlite3"
+         )
+
+parseCommands :: Parser Command
+parseCommands = subparser $ 
+  command
+    "run"
+    (info
+      (Run <$> parseServerConf <**> helper)
+      (  progDesc "Run the REST API webserver"
+      )
+    )
+  <>
+  command
+    "create-tables"
+    (info
+      (Create <$> parseServerConf <**> helper)
+      (  progDesc "Create the database"
+      )
+    )
+
+
+main :: IO ()
+main = do
+  Config{ .. } <-
+    execParser (info (parseConfig <**> helper <**> versioner) (fullDesc <> progDesc "Soostone"))
+
+  case serverCommand of
+    Run ServerConfig{..} -> do
+      when (sqliteDB == ":memory:") $ fail "In-memory DB is not supported!"
+      let appState = AppState { sqliteFile = sqliteDB }
+      void $ register ghcMetrics
+      void $ register procMetrics
+      run serverPort (middleWare $ app appState)
+    Create ServerConfig{..} -> do
+      when (sqliteDB == ":memory:") $ fail "In-memory DB is not supported!"
+      con <- open sqliteDB
+      createTables con
+ where
+  createTables :: Connection -> IO ()
+  createTables con = do
+    execute_ con "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, key TEXT, count INTEGER)"