feat(Server): Add exterimental web server

shift.cabal

@@ -21,6 +21,7 @@ library
                      , Shift.Parsers
                      , Shift.Processing
                      , Shift.Rendering
+                     , Shift.Server
                      , Shift.Types
                      , Shift.Utilities
                      , GitHub.UserSearch
@@ -48,6 +49,7 @@ library
                      , exceptions
                      , semigroups
                      , cmark-gfm
+                     , scotty
   default-language:    Haskell2010
 
 executable shift

src/Shift.hs

@@ -11,6 +11,7 @@ import Shift.CLI       as X
 import Shift.Git       as X
 import Shift.Rendering as X
 import Shift.Types     as X
+import Shift.Server (runServer)
 
 -- | The main CLI entrypoint.
 shiftMain :: IO ()
@@ -19,6 +20,7 @@ shiftMain = do
 
   case currentOptions ^. soCommand of
     GenerateCommand -> tempMain currentOptions
+    ServeCommand  -> runServer currentOptions
 
   where
     opts = info (helper <*> shiftOptions)

src/Shift/CLI.hs

-{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Shift.CLI where
 
-import Options.Applicative
-
 import Control.Lens (makeLenses)
+import Options.Applicative
 
 data ShiftOptions = ShiftOptions
-  { _soCommand          :: ShiftCommand
-  , _soHostingType      :: HostingType
-  , _soGitHubOwner      :: Maybe String
-  , _soGitHubRepository :: Maybe String
-  , _soGitHubToken      :: Maybe String
-  } deriving (Show, Eq)
+  { _soCommand :: ShiftCommand,
+    _soHostingType :: HostingType,
+    _soGitHubOwner :: Maybe String,
+    _soGitHubRepository :: Maybe String,
+    _soGitHubToken :: Maybe String
+  }
+  deriving (Show, Eq)
 
-data ShiftCommand = GenerateCommand deriving (Show, Eq, Enum)
+data ShiftCommand = GenerateCommand | ServeCommand deriving (Show, Eq, Enum)
 
 data HostingType = GitHubType | GitType deriving (Show, Eq, Enum)
 
 shiftOptions :: Parser ShiftOptions
-shiftOptions = ShiftOptions
-  <$> shiftCommand
-  <*> option hostingType
-    ( long "hosting-type"
-    <> short 't'
-    <> metavar "TYPE"
-    <> help "Which kind of service the repository is hosted on"
-    )
-  <*> optional (strOption
-    ( long "github-owner"
-    <> metavar "USERNAME"
-    <> help "Username who owns the repository"
-    ))
-  <*> optional (strOption
-    ( long "github-repository"
-    <> metavar "REPOSITORY"
-    <> help "Name of the repository"
-    ))
-  <*> optional (strOption
-    ( long "github-token"
-    <> metavar "TOKEN"
-    <> help "GitHub access token"
-    ))
+shiftOptions =
+  ShiftOptions
+    <$> shiftCommand
+    <*> option
+      hostingType
+      ( long "hosting-type"
+          <> short 't'
+          <> metavar "TYPE"
+          <> help "Which kind of service the repository is hosted on"
+      )
+    <*> optional
+      ( strOption
+          ( long "github-owner"
+              <> metavar "USERNAME"
+              <> help "Username who owns the repository"
+          )
+      )
+    <*> optional
+      ( strOption
+          ( long "github-repository"
+              <> metavar "REPOSITORY"
+              <> help "Name of the repository"
+          )
+      )
+    <*> optional
+      ( strOption
+          ( long "github-token"
+              <> metavar "TOKEN"
+              <> help "GitHub access token"
+          )
+      )
 
 shiftCommand :: Parser ShiftCommand
-shiftCommand = subparser $
-  command "generate"
-    (info (pure GenerateCommand)
-      (progDesc "Generate changelog")
-    )
+shiftCommand =
+  subparser $
+    command
+      "generate"
+      ( info
+          (pure GenerateCommand)
+          (progDesc "Generate changelog")
+      )
+      <> command
+        "serve"
+        (info (pure ServeCommand) (progDesc "Start UI server"))
 
 hostingType :: ReadM HostingType
 hostingType = eitherReader $ \case

src/Shift/Server.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Shift.Server (runServer) where
+
+import Web.Scotty (scotty, get, param, html)
+import Shift.CLI (ShiftOptions)
+import Shift.Git (renderToNode)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import CMarkGFM (nodeToHtml, nodeToHtml, commonmarkToHtml)
+import Data.Text.Lazy (fromChunks)
+
+runServer :: ShiftOptions -> IO ()
+runServer options = scotty 3000 $
+    get "/" $ do
+        node <- liftIO $ renderToNode options
+        html $ fromChunks [nodeToHtml [] [] node]