Fetch markdown from backend

srid · Jul 21, 2018 · 9045f00 · 9045f00
1 parent 7207778
commit 9045f00
Show file tree

Hide file tree

Showing 9 changed files with 85 additions and 68 deletions.
diff --git 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
@@ -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
@@ -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 → backend/src/Backend/Markdown.hs b/frontend/src/Frontend/Markdown.hs → 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 "<nofile>" 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
@@ -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
@@ -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
@@ -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
@@ -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,26 +40,25 @@ 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
   divClass "ui top attached inverted header" $ el "h1" $ text title
   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
@@ -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