From 64d2cd0591b8e19c870da13d39e7232a0a06dd1e Mon Sep 17 00:00:00 2001
From: Eduardo Trujillo <ed@chromabits.com>
Date: Fri, 25 Dec 2020 23:05:15 -0800
Subject: [PATCH] feat(Server): Add exterimental web server
---
shift.cabal | 2 +
src/Shift.hs | 2 +
src/Shift/CLI.hs | 92 ++++++++++++++++++++++++++-------------------
src/Shift/Server.hs | 16 ++++++++
4 files changed, 73 insertions(+), 39 deletions(-)
create mode 100644 src/Shift/Server.hs
diff --git a/shift.cabal b/shift.cabal
index 95eab87..990a597 100644
--- a/shift.cabal
+++ b/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
diff --git a/src/Shift.hs b/src/Shift.hs
index ef1cc1f..013fb94 100644
--- a/src/Shift.hs
+++ b/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)
diff --git a/src/Shift/CLI.hs b/src/Shift/CLI.hs
index 39cc42f..f4193c9 100644
--- a/src/Shift/CLI.hs
+++ b/src/Shift/CLI.hs
@@ -1,56 +1,70 @@
-{-# 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
diff --git a/src/Shift/Server.hs b/src/Shift/Server.hs
new file mode 100644
index 0000000..0e69ee4
--- /dev/null
+++ b/src/Shift/Server.hs
@@ -0,0 +1,16 @@
+{-# 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]
--
GitLab