Refactored server functions to use ServerMonad to allow access to custom configurations.

diff --git a/Vagrantfile b/Vagrantfile
index 4bf7389..b9834eb 100644 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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