Commit 199a1ad8 authored by Christopher League's avatar Christopher League
Browse files

Pandoc page titles and style

parent 625d0ee1
......@@ -31,6 +31,8 @@ module App.Foundation
runMailer,
requireAuth,
maybeAuth,
isAuthenticated,
whenAuthenticated,
module Yesod,
module Yesod.Auth,
setpassR,
......@@ -85,15 +87,16 @@ mkYesodData
"App"
[parseRoutes|
/ HomeR GET
/favicon.ico FaviconR GET
/me ProfileR GET POST
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
/post/#PostId PostR GET
/submit/#Text SubmitR GET POST
/cache/meta MetaCacheR GET DELETE
/auth AuthR Auth getAuth
/ HomeR GET
/pandoc.css PandocStyleR GET
/favicon.ico FaviconR GET
/me ProfileR GET POST
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
/post/#PostId PostR GET
/submit/#Text SubmitR GET POST
/cache/meta MetaCacheR GET DELETE
/auth AuthR Auth getAuth
|]
......@@ -413,11 +416,11 @@ about a day.
|]
setPasswordHandler needOld = do
(widget, enctype) <- generateFormPost setPassForm
toParent <- getRouteToParent
selectRep $ provideRep $ authLayout $ do
setTitle "Set Password"
[whamlet|
(widget, enctype) <- generateFormPost setPassForm
toParent <- getRouteToParent
selectRep $ provideRep $ authLayout $ do
setTitle "Set Password"
[whamlet|
<form #authPanel .text-center method=post action=@{toParent setpassR} enctype=#{enctype}>
^{widget}
<button .mt-3 .mb-3 .btn .btn-lg .btn-primary .btn-block type=submit>Set Password
......@@ -426,9 +429,9 @@ about a day.
setPassForm =
renderDivsNoLabels $
(,,)
<$> (if needOld then authPassField "Current Password" "current" else pure "")
<*> authPassField "New Password" "new"
<*> authPassField "Confirm Password" "confirm"
<$> (if needOld then authPassField "Current Password" "current" else pure "")
<*> authPassField "New Password" "new"
<*> authPassField "Confirm Password" "confirm"
authField :: String -> Text -> FieldSettings App
authField label name =
......@@ -471,6 +474,15 @@ requireAuth :: AppHandler m => m UserEntity
requireAuth =
requireAuthId >>= cachedAuth
isAuthenticated :: AppHandler m => m Bool
isAuthenticated =
maybeAuthId <&> isJust
whenAuthenticated :: AppHandler m => m () -> m ()
whenAuthenticated act = do
ok <- isAuthenticated
when ok act
adminMasquerade :: AuthPlugin App
adminMasquerade =
AuthPlugin "admin" dispatch chooser
......
......@@ -32,7 +32,8 @@ import qualified Data.Yaml as Yaml
import Network.Mime
import System.Environment
import System.Exit
import Text.Pandoc (runPure, writeHtml5String)
import Text.Pandoc (Pandoc (..), runPure, writeHtml5String)
import qualified Text.Pandoc.Highlighting as PH
import UnliftIO.IORef (newIORef, readIORef, writeIORef)
import Yesod.Core.Types (FileInfo (..))
......@@ -97,7 +98,7 @@ postSubmitR sid = do
<p>Will upload to #{st}
|]
getPostR :: PostId -> Handler TypedContent
getPostR :: PostId -> Handler Html
getPostR pid = do
uid <- requireAuthId
runRw $ do
......@@ -105,7 +106,7 @@ getPostR pid = do
updatePureY_ uid (markPostAsRead pid)
getPandocPage pid
getPageDocR :: PageId -> Handler TypedContent
getPageDocR :: PageId -> Handler Html
getPageDocR = getPandocPage
getPageAssetR :: AssetId -> Handler TypedContent
......@@ -119,14 +120,24 @@ getPageAssetR name = do
"image/vnd.microsoft.icon" -> "image/x-icon"
t -> t
getPandocPage :: IsPageKey k => k -> Handler TypedContent
getPandocPage :: IsPageKey k => k -> Handler Html
getPandocPage k =
runRo (fetchPageMaybe k) >>= \case
Nothing -> notFound
Just doc -> do
html <- eitherThrow . runPure $ writeHtml5String def doc
-- TODO: set title, heading
toTypedContent <$> defaultLayout (toWidget (preEscapedToMarkup html))
Just doc@(Pandoc meta _) -> do
title <- formatTitle meta
body <- eitherThrow . runPure $ writeHtml5String def doc
defaultLayout $ do
addStylesheet PandocStyleR
setTitle title
[whamlet|
<div .col-12>
#{preEscapedToMarkup body}
|]
getPandocStyleR :: Handler TypedContent
getPandocStyleR =
return $ TypedContent "text/css" $ toContent $ PH.styleToCss PH.pygments
mkYesodDispatch "App" resourcesApp
......
......@@ -33,7 +33,6 @@ import Data.Time.Calendar (Day)
import Data.Time.Format
import Data.Tuple.Extra
import GHC.Generics hiding (Meta)
import Text.Pandoc
data OutlineId = TheOutline
deriving (Eq, Ord, Show, Read)
......@@ -112,11 +111,6 @@ formatDay =
-- The home page should still have *some* information even when not logged in:
-- link to PDF syllabus,
formatTitle :: MonadThrow m => Meta -> m Html
formatTitle meta =
eitherThrow . runPure $ writeHtml5 def $
Pandoc nullMeta [Plain (docTitle meta)]
essentialLinks :: Widget
essentialLinks = do
let syllabusId = AssetId "cs101s20.pdf"
......@@ -147,13 +141,13 @@ essentialLinks = do
recentPosts :: Widget
recentPosts =
maybeAuth >>= mapM_ \(_, user) -> do
postIds <- runRo listPostIds
unless (null postIds) $ do
posts <- forM postIds \pid -> do
title <- getPageMeta pid >>= formatTitle
return (pid, title, not (Set.member pid (user ^. userReadPosts)))
let newCount = length $ filter thd3 posts
[whamlet|
postIds <- runRo listPostIds
unless (null postIds) $ do
posts <- forM postIds \pid -> do
title <- getPageMeta pid >>= formatTitle
return (pid, title, not (Set.member pid (user ^. userReadPosts)))
let newCount = length $ filter thd3 posts
[whamlet|
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
......@@ -174,6 +168,7 @@ recentPosts =
#{preEscapedToMarkup title}
|]
unit1 :: Widget
unit1 =
[whamlet|
<div .col-lg-6>
......@@ -183,20 +178,14 @@ unit1 =
Unit 1:
Digital representations
<div .card-body>
Body goes here
Content coming soon
|]
getHomeR :: Handler Html
getHomeR = do
uidOpt <- maybeAuthId
(out, units) <- runRo $ do
out <- loadY TheOutline
let nums = [1 ..] :: [Int]
units = zip nums $ out ^. outUnits
return (out, units)
getHomeR =
defaultLayout $ do
setTitle $ toHtml $ out ^. outTitle
setTitle "Fundamentals of Computer and Information Sciences"
recentPosts
essentialLinks
maybeAuthId >>= mapM_ \_ -> do
whenAuthenticated $ do
unit1
......@@ -9,10 +9,10 @@ module App.Page
PageFile (..),
IsPageKey (..),
AssetId (..),
PageTitle,
fetchPage,
fetchPageMaybe,
parseJsonPathPiece,
formatTitle,
)
where
......@@ -114,9 +114,7 @@ fetchPageMaybe :: (IsPageKey k, ByteStoreRO m) => k -> m (Maybe Pandoc)
fetchPageMaybe k =
loadStringMaybe k >>= mapM (fromPandoc k)
type PageTitle = Html
-- fetchPageTitle :: (IsPageKey k, ByteStoreRO m) => k -> m PageTitle
-- fetchPageTitle k = do
-- Pandoc meta _ <- fetchPage k
-- eitherThrow . runPure $ writeHtml5 def $
-- Pandoc nullMeta [Plain (docTitle meta)]
formatTitle :: MonadThrow m => Meta -> m Html
formatTitle meta =
eitherThrow . runPure $ writeHtml5 def $
Pandoc nullMeta [Plain (docTitle meta)]
......@@ -37,7 +37,6 @@ getProfileR = do
((_, widget), enctype) <- runFormPost $ profileForm (user ^. userNickName)
defaultLayout $ do
setTitle "Your profile"
[whamlet|
<div .col-12>
<table .table .table-borderless .table-sm>
......
......@@ -9,6 +9,7 @@
module App.Scores
( ScoresId,
ScoreExn (..),
augmentRoster,
)
where
......@@ -18,7 +19,6 @@ import App.User (UserId (..))
import App.YamlStore
import Control.Lens (makeLenses)
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson as Js
import Data.Foldable
import qualified Data.HashMap.Strict as HM
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment