From: sabadev <saba@sabadev.xyz>
Date: Sun, 11 Apr 2021 23:19:17 +0000 (-0400)
Subject: Added image support.
X-Git-Url: http://sabadev.xyz:4321/?a=commitdiff_plain;h=d179e20cea7f8fd8a8925a34f57f903f2716ed1d;p=website.git

Added image support.
---

diff --git a/src/ApiTypes.hs b/src/ApiTypes.hs
index 0204167..7e54905 100644
--- a/src/ApiTypes.hs
+++ b/src/ApiTypes.hs
@@ -2,7 +2,9 @@ module ApiTypes where
 
 import Control.Monad ((<=<))
 import CssContentType
+import Data.ByteString.Lazy (ByteString(..))
 import GHC.Generics (Generic(..))
+import ImageContentType
 import Lucid
 import Servant
 import Servant.HTML.Lucid (HTML(..))
@@ -11,14 +13,16 @@ import qualified Clay as C
 import qualified Data.Text as T
 
 type Api = Styling :<|> Page
-type Page = ChangeTheme :<|> MainPage :<|> BlogPost
+type Page = ChangeTheme :<|> ImageLink :<|> MainPage :<|> BlogPost
 type MainPage = ThemeParam :> Get '[HTML] (Html ())
 type BlogPost = ThemeParam :> Capture "id" BlogId :> Get '[HTML] (Html ())
+type ImageLink = "image" :> Capture "id" ImageId :> Get '[PNG] ByteString
 type Styling = "style" :> ThemeParam :> Get '[CSS] C.Css
 type ChangeTheme = ReqBody '[FormUrlEncoded] Theme :> Capture "id" BlogId :> Post '[HTML] (Html ())
 type ThemeParam = QueryParam "theme" Theme
 
 type BlogId = FilePath
+type ImageId = FilePath
 
 data LightDark = Light | Dark deriving (Eq)
 
diff --git a/src/Html.hs b/src/Html.hs
index 2e0d759..e0f8a24 100644
--- a/src/Html.hs
+++ b/src/Html.hs
@@ -4,6 +4,7 @@ import ApiTypes
 import Control.Exception.Safe (SomeException)
 import Control.Monad (void)
 import Control.Monad.IO.Class (MonadIO(..), liftIO)
+import Data.ByteString.Lazy (ByteString(..))
 import Data.List (sort)
 import Data.Maybe (fromMaybe)
 import Lucid
@@ -73,6 +74,9 @@ blogListItem theme (blogLink -> (Just file)) = li_ [class_ "blog-link"] $ a_ [hr
 blogLink :: T.Text -> Maybe T.Text
 blogLink = T.stripSuffix markdownExtension
 
+imageNotFound :: (MonadIO m) => SomeException -> m ByteString
+imageNotFound _ = pure mempty
+
 blogNotFound :: (MonadIO m) => Maybe Theme -> BlogId -> SomeException -> m (Html ())
 blogNotFound theme blogId _ = htmlContainer theme Nothing $ do
   div_ [class_ "not-found"] $ do
@@ -85,5 +89,8 @@ siteTitle = "My Site"
 staticPath :: FilePath
 staticPath = "static/"
 
+imagePath :: FilePath
+imagePath = staticPath <> "img/"
+
 markdownExtension :: T.Text
 markdownExtension = ".md"
diff --git a/src/ImageContentType.hs b/src/ImageContentType.hs
new file mode 100644
index 0000000..e457160
--- /dev/null
+++ b/src/ImageContentType.hs
@@ -0,0 +1,13 @@
+module ImageContentType where
+
+import Data.ByteString.Lazy (ByteString(..))
+import Network.HTTP.Media ((//), (/:))
+import Servant
+
+data PNG
+
+instance Accept PNG where
+  contentType _ = "image" // "png"
+
+instance MimeRender PNG ByteString where
+  mimeRender _ val = val
diff --git a/src/Server.hs b/src/Server.hs
index b1c7900..1c1b57c 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -2,7 +2,6 @@ module Server where
 
 import ApiTypes
 import Control.Exception.Safe (handleAny)
-import Control.Monad ((<=<))
 import Control.Monad.IO.Class (liftIO)
 import Data.Maybe (fromMaybe)
 import Html
@@ -11,6 +10,7 @@ import RenderBlog (renderBlog)
 import Servant
 import StyleSheet
 import qualified Clay as C
+import qualified Data.ByteString.Lazy as B
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 
@@ -21,7 +21,7 @@ api :: Server Api
 api = styling :<|> page
 
 page :: Server Page
-page = changeTheme :<|> mainPage :<|> blogPost
+page = changeTheme :<|> imageLink :<|> mainPage :<|> blogPost
 
 mainPage :: Maybe Theme -> Handler (Html ())
 mainPage = flip blogPost defaultBlogId
@@ -35,6 +35,9 @@ findBlogPost = liftIO . T.readFile . (<>) staticPath . flip (<>) (T.unpack markd
 changeTheme :: Theme -> BlogId -> Handler (Html ())
 changeTheme theme = blogPost (Just theme)
 
+imageLink :: ImageId -> Handler B.ByteString
+imageLink imageId = handleAny imageNotFound $ liftIO $ B.readFile $ imagePath <> imageId
+
 styling :: Maybe Theme -> Handler C.Css
 styling (fromMaybe defaultTheme -> theme) = pure $ getStyleFromTheme (themeType theme) $ C.rgba (themeRed theme) (themeGreen theme) (themeBlue theme) 1
 
diff --git a/src/StyleSheet.hs b/src/StyleSheet.hs
index f576252..ecbea91 100644
--- a/src/StyleSheet.hs
+++ b/src/StyleSheet.hs
@@ -16,6 +16,7 @@ makeStyle :: ColorAction -> Color -> Css
 makeStyle colorAction themeColor = do
   html ? maxWidth (pct 100)
   bodyStyle colorAction themeColor
+  imageStyle
   paragraphStyle
   codeStyle
   headerStyle
@@ -34,6 +35,13 @@ bodyStyle action themeColor = body ? do
   padding (rem 0.25) (rem 0.25) (rem 0.25) (rem 0.25)
   fontSize $ px 16
 
+imageStyle :: Css
+imageStyle = img ? do
+  display block
+  marginLeft auto
+  marginRight auto
+  width $ pct 100
+
 paragraphStyle :: Css
 paragraphStyle = p ? do
   fontSize $ rem 1