Commit 4885ae13 authored by Christopher League's avatar Christopher League
Browse files

Cache auth entity and page metadata!

Just need to clear cache on git push
parent fe2d36aa
......@@ -33,6 +33,7 @@ module App.Foundation
module Yesod,
module Yesod.Auth,
setpassR,
getPageMeta,
)
where
......@@ -47,12 +48,13 @@ import App.YamlStore
import Conduit
import Control.Monad.Reader (ReaderT (runReaderT))
import Data.List (sort)
import qualified Data.Map as Map
import Data.String (fromString)
import Data.Typeable
import Network.Mail.Mime as Mail
import Text.Pandoc hiding (getCurrentTime)
import Text.Shakespeare.Text (stext)
import UnliftIO.IORef (IORef)
import UnliftIO.IORef (IORef, modifyIORef, readIORef)
import Yesod hiding (Entity (..), Key)
import Yesod.Auth hiding (maybeAuth, requireAuth)
import Yesod.Auth.Email
......@@ -89,6 +91,7 @@ mkYesodData
!/page/#AssetId PageAssetR GET
/post/#PostId PostR GET
/submit/#Text SubmitR GET POST
/cache/meta MetaCacheR GET DELETE
/auth AuthR Auth getAuth
|]
......@@ -168,7 +171,20 @@ messageAlert (status, body) =
|]
instance Yesod App where
yesodMiddleware = defaultCsrfMiddleware . defaultYesodMiddleware
yesodMiddleware =
defaultCsrfSetCookieMiddleware . csrfCheck . defaultYesodMiddleware
where
csrfCheck handler =
csrfCheckMiddleware
handler
needsCsrf
defaultCsrfHeaderName
defaultCsrfParamName
needsCsrf =
getCurrentRoute >>= \case
Nothing -> return False
Just MetaCacheR -> return False
Just r -> isWriteRequest r
authRoute _ = Just (AuthR LoginR)
......@@ -443,3 +459,17 @@ $forall uid <- users
setCredsRedirect $ Creds "admin" uid []
dispatch _ _ =
notFound
getPageMeta :: (IsPageKey k, AppHandler m) => k -> m Meta
getPageMeta k = do
cacheRef <- appMetaCache <$> getYesod
cache <- readIORef cacheRef
case Map.lookup (pageFile k) cache of
Just meta -> do
putStrLn $ "meta cache HIT: " <> toPathPiece (pageFile k)
return meta
Nothing -> do
putStrLn $ "meta cache MISS: " <> toPathPiece (pageFile k)
Pandoc meta _ <- runRo $ fetchPage k
modifyIORef cacheRef $ Map.insert (pageFile k) meta
return meta
......@@ -27,17 +27,31 @@ import App.User
import App.YamlStore
import Conduit
import Control.Monad.Catch (MonadMask)
import qualified Data.Map as Map
import qualified Data.Yaml as Yaml
import Network.Mime
import System.Environment
import System.Exit
import Text.Pandoc (runPure, writeHtml5String)
import UnliftIO.IORef (newIORef)
import UnliftIO.IORef (newIORef, readIORef, writeIORef)
import Yesod.Core.Types (FileInfo (..))
getFaviconR :: Handler TypedContent
getFaviconR =
getPageAssetR $ AssetId "learn.ico"
getMetaCacheR :: Handler Text
getMetaCacheR = do
cache <- readIORef . appMetaCache =<< getYesod
return $ convertString $ Yaml.encode cache
deleteMetaCacheR :: Handler Text
deleteMetaCacheR = do
cacheRef <- appMetaCache <$> getYesod
num <- Map.size <$> readIORef cacheRef
writeIORef cacheRef mempty
return $ "Dropped " <> show num <> " entries.\n"
getSubmitR :: Text -> Handler Html
getSubmitR sid = do
(widget, enctype) <- generateFormPost $ renderDivs $ fileAFormReq "your-file"
......
......@@ -4,6 +4,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
......@@ -31,7 +32,8 @@ import qualified Data.Set as Set
import Data.Time.Calendar (Day)
import Data.Time.Format
import Data.Tuple.Extra
import GHC.Generics
import GHC.Generics hiding (Meta)
import Text.Pandoc
data OutlineId = TheOutline
deriving (Eq, Ord, Show, Read)
......@@ -114,15 +116,24 @@ isNewPost user (pid, title) =
-- 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)]
listPosts :: Handler [(PostId, Html)]
listPosts =
runRo listPostIds >>= mapM \k -> (k,) <$> (getPageMeta k >>= formatTitle)
getHomeR :: Handler Html
getHomeR = do
(_, user) <- requireAuth
(posts, out, units) <- runRo $ do
posts <- map (isNewPost user) <$> listPosts
posts <- map (isNewPost user) <$> listPosts
(out, units) <- runRo $ do
out <- loadY TheOutline
let nums = [1 ..] :: [Int]
units = zip nums $ out ^. outUnits
return (posts, out, units)
return (out, units)
let newCount = length $ filter thd3 posts
defaultLayout
[whamlet|
......
......@@ -12,7 +12,6 @@ module App.Page
PageTitle,
fetchPage,
fetchPageMaybe,
fetchPageTitle,
parseJsonPathPiece,
)
where
......@@ -43,6 +42,8 @@ data PageFile
}
deriving (Eq, Ord, Show, Read)
instance ToJSONKey PageFile
instance PathPiece PageFile where
toPathPiece (PageFile page fmt) =
page <> pageExtension fmt
......@@ -114,9 +115,8 @@ 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)]
-- fetchPageTitle :: (IsPageKey k, ByteStoreRO m) => k -> m PageTitle
-- fetchPageTitle k = do
-- Pandoc meta _ <- fetchPage k
-- eitherThrow . runPure $ writeHtml5 def $
-- Pandoc nullMeta [Plain (docTitle meta)]
......@@ -6,7 +6,7 @@
module App.Post
( PostId (..),
listPosts,
listPostIds,
)
where
......@@ -53,10 +53,6 @@ instance IsPageKey PostId where
listPostIds :: ByteStoreRO m => m [PostId]
listPostIds =
listKeys <&> sortOn Down
listPosts :: ByteStoreRO m => m [(PostId, PageTitle)]
listPosts =
listPostIds >>= mapM \k -> (k,) <$> fetchPageTitle k
-- devSendLatestByEmail :: Mailer -> IO ()
-- devSendLatestByEmail mailer = do
-- flip runReaderT (WorkDir "data") $ do
......
......@@ -20,6 +20,7 @@ module App.Prelude
Maybe (..),
Either (..),
fromMaybe,
maybe,
maybeReturn,
maybeThrow,
mapMaybeM,
......
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