From 9045f008d5de376373c152bee4238687743a289c Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Fri, 20 Jul 2018 20:04:13 -0400 Subject: [PATCH] Fetch markdown from backend --- README.md | 6 +-- backend/backend.cabal | 17 +++++++ backend/src/Backend.hs | 18 ++++++- .../src/Backend}/Markdown.hs | 17 +------ backend/src/main.hs | 18 ++----- common/src/Common/Route.hs | 10 ++-- frontend/frontend.cabal | 9 ++-- frontend/src/Frontend.hs | 49 ++++++++++++------- frontend/src/main.hs | 9 +++- 9 files changed, 85 insertions(+), 68 deletions(-) rename {frontend/src/Frontend => backend/src/Backend}/Markdown.hs (82%) diff --git a/README.md b/README.md index f29682b..bbf1904 100644 --- a/README.md +++ b/README.md @@ -8,8 +8,4 @@ revue uses Obelisk. Use `ob run` to run locally, and `nix-build -A exe` (or `ob ## Roadmap -- [X] Use markdown (only in frontend) -- [ ] Start using sub routes (eg: /wiki/whatever) -- [ ] Have backend do the markdown conversion - - [ ] Extract markdown rendering as separate reflex-dom library (just StaticWidget due to [yaml blocker](https://github.com/mmark-md/mmark/issues/54)) - - [ ] with Haskell syntax highlighting ([cf](https://github.com/mrkkrp/ghc-syntax-highlighter)) +https://github.com/srid/revue/projects/1?add_cards_query=is%3Aopen diff --git a/backend/backend.cabal b/backend/backend.cabal index 75743f3..7365c64 100644 --- a/backend/backend.cabal +++ b/backend/backend.cabal @@ -9,12 +9,21 @@ library buildable: False build-depends: base , common + , text + , foldl + , file-embed + , snap + , bytestring + , reflex-dom-core , frontend , obelisk-backend , dependent-sum , dependent-sum-template + , mmark + , modern-uri exposed-modules: Backend + Backend.Markdown ghc-options: -Wall executable backend @@ -25,6 +34,12 @@ executable backend build-depends: base , backend , common + , text + , foldl + , file-embed + , snap + , bytestring + , reflex-dom-core , frontend , dependent-sum , dependent-sum-template @@ -34,3 +49,5 @@ executable backend , obelisk-executable-config , obelisk-executable-config-inject , text + , mmark + , modern-uri diff --git a/backend/src/Backend.hs b/backend/src/Backend.hs index f6edc5e..9d5e22f 100644 --- a/backend/src/Backend.hs +++ b/backend/src/Backend.hs @@ -3,20 +3,36 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Backend where +import Control.Monad.IO.Class +import Data.ByteString (ByteString) import Data.Dependent.Sum (DSum (..)) +import Data.FileEmbed import Data.Functor.Identity +import qualified Data.Text.Encoding as T +import Snap + +import Reflex.Dom.Core import Obelisk.Backend as Ob import Common.Route +import Backend.Markdown (markdownView) + +landingMd :: ByteString +landingMd = $(embedFile "static/markdown/landing.md") + backend :: Backend BackendRoute Route backend = Backend { _backend_routeEncoder = backendRouteEncoder , _backend_run = \serve -> serve $ \case - BackendRoute_NoOp :=> Identity () -> pure () + BackendRoute_GetPage :=> Identity () -> do + ((), v) <- liftIO $ renderStatic $ do + markdownView $ T.decodeUtf8 landingMd + writeBS v } diff --git a/frontend/src/Frontend/Markdown.hs b/backend/src/Backend/Markdown.hs similarity index 82% rename from frontend/src/Frontend/Markdown.hs rename to backend/src/Backend/Markdown.hs index cb8a1c2..8b23c40 100644 --- a/frontend/src/Frontend/Markdown.hs +++ b/backend/src/Backend/Markdown.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Frontend.Markdown where +module Backend.Markdown where import Control.Foldl hiding (mconcat) import Control.Monad (forM_) @@ -16,7 +16,6 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) import qualified Data.Text as T -import Language.Javascript.JSaddle import Reflex.Dom.Core hiding (Link) import qualified Text.MMark as MMark @@ -65,17 +64,3 @@ markdownView source = case MMark.parse "" source of , (titleAttr =:) <$> title ] --- FIXME: can't use this with runRouteViewT (constraint violations) -fetchMarkdown :: - ( PostBuild t m - , TriggerEvent t m - , PerformEvent t m - , MonadJSM (Performable m) - , HasJSContext (Performable m) - ) - => Text -> m (Event t Text) -fetchMarkdown url = do - let req = xhrRequest "GET" url def - pb <- getPostBuild - asyncReq <- performRequestAsync (tag (constant req) pb) - pure $ fmap (fromMaybe " fetchMarkdown: Unknown error" . _xhrResponse_responseText) asyncReq diff --git a/backend/src/main.hs b/backend/src/main.hs index 23451d3..6a4f266 100644 --- a/backend/src/main.hs +++ b/backend/src/main.hs @@ -1,20 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Exception -import Control.Lens -import Data.Maybe -import Data.Text.Encoding -import Obelisk.ExecutableConfig (get) -import System.Environment -import qualified Text.URI as URI -import Text.URI.Lens import Backend +import Frontend +import Obelisk.Backend main :: IO () -main = do - Just route <- get "common/route" - port <- case URI.mkURI route of - Left err -> fail $ show err - Right uri -> return $ fromMaybe 8000 $ uri ^? uriAuthority . _Right . authPort . _Just - withArgs ["--port", show port] backend - +main = runBackend backend frontend diff --git a/common/src/Common/Route.hs b/common/src/Common/Route.hs index 6ad2e22..d6313f6 100644 --- a/common/src/Common/Route.hs +++ b/common/src/Common/Route.hs @@ -34,25 +34,25 @@ backendRouteEncoder = Encoder $ do myObeliskRestValidEncoder <- checkObeliskRouteRestEncoder routeRestEncoder checkEncoder $ pathComponentEncoder myComponentEncoder $ \case InL backendRoute -> case backendRoute of - BackendRoute_NoOp -> endValidEncoder mempty + BackendRoute_GetPage -> endValidEncoder mempty InR obeliskRoute -> runValidEncoderFunc myObeliskRestValidEncoder obeliskRoute --TODO: Should we rename `Route` to `AppRoute`? data BackendRoute :: * -> * where --TODO: How do we do routes with strongly-typed results? - BackendRoute_NoOp :: BackendRoute () + BackendRoute_GetPage :: BackendRoute () backendRouteComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some BackendRoute) (Maybe Text) backendRouteComponentEncoder = enum1Encoder $ \case - BackendRoute_NoOp -> Just "noop" + BackendRoute_GetPage -> Just "get-page" backendRouteRestEncoder :: (Applicative check, MonadError Text parse) => BackendRoute a -> Encoder check parse a PageName backendRouteRestEncoder = Encoder . pure . \case - BackendRoute_NoOp-> endValidEncoder mempty + BackendRoute_GetPage-> endValidEncoder mempty instance Universe (Some BackendRoute) where universe = - [ Some.This BackendRoute_NoOp + [ Some.This BackendRoute_GetPage ] data Route :: * -> * where diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal index 3c23b9e..4c6c9f1 100644 --- a/frontend/frontend.cabal +++ b/frontend/frontend.cabal @@ -8,18 +8,17 @@ library build-depends: base , common , reflex-dom - , foldl , static , text , string-conv , obelisk-route + , obelisk-frontend , clay - , mmark , modern-uri + , jsaddle exposed-modules: Frontend Frontend.Css - Frontend.Markdown ghc-options: -Wall executable frontend @@ -29,14 +28,14 @@ executable frontend , common , reflex-dom , static - , foldl , text , frontend , string-conv , obelisk-route + , obelisk-frontend , clay - , mmark , modern-uri + , jsaddle --TODO: Make these ghc-options optional ghc-options: -threaded if os(darwin) diff --git a/frontend/src/Frontend.hs b/frontend/src/Frontend.hs index 42acbf0..d32b184 100644 --- a/frontend/src/Frontend.hs +++ b/frontend/src/Frontend.hs @@ -12,26 +12,23 @@ module Frontend where import Prelude hiding (id, (.)) import Control.Category -import Data.ByteString (ByteString) -import Data.FileEmbed +import Control.Monad (void) +import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) import Data.Text (Text) -import qualified Data.Text.Encoding as T +import qualified Data.Text as T + +import Language.Javascript.JSaddle +import Reflex.Dom.Core --- import Language.Javascript.JSaddle import Obelisk.Frontend import Obelisk.Route.Frontend -import Reflex.Dom.Core import Static import Common.Route import Frontend.Css (appCssStr) -import Frontend.Markdown - --- TODO: As soon as obelisk backend routing is ready, move content as markdown --- to the backend (or have backend fetch it from elsewhere). title :: Text title = "Sridhar Ratnakumar" @@ -43,11 +40,18 @@ frontend = Frontend el "title" $ text title elAttr "link" ("rel" =: "stylesheet" <> "type" =: "text/css" <> "href" =: static @"semantic.min.css") blank el "style" $ text appCssStr - , _frontend_body = pageTemplate $ subRoute_ $ - divClass "markdown" . markdownView . getRouteMarkdown + , _frontend_body = pageTemplate $ subRoute_ $ \_r -> do + c <- prerender (pure never) $ + fetchContent $ backendRoute BackendRoute_GetPage + t :: Dynamic t Text <- holdDyn "Loading..." c + divClass "markdown" $ do + prerender blank $ void $ elDynHtml' "div" t , _frontend_title = \_ -> title , _frontend_notFoundRoute = \_ -> Route_Landing :/ () } + where + Right backendRouteValidEncoder = checkEncoder $ obeliskRouteEncoder backendRouteComponentEncoder backendRouteRestEncoder + backendRoute r = T.intercalate "/" $ fst $ _validEncoder_encode backendRouteValidEncoder $ ObeliskRoute_App r :/ () pageTemplate :: DomBuilder t m=> m a -> m a pageTemplate page = divClass "ui container" $ do @@ -55,14 +59,6 @@ pageTemplate page = divClass "ui container" $ do divClass "ui attached segment" $ elAttr "div" ("id" =: "content") $ page -getRouteMarkdown :: Route a -> Text -getRouteMarkdown = \case - Route_Landing -> T.decodeUtf8 landingMd - --- TODO: Don't embed, but pull from backend. -landingMd :: ByteString -landingMd = $(embedFile "static/markdown/landing.md") - -- TODO: Move to Widget.hs aLink :: DomBuilder t m => m () -> m (Event t ()) @@ -73,3 +69,18 @@ click' => m (target, a) -> m (Event t (DomEventType target 'ClickTag)) click' = fmap (domEvent Click . fst) + +-- TODO: change this to toplevel dynamic +fetchContent :: + ( PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , MonadJSM (Performable m) + , HasJSContext (Performable m) + ) + => Text -> m (Event t Text) +fetchContent url = do + let req = xhrRequest "GET" url def + pb <- getPostBuild + asyncReq <- performRequestAsync (tag (constant req) pb) + pure $ fmap (fromMaybe " fetchMarkdown: Unknown error" . _xhrResponse_responseText) asyncReq diff --git a/frontend/src/main.hs b/frontend/src/main.hs index 094a63a..3421d29 100644 --- a/frontend/src/main.hs +++ b/frontend/src/main.hs @@ -1,5 +1,10 @@ -import Reflex.Dom +import Common.Route import Frontend +import Obelisk.Frontend +import Obelisk.Route.Frontend +import Reflex.Dom main :: IO () -main = mainWidget $ snd frontend +main = do + let Right validFullEncoder = checkEncoder backendRouteEncoder + run $ runFrontend validFullEncoder frontend