Add run command taking --host and --port

2024-11-25 20:12:20 +03:00 · 2022-01-09 13:40:33 -05:00 · 2022-01-09 13:40:33 -05:00 · 8e6a660cb3
commit 8e6a660cb3
parent 9f91de9ff5
6 changed files with 49 additions and 15 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -7,6 +7,7 @@
 - `Tailwind.layoutWith`: don't hardcode `<body>` attrs
 - `runEma` and friends: 
  - return the monadic's action's return value or generated files (dependent type)
+- CLI: add `run` subcommand that takes `--host` and `--port` (and remove environment hacks of $HOST and $PORT)

 ## 0.2.0.0 -- 2021-11-21

--- a/ema.cabal
+++ b/ema.cabal
@ -40,6 +40,7 @@ library
    , base                    >=4.13.0.0 && <=4.17.0.0
    , constraints-extras
    , containers
+    , data-default
    , dependent-sum
    , dependent-sum-template
    , directory
--- a/src/Ema/App.hs
+++ b/src/Ema/App.hs
@ -29,8 +29,12 @@ import Ema.Class (Ema)
 import qualified Ema.Generate as Generate
 import qualified Ema.Server as Server
 import System.Directory (getCurrentDirectory)
-import System.Environment (lookupEnv)
-import UnliftIO (BufferMode (BlockBuffering, LineBuffering), MonadUnliftIO, hFlush, hSetBuffering)
+import UnliftIO
+  ( BufferMode (BlockBuffering, LineBuffering),
+    MonadUnliftIO,
+    hFlush,
+    hSetBuffering,
+  )

 -- | Pure version of @runEmaWith@ (i.e with no model).
 --
@ -46,7 +50,7 @@ runEmaPure render = do
  void $
    runEma (\act () () -> AssetGenerated Html $ render act) $ \act model -> do
      LVar.set model ()
-      when (act == Some CLI.Run) $ do
+      when (CLI.isLiveServer act) $
        liftIO $ threadDelay maxBound

 -- | Convenient version of @runEmaWith@ that takes initial model and an update
@ -119,11 +123,9 @@ runEmaWithCliInCwd cliAction model render = do
        withBlockBuffering $
          Generate.generate dest val (render cliAction)
      pure $ CLI.Generate dest :=> Identity fs
-    Some CLI.Run -> do
-      port <- liftIO $ fromMaybe 8000 . (readMaybe @Int =<<) <$> lookupEnv "PORT"
-      host <- liftIO $ fromMaybe "127.0.0.1" <$> lookupEnv "HOST"
+    Some (CLI.Run (host, port)) -> do
      Server.runServerWithWebSocketHotReload host port model (render cliAction)
-      pure $ CLI.Run :=> Identity ()
+      pure $ CLI.Run (host, port) :=> Identity ()
  where
    -- Temporarily use block buffering before calling an IO action that is
    -- known ahead to log rapidly, so as to not hamper serial processing speed.
--- a/src/Ema/CLI.hs
+++ b/src/Ema/CLI.hs
@ -1,5 +1,7 @@
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
@ -7,23 +9,29 @@
 module Ema.CLI where

 import Data.Constraint.Extras.TH (deriveArgDict)
+import Data.Default
 import Data.GADT.Compare.TH
  ( DeriveGCompare (deriveGCompare),
    DeriveGEQ (deriveGEq),
  )
 import Data.GADT.Show.TH (DeriveGShow (deriveGShow))
 import Data.Some
+import Ema.Server (Host, Port)
 import Options.Applicative hiding (action)

 data Action res where
  Generate :: FilePath -> Action [FilePath]
-  Run :: Action ()
+  Run :: (Host, Port) -> Action ()

 $(deriveGEq ''Action)
 $(deriveGShow ''Action)
 $(deriveGCompare ''Action)
 $(deriveArgDict ''Action)

+isLiveServer :: Some Action -> Bool
+isLiveServer (Some (Run _)) = True
+isLiveServer _ = False
+
 data Cli = Cli
  { action :: (Some Action)
  }
@ -34,9 +42,16 @@ cliParser = do
  action <-
    subparser
      (command "gen" (info generate (progDesc "Generate static HTML files")))
-      <|> pure (Some Run)
+      <|> subparser (command "run" (info run (progDesc "Run the live server")))
+      <|> pure (Some $ Run def)
  pure Cli {..}
  where
+    run :: Parser (Some Action)
+    run =
+      Some . Run
+        <$> ( (,) <$> strOption (long "host" <> short 'h' <> metavar "HOST" <> help "Host to bind to" <> value def)
+                <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> help "Port to bind to" <> value def)
+            )
    generate :: Parser (Some Action)
    generate =
      Some . Generate <$> argument str (metavar "DEST...")
--- a/src/Ema/Example/Ex02_Basic.hs
+++ b/src/Ema/Example/Ex02_Basic.hs
@ -37,7 +37,7 @@ main = do
  void $
    Ema.runEma (\act m -> Ema.AssetGenerated Ema.Html . render act m) $ \act model -> do
      LVar.set model $ Model "Hello World. "
-      when (act == Some CLI.Run) $
+      when (CLI.isLiveServer act) $
        liftIO $ threadDelay maxBound

 render :: Some Ema.CLI.Action -> Model -> Route -> LByteString
--- a/src/Ema/Server.hs
+++ b/src/Ema/Server.hs
@ -1,3 +1,5 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeApplications #-}

@ -6,6 +8,7 @@ module Ema.Server where
 import Control.Concurrent.Async (race)
 import Control.Exception (catch, try)
 import Control.Monad.Logger
+import Data.Default
 import Data.LVar (LVar)
 import qualified Data.LVar as LVar
 import qualified Data.Text as T
@ -24,6 +27,18 @@ import System.FilePath ((</>))
 import Text.Printf (printf)
 import UnliftIO (MonadUnliftIO)

+newtype Host = Host {unHost :: Text}
+  deriving newtype (Eq, Show, Ord, IsString)
+
+newtype Port = Port {unPort :: Int}
+  deriving newtype (Eq, Show, Ord, Num, Read)
+
+instance Default Host where
+  def = "127.0.0.1"
+
+instance Default Port where
+  def = 8000
+
 runServerWithWebSocketHotReload ::
  forall model route m.
  ( Ema model route,
@ -32,20 +47,20 @@ runServerWithWebSocketHotReload ::
    MonadUnliftIO m,
    MonadLoggerIO m
  ) =>
-  String ->
-  Int ->
+  Host ->
+  Port ->
  LVar model ->
  (model -> route -> Asset LByteString) ->
  m ()
 runServerWithWebSocketHotReload host port model render = do
  let settings =
        Warp.defaultSettings
-          & Warp.setPort port
-          & Warp.setHost (fromString host)
+          & Warp.setPort (unPort port)
+          & Warp.setHost (fromString . toString . unHost $ host)
  logger <- askLoggerIO

  logInfoN "============================================"
-  logInfoN $ "Running live server at http://" <> toText host <> ":" <> show port
+  logInfoN $ "Running live server at http://" <> unHost host <> ":" <> show port
  logInfoN "============================================"
  liftIO $
    Warp.runSettings settings $