css

aggreact.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: a75b559a48622ecf2f5c1828cceaaca1e22b3e02dd220be74a7c3ec81fb1b60b
+-- hash: d11aa404572bc87a8da8ab8884a2b01443beea6ede73072538bcbe8a4f42ca1b
 
 name:           aggreact
 version:        0.1.0.0
@@ -29,6 +29,8 @@ library
   exposed-modules:
       Aggreact
       Aggreact.Comments
+      Aggreact.Css
+      Servant.Clay
   other-modules:
       Paths_aggreact
   hs-source-dirs:
@@ -43,8 +45,10 @@ library
     , cereal
     , cereal-text
     , cereal-time
+    , clay
     , containers
     , http-api-data
+    , http-media
     , human-readable-duration
     , ixset
     , protolude
@@ -66,7 +70,7 @@ executable aggreact
   hs-source-dirs:
       src-exe
   default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables
-  ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts="-N -I0"
+  ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -I0
   build-depends:
       aggreact
     , base >=4.8 && <5

package.yaml

@@ -33,8 +33,10 @@ library:
   - cereal
   - cereal-text
   - cereal-time
+  - clay
   - containers
   - http-api-data
+  - http-media
   - human-readable-duration
   - ixset
   - safecopy
@@ -54,7 +56,7 @@ executables:
     - -optP-Wno-nonportable-include-path
     - -threaded
     - -rtsopts
-    - -with-rtsopts="-N -I0"
+    - "-with-rtsopts=-N -I0"
     dependencies:
     - aggreact
 tests:

src/Aggreact.hs

@@ -26,16 +26,20 @@ module Aggreact
 import           Protolude
 
 import           Aggreact.Comments
+import           Aggreact.Css             (genCss)
 
+import           Clay                     (Css)
 import           Data.Time                (getCurrentTime)
 import           Network.Wai              (Application)
 import qualified Network.Wai.Handler.Warp as Warp
 import           Servant
+import           Servant.Clay
 import           Servant.HTML.Blaze
 
 type CommentAPI =
   "comments" :> Capture "slug" Text :> Get '[HTML,JSON] CommentPage
   :<|> "slugs" :> Get '[JSON] [Slug]
+  :<|> "main.css" :> Get '[CSS] Css
   :<|> "comments" :> ReqBody '[JSON, FormUrlEncoded] NewComment :> Post '[JSON] Comment
 
 data Conf = Conf { port :: Int }
@@ -55,6 +59,7 @@ api = Proxy
 server :: DB Comments -> Server CommentAPI
 server db = showComments db
             :<|> listSlugs db
+            :<|> return genCss
             :<|> liftIO . createNewComment db
 
 app :: DB Comments -> Application

src/Aggreact/Comments.hs

@@ -256,8 +256,9 @@ getCommentsByParentId db s = Acid.query db (CommentsByParentId s)
 boilerplate :: Text -> H.Markup -> H.Html
 boilerplate url innerHtml =
   H.html $ do
-    H.head $
+    H.head $ do
       H.title (H.text "Aggreact")
+      H.link H.! A.rel "stylesheet" H.! A.type_ "text/css" H.! A.href "/main.css"
     H.body $ do
       H.h1 $ do
         H.text "Aggreact: "

src/Aggreact/Css.hs

@@ -0,0 +1,12 @@
+module Aggreact.Css where
+
+import Clay
+
+genCss :: Css
+genCss =
+  body ? do
+    fontFamily ["Menlo"] [monospace]
+    fontSize (px 14)
+    maxWidth (px 800)
+    lineHeight (em 1.5)
+    margin (px 0) auto (px 0) auto

src/Servant/Clay.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+
+module Servant.Clay where
+
+import Protolude hiding (encodeUtf8)
+
+import           Clay                    (Css, compact, renderWith)
+import           Data.Text.Lazy.Encoding (encodeUtf8)
+import           Data.Typeable           (Typeable)
+import qualified Network.HTTP.Media      as M
+import           Servant.API             (Accept (..), MimeRender (..))
+
+data CSS deriving Typeable
+
+instance Accept CSS where
+  contentType _ = "test" M.// "css" M./: ("charset","utf-8")
+
+instance MimeRender CSS Css where
+  mimeRender _ = encodeUtf8 . renderWith compact []