From: sabadev Date: Sat, 22 May 2021 03:38:51 +0000 (-0400) Subject: Refactored server functions to use ServerMonad to allow access to custom configurations. X-Git-Url: http://sabadev.xyz:4321/?a=commitdiff_plain;h=daa190a0bbf922faaba09b76aa1d05da97adfcee;p=website.git Refactored server functions to use ServerMonad to allow access to custom configurations. --- diff --git a/Vagrantfile b/Vagrantfile index 4bf7389..b9834eb 100644 --- a/Vagrantfile +++ b/Vagrantfile @@ -20,6 +20,12 @@ cd /vagrant sudo stack --allow-different-user exec website SCRIPT +$runconf = <<-SCRIPT +sudo killall website +cd /vagrant +sudo stack --allow-different-user exec website config.json +SCRIPT + Vagrant.configure("2") do |config| config.vm.box = "debian/buster64" @@ -38,4 +44,5 @@ Vagrant.configure("2") do |config| config.vm.provision "build", type: "shell", run: "never", inline: $build config.vm.provision "test", type: "shell", run: "never", inline: $test config.vm.provision "run", type: "shell", run: "never", inline: $run + config.vm.provision "runconf", type: "shell", run: "never", inline: $runconf end diff --git a/app/Main.hs b/app/Main.hs index 6f37f7e..b9ee968 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,12 +9,18 @@ import Network.Wai.Handler.Warp (run) import Server import ServerMonad (ConfigMonad(..), ServerMonad(..)) import System.Environment (getArgs) -import Text.Read (readMaybe) +import System.IO (hPutStrLn, stderr) main :: IO () -main = runConfigMonad getConfiguration >>= flip run app . configPort +main = do + config <- runConfigMonad getConfiguration + printError $ show config + flip run (app config) $ configPort config getConfiguration :: ConfigMonad ServerConfiguration getConfiguration = do - configFilePath <- liftIO getArgs >>= pure . (readMaybe <=< listToMaybe) + configFilePath <- liftIO getArgs >>= pure . listToMaybe maybe (pure $ Right defaultConfiguration) readConfiguration configFilePath >>= pure . either error id + +printError :: String -> IO () +printError = hPutStrLn stderr diff --git a/config.json b/config.json new file mode 100644 index 0000000..38ef27d --- /dev/null +++ b/config.json @@ -0,0 +1,4 @@ +{ + "configPort": 5000, + "configShowExceptions": true +} diff --git a/src/Configuration.hs b/src/Configuration.hs index d1b8958..e2a1053 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -11,7 +11,7 @@ class (Monad m) => MonadReadConfig m where data ServerConfiguration = ServerConfiguration { configPort :: !Port , configShowExceptions :: !Bool - } deriving (Generic) + } deriving (Show, Generic) instance FromJSON ServerConfiguration diff --git a/src/Html.hs b/src/Html.hs index 30a809e..50e2e2b 100644 --- a/src/Html.hs +++ b/src/Html.hs @@ -1,10 +1,12 @@ module Html where import ApiTypes +import Configuration (ServerConfiguration(..)) import Control.Exception.Safe (SomeException) import Control.Monad (void) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..), liftIO) +import Control.Monad.Reader (MonadReader(..)) import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString(..)) import Data.List (sortOn) @@ -89,8 +91,9 @@ blogLink = T.stripSuffix markdownExtension imageNotFound :: (MonadError ServerError m) => SomeException -> m a imageNotFound _ = throwError $ err404 { errBody = "No image found." } -blogNotFound :: (MonadIO m, MonadError ServerError m) => Maybe Theme -> BlogId -> SomeException -> m a -blogNotFound theme blogId _ = do +blogNotFound :: (MonadIO m, MonadError ServerError m, MonadReader ServerConfiguration m) => Maybe Theme -> BlogId -> SomeException -> m a +blogNotFound theme blogId exceptionReason = do + showExceptions <- ask >>= pure . configShowExceptions body <- htmlContainer theme Nothing $ do div_ [class_ "not-found"] $ do h1_ $ toHtml @T.Text "Blog not found" @@ -98,6 +101,7 @@ blogNotFound theme blogId _ = do toHtml @T.Text "Blog post " em_ $ toHtml $ T.pack blogId toHtml @T.Text " could not found." + if showExceptions then p_ $ toHtml $ T.pack $ show exceptionReason else pure () throwError $ err404 { errBody = renderBS body } siteTitle :: T.Text diff --git a/src/Server.hs b/src/Server.hs index 271f3a1..3c4e4e8 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,13 +1,16 @@ module Server where import ApiTypes +import Configuration (ServerConfiguration(..)) import Control.Exception.Safe (handleAny) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (runReaderT) import Data.Maybe (fromMaybe) import Html import Lucid import RenderBlog (renderBlog) import Servant +import ServerMonad (ServerMonad(..)) import StyleSheet import System.FilePath.Posix (()) import qualified Clay as C @@ -15,31 +18,34 @@ import qualified Data.ByteString.Lazy as B import qualified Data.Text as T import qualified Data.Text.IO.Utf8 as T -app :: Application -app = serve apiProxy api +app :: ServerConfiguration -> Application +app config = serve apiProxy $ hoistServer apiProxy (serverMonadToHandler config) api -api :: Server Api +serverMonadToHandler :: ServerConfiguration -> ServerMonad a -> Handler a +serverMonadToHandler config = Handler . flip runReaderT config . runServerMonad + +api :: ServerT Api ServerMonad api = styling :<|> page -page :: Server Page +page :: ServerT Page ServerMonad page = changeTheme :<|> imageLink :<|> mainPage :<|> blogPost -mainPage :: Maybe Theme -> Handler (Html ()) +mainPage :: Maybe Theme -> ServerMonad (Html ()) mainPage = flip blogPost defaultBlogId -blogPost :: Maybe Theme -> BlogId -> Handler (Html ()) +blogPost :: Maybe Theme -> BlogId -> ServerMonad (Html ()) blogPost theme blogId = handleAny (blogNotFound theme blogId) $ findBlogPost blogId >>= htmlContainer theme (Just blogId) . renderBlog -findBlogPost :: BlogId -> Handler T.Text +findBlogPost :: BlogId -> ServerMonad T.Text findBlogPost = liftIO . T.readFile . () staticPath . flip (<>) (T.unpack markdownExtension) -changeTheme :: Theme -> BlogId -> Handler (Html ()) +changeTheme :: Theme -> BlogId -> ServerMonad (Html ()) changeTheme theme = blogPost (Just theme) -imageLink :: ImageId -> Handler B.ByteString +imageLink :: ImageId -> ServerMonad B.ByteString imageLink imageId = handleAny imageNotFound $ liftIO $ B.readFile $ imagePath imageId -styling :: Maybe Theme -> Handler C.Css +styling :: Maybe Theme -> ServerMonad C.Css styling (fromMaybe defaultTheme -> theme) = pure $ getStyleFromTheme (themeType theme) $ C.rgba (themeRed theme) (themeGreen theme) (themeBlue theme) 1 getStyleFromTheme :: LightDark -> C.Color -> C.Css diff --git a/src/ServerMonad.hs b/src/ServerMonad.hs index fd1d1c4..8760b2d 100644 --- a/src/ServerMonad.hs +++ b/src/ServerMonad.hs @@ -1,15 +1,19 @@ module ServerMonad where import Configuration (ServerConfiguration(..), MonadReadConfig(..)) +import Control.Exception.Safe (MonadCatch(..), MonadThrow(..)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Except (ExceptT(..)) import Control.Monad.IO.Class (MonadIO(..), liftIO) import Control.Monad.Reader (MonadReader(..), ReaderT(..)) +import Servant (ServerError) import qualified Data.ByteString as B newtype ConfigMonad a = ConfigMonad { runConfigMonad :: IO a } deriving (Functor, Applicative, Monad, MonadIO) -newtype ServerMonad a = ServerMonad { runServerMonad :: ReaderT ServerConfiguration IO a - } deriving (Functor, Applicative, Monad, MonadIO, MonadReader ServerConfiguration) +newtype ServerMonad a = ServerMonad { runServerMonad :: ReaderT ServerConfiguration (ExceptT ServerError IO) a + } deriving (Functor, Applicative, Monad, MonadIO, MonadReader ServerConfiguration, MonadError ServerError, MonadThrow, MonadCatch) instance MonadReadConfig ConfigMonad where readConfigFile = liftIO . B.readFile