1
1
mirror of https://github.com/aelve/guide.git synced 2024-12-22 20:31:31 +03:00

Merge pull request #182 from aelve/fix/sectore-ghc-warnings

Fix ghc warnings (#181)
This commit is contained in:
Artyom Kazak 2017-07-30 16:55:18 +03:00 committed by GitHub
commit 8679428dda
7 changed files with 196 additions and 156 deletions

View File

@ -75,6 +75,7 @@ library
Guide.Views.Utils
Guide.Views.Utils.Input
Guide.Cache
Guide.Routes
other-modules:
Imports
build-depends: Spock

View File

@ -28,7 +28,7 @@ import qualified Text.Atom.Feed as Atom
import qualified Data.Text.All as T
import qualified Data.Text.Lazy.All as TL
-- Web
import Web.Spock hiding (head, get, text)
import Web.Spock hiding (head, get, renderRoute, text)
import qualified Web.Spock as Spock
import Web.Spock.Lucid
import Lucid hiding (for_)
@ -44,6 +44,7 @@ import Guide.State
import Guide.Types
import Guide.Utils
import Guide.Views
import Guide.Routes
methods :: GuideM ctx ()
methods = do
@ -53,40 +54,40 @@ methods = do
otherMethods
renderMethods :: GuideM ctx ()
renderMethods = Spock.subcomponent "render" $ do
renderMethods = do
-- Notes for a category
Spock.get (categoryVar <//> "notes") $ \catId -> do
Spock.get (renderRoute <//> categoryVar <//> "notes") $ \catId -> do
category <- dbQuery (GetCategory catId)
lucidIO $ renderCategoryNotes category
-- Item colors
Spock.get (itemVar <//> "colors") $ \itemId -> do
Spock.get (renderRoute <//> itemVar <//> "colors") $ \itemId -> do
item <- dbQuery (GetItem itemId)
category <- dbQuery (GetCategoryByItem itemId)
let hue = getItemHue category item
json $ M.fromList [("light" :: Text, hueToLightColor hue),
("dark" :: Text, hueToDarkColor hue)]
-- Item info
Spock.get (itemVar <//> "info") $ \itemId -> do
Spock.get (renderRoute <//> itemVar <//> "info") $ \itemId -> do
item <- dbQuery (GetItem itemId)
category <- dbQuery (GetCategoryByItem itemId)
lucidIO $ renderItemInfo category item
-- Item description
Spock.get (itemVar <//> "description") $ \itemId -> do
Spock.get (renderRoute <//> itemVar <//> "description") $ \itemId -> do
item <- dbQuery (GetItem itemId)
lucidIO $ renderItemDescription item
-- Item ecosystem
Spock.get (itemVar <//> "ecosystem") $ \itemId -> do
Spock.get (renderRoute <//> itemVar <//> "ecosystem") $ \itemId -> do
item <- dbQuery (GetItem itemId)
lucidIO $ renderItemEcosystem item
-- Item notes
Spock.get (itemVar <//> "notes") $ \itemId -> do
Spock.get (renderRoute <//> itemVar <//> "notes") $ \itemId -> do
item <- dbQuery (GetItem itemId)
category <- dbQuery (GetCategoryByItem itemId)
lucidIO $ renderItemNotes category item
setMethods :: GuideM ctx ()
setMethods = Spock.subcomponent "set" $ do
Spock.post (categoryVar <//> "info") $ \catId -> do
setMethods = do
Spock.post (setRoute <//> categoryVar <//> "info") $ \catId -> do
-- TODO: [easy] add a cross-link saying where the form is handled in the
-- code and other notes saying where stuff is rendered, etc
title' <- T.strip <$> param' "title"
@ -129,7 +130,7 @@ setMethods = Spock.subcomponent "set" $ do
category <- dbQuery (GetCategory catId)
lucidIO $ renderCategoryInfo category
-- Notes for a category
Spock.post (categoryVar <//> "notes") $ \catId -> do
Spock.post (setRoute <//> categoryVar <//> "notes") $ \catId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (notes.mdText) <$> dbQuery (GetCategory catId)
@ -146,7 +147,7 @@ setMethods = Spock.subcomponent "set" $ do
("modified" :: Text, modified),
("merged" :: Text, merge original content' modified)]
-- Item info
Spock.post (itemVar <//> "info") $ \itemId -> do
Spock.post (setRoute <//> itemVar <//> "info") $ \itemId -> do
-- TODO: [easy] add a cross-link saying where the form is handled in the
-- code and other notes saying where stuff is rendered, etc
name' <- T.strip <$> param' "name"
@ -192,7 +193,7 @@ setMethods = Spock.subcomponent "set" $ do
category <- dbQuery (GetCategoryByItem itemId)
lucidIO $ renderItemInfo category item
-- Item description
Spock.post (itemVar <//> "description") $ \itemId -> do
Spock.post (setRoute <//> itemVar <//> "description") $ \itemId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (description.mdText) <$> dbQuery (GetItem itemId)
@ -209,7 +210,7 @@ setMethods = Spock.subcomponent "set" $ do
("modified" :: Text, modified),
("merged" :: Text, merge original content' modified)]
-- Item ecosystem
Spock.post (itemVar <//> "ecosystem") $ \itemId -> do
Spock.post (setRoute <//> itemVar <//> "ecosystem") $ \itemId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId)
@ -226,7 +227,7 @@ setMethods = Spock.subcomponent "set" $ do
("modified" :: Text, modified),
("merged" :: Text, merge original content' modified)]
-- Item notes
Spock.post (itemVar <//> "notes") $ \itemId -> do
Spock.post (setRoute <//> itemVar <//> "notes") $ \itemId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (notes.mdText) <$> dbQuery (GetItem itemId)
@ -244,7 +245,7 @@ setMethods = Spock.subcomponent "set" $ do
("modified" :: Text, modified),
("merged" :: Text, merge original content' modified)]
-- Trait
Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
Spock.post (setRoute <//> itemVar <//> traitVar) $ \itemId traitId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId)
@ -262,9 +263,9 @@ setMethods = Spock.subcomponent "set" $ do
("merged" :: Text, merge original content' modified)]
addMethods :: GuideM ctx ()
addMethods = Spock.subcomponent "add" $ do
addMethods = do
-- New category
Spock.post "category" $ do
Spock.post (addRoute <//> "category") $ do
title' <- param' "content"
-- If the category exists already, don't create it
cats <- view categories <$> dbQuery GetGlobalState
@ -282,7 +283,7 @@ addMethods = Spock.subcomponent "add" $ do
Spock.text ("/haskell/" <> categorySlug category)
-- New item in a category
Spock.post (categoryVar <//> "item") $ \catId -> do
Spock.post (addRoute <//> categoryVar <//> "item") $ \catId -> do
name' <- param' "name"
-- TODO: do something if the category doesn't exist (e.g. has been
-- already deleted)
@ -299,7 +300,7 @@ addMethods = Spock.subcomponent "add" $ do
category <- dbQuery (GetCategory catId)
lucidIO $ renderItem category newItem
-- Pro (argument in favor of an item)
Spock.post (itemVar <//> "pro") $ \itemId -> do
Spock.post (addRoute <//> itemVar <//> "pro") $ \itemId -> do
content' <- param' "content"
traitId <- randomLongUid
(edit, newTrait) <- dbUpdate (AddPro itemId traitId content')
@ -307,7 +308,7 @@ addMethods = Spock.subcomponent "add" $ do
addEdit edit
lucidIO $ renderTrait itemId newTrait
-- Con (argument against an item)
Spock.post (itemVar <//> "con") $ \itemId -> do
Spock.post (addRoute <//> itemVar <//> "con") $ \itemId -> do
content' <- param' "content"
traitId <- randomLongUid
(edit, newTrait) <- dbUpdate (AddCon itemId traitId content')
@ -318,68 +319,66 @@ addMethods = Spock.subcomponent "add" $ do
otherMethods :: GuideM ctx ()
otherMethods = do
-- Moving things
Spock.subcomponent "move" $ do
-- Move item
Spock.post itemVar $ \itemId -> do
direction :: Text <- param' "direction"
uncache (CacheItem itemId) $ do
edit <- dbUpdate (MoveItem itemId (direction == "up"))
addEdit edit
-- Move trait
Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
direction :: Text <- param' "direction"
uncache (CacheItemTraits itemId) $ do
edit <- dbUpdate (MoveTrait itemId traitId (direction == "up"))
addEdit edit
-- Move item
Spock.post (moveRoute <//> itemVar) $ \itemId -> do
direction :: Text <- param' "direction"
uncache (CacheItem itemId) $ do
edit <- dbUpdate (MoveItem itemId (direction == "up"))
addEdit edit
-- Move trait
Spock.post (moveRoute <//> itemVar <//> traitVar) $ \itemId traitId -> do
direction :: Text <- param' "direction"
uncache (CacheItemTraits itemId) $ do
edit <- dbUpdate (MoveTrait itemId traitId (direction == "up"))
addEdit edit
-- Deleting things
Spock.subcomponent "delete" $ do
-- Delete category
Spock.post categoryVar $ \catId ->
uncache (CacheCategory catId) $ do
mbEdit <- dbUpdate (DeleteCategory catId)
mapM_ addEdit mbEdit
-- Delete item
Spock.post itemVar $ \itemId ->
uncache (CacheItem itemId) $ do
mbEdit <- dbUpdate (DeleteItem itemId)
mapM_ addEdit mbEdit
-- Delete trait
Spock.post (itemVar <//> traitVar) $ \itemId traitId ->
uncache (CacheItemTraits itemId) $ do
mbEdit <- dbUpdate (DeleteTrait itemId traitId)
mapM_ addEdit mbEdit
-- Deleting things
-- Delete category
Spock.post (deleteRoute <//> categoryVar) $ \catId ->
uncache (CacheCategory catId) $ do
mbEdit <- dbUpdate (DeleteCategory catId)
mapM_ addEdit mbEdit
-- Delete item
Spock.post (deleteRoute <//> itemVar) $ \itemId ->
uncache (CacheItem itemId) $ do
mbEdit <- dbUpdate (DeleteItem itemId)
mapM_ addEdit mbEdit
-- Delete trait
Spock.post (deleteRoute <//> itemVar <//> traitVar) $ \itemId traitId ->
uncache (CacheItemTraits itemId) $ do
mbEdit <- dbUpdate (DeleteTrait itemId traitId)
mapM_ addEdit mbEdit
-- Feeds
-- TODO: this link shouldn't be absolute [absolute-links]
baseUrl <- (// "haskell") . _baseUrl <$> getConfig
Spock.subcomponent "feed" $ do
-- Feed for items in a category
Spock.get categoryVar $ \catId -> do
category <- dbQuery (GetCategory catId)
let sortedItems = reverse $ sortBy cmp (category^.items)
where cmp = comparing (^.created) <> comparing (^.uid)
let route = "feed" <//> categoryVar
let feedUrl = baseUrl // renderRoute route (category^.uid)
feedTitle = Atom.TextString (T.unpack (category^.title) ++
" Haskell Aelve Guide")
feedLastUpdate = case sortedItems of
(item:_) -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)
_ -> ""
let feedBase = Atom.nullFeed (T.unpack feedUrl) feedTitle feedLastUpdate
entries <- liftIO $ mapM (itemToFeedEntry baseUrl category) sortedItems
atomFeed $ feedBase {
Atom.feedEntries = entries,
Atom.feedLinks = [Atom.nullLink (T.unpack feedUrl)] }
-- Feed for items in a category
Spock.get (feedRoute <//> categoryVar) $ \catId -> do
category <- dbQuery (GetCategory catId)
let sortedItems = reverse $ sortBy cmp (category^.items)
where cmp = comparing (^.created) <> comparing (^.uid)
let route = "feed" <//> categoryVar
let feedUrl = baseUrl // Spock.renderRoute route (category^.uid)
feedTitle = Atom.TextString (T.unpack (category^.title) ++
" Haskell Aelve Guide")
feedLastUpdate = case sortedItems of
(item:_) -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)
_ -> ""
let feedBase = Atom.nullFeed (T.unpack feedUrl) feedTitle feedLastUpdate
entries <- liftIO $ mapM (itemToFeedEntry baseUrl category) sortedItems
atomFeed $ feedBase {
Atom.feedEntries = entries,
Atom.feedLinks = [Atom.nullLink (T.unpack feedUrl)] }
adminMethods :: AdminM ctx ()
adminMethods = Spock.subcomponent "admin" $ do
adminMethods = do
-- Accept an edit
Spock.post ("edit" <//> var <//> "accept") $ \n -> do
Spock.post (adminRoute <//> "edit" <//> var <//> "accept") $ \n -> do
dbUpdate (RemovePendingEdit n)
return ()
-- Undo an edit
Spock.post ("edit" <//> var <//> "undo") $ \n -> do
Spock.post (adminRoute <//> "edit" <//> var <//> "undo") $ \n -> do
(edit, _) <- dbQuery (GetEdit n)
res <- undoEdit edit
case res of
@ -388,10 +387,10 @@ adminMethods = Spock.subcomponent "admin" $ do
dbUpdate (RemovePendingEdit n)
Spock.text ""
-- Accept a range of edits
Spock.post ("edits" <//> var <//> var <//> "accept") $ \m n -> do
Spock.post (adminRoute <//> "edits" <//> var <//> var <//> "accept") $ \m n -> do
dbUpdate (RemovePendingEdits m n)
-- Undo a range of edits
Spock.post ("edits" <//> var <//> var <//> "undo") $ \m n -> do
Spock.post (adminRoute <//> "edits" <//> var <//> var <//> "undo") $ \m n -> do
edits <- dbQuery (GetEdits m n)
s <- dbQuery GetGlobalState
failed <- fmap catMaybes $ for edits $ \(edit, details) -> do
@ -405,7 +404,7 @@ adminMethods = Spock.subcomponent "admin" $ do
[] -> Spock.text ""
_ -> lucidIO $ renderEdits s failed
-- Create a checkpoint
Spock.post "create-checkpoint" $ do
Spock.post (adminRoute <//> "create-checkpoint") $ do
db <- _db <$> Spock.getState
createCheckpoint' db
@ -419,7 +418,7 @@ getLoggedInUser = do
sess <- readSession
case sess ^. sessionUserID of
Nothing -> return Nothing
Just uid -> dbQuery $ GetUser uid
Just uid' -> dbQuery $ GetUser uid'
itemToFeedEntry
:: (MonadIO m)

View File

@ -68,6 +68,7 @@ import Guide.JS (JS(..), allJSFunctions)
import Guide.Utils
import Guide.Cache
import Guide.Session
import Guide.Routes (authRoute, haskellRoute)
{- Note [acid-state]
@ -249,7 +250,7 @@ guideApp waiMetrics = do
-- Main page
Spock.get root $
lucidWithConfig $ renderRoot
lucidWithConfig renderRoot
-- Admin page
prehook authHook $ prehook adminHook $ do
@ -263,7 +264,7 @@ guideApp waiMetrics = do
-- Donation page
Spock.get "donate" $
lucidWithConfig $ renderDonate
lucidWithConfig renderDonate
-- Static pages
Spock.get "unwritten-rules" $ lucidWithConfig $
@ -274,57 +275,55 @@ guideApp waiMetrics = do
renderStaticMd "License" "license.md"
-- Haskell
Spock.subcomponent "haskell" $ do
Spock.get root $ do
s <- dbQuery GetGlobalState
q <- param "q"
(time, mbIP, mbReferrer, mbUA) <- getRequestDetails
let act = case q of
Nothing -> Action'MainPageVisit
Just x -> Action'Search x
baseUrl <- _baseUrl <$> getConfig
dbUpdate (RegisterAction act mbIP time baseUrl mbReferrer mbUA)
lucidWithConfig $ renderHaskellRoot s q
-- Category pages
Spock.get var $ \path -> do
-- The links look like /parsers-gao238b1 (because it's nice when
-- you can find out where a link leads just by looking at it)
let (_, catId) = T.breakOnEnd "-" path
when (T.null catId) $
Spock.jumpNext
mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
case mbCategory of
Nothing -> Spock.jumpNext
Just category -> do
(time, mbIP, mbReferrer, mbUA) <- getRequestDetails
baseUrl <- _baseUrl <$> getConfig
dbUpdate $ RegisterAction (Action'CategoryVisit (Uid catId))
mbIP time baseUrl mbReferrer mbUA
-- If the slug in the url is old (i.e. if it doesn't match the
-- one we would've generated now), let's do a redirect
when (categorySlug category /= path) $
-- TODO: this link shouldn't be absolute [absolute-links]
Spock.redirect ("/haskell/" <> categorySlug category)
lucidWithConfig $ renderCategoryPage category
-- The add/set methods return rendered parts of the structure (added
-- categories, changed items, etc) so that the Javascript part could
-- take them and inject into the page. We don't want to duplicate
-- rendering on server side and on client side.
methods
Spock.subcomponent "auth" $ do
-- plain "/auth" logs out a logged-in user and lets a logged-out user
-- log in (this is not the best idea, granted, and we should just
-- shot logged-in users a “logout” link and logged-out users a
-- “login” link instead)
Spock.get root $ do
user <- getLoggedInUser
if isJust user
then Spock.redirect "auth/logout"
else Spock.redirect "auth/login"
Spock.getpost "login" $ authRedirect "/" $ loginAction
Spock.get "logout" $ logoutAction
Spock.getpost "register" $ authRedirect "/" $ signupAction
Spock.get (haskellRoute <//> root) $ do
s <- dbQuery GetGlobalState
q <- param "q"
(time, mbIP, mbReferrer, mbUA) <- getRequestDetails
let act = case q of
Nothing -> Action'MainPageVisit
Just x -> Action'Search x
baseUrl <- _baseUrl <$> getConfig
dbUpdate (RegisterAction act mbIP time baseUrl mbReferrer mbUA)
lucidWithConfig $ renderHaskellRoot s q
-- Category pages
Spock.get (haskellRoute <//> var) $ \path -> do
-- The links look like /parsers-gao238b1 (because it's nice when
-- you can find out where a link leads just by looking at it)
let (_, catId) = T.breakOnEnd "-" path
when (T.null catId)
Spock.jumpNext
mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
case mbCategory of
Nothing -> Spock.jumpNext
Just category -> do
(time, mbIP, mbReferrer, mbUA) <- getRequestDetails
baseUrl <- _baseUrl <$> getConfig
dbUpdate $ RegisterAction (Action'CategoryVisit (Uid catId))
mbIP time baseUrl mbReferrer mbUA
-- If the slug in the url is old (i.e. if it doesn't match the
-- one we would've generated now), let's do a redirect
when (categorySlug category /= path) $
-- TODO: this link shouldn't be absolute [absolute-links]
Spock.redirect ("/haskell/" <> categorySlug category)
lucidWithConfig $ renderCategoryPage category
-- The add/set methods return rendered parts of the structure (added
-- categories, changed items, etc) so that the Javascript part could
-- take them and inject into the page. We don't want to duplicate
-- rendering on server side and on client side.
methods
-- plain "/auth" logs out a logged-in user and lets a logged-out user
-- log in (this is not the best idea, granted, and we should just
-- shot logged-in users a “logout” link and logged-out users a
-- “login” link instead)
Spock.get (authRoute <//> root) $ do
user <- getLoggedInUser
if isJust user
then Spock.redirect "auth/logout"
else Spock.redirect "auth/login"
Spock.getpost "login" $ authRedirect "/" loginAction
Spock.get "logout" logoutAction
Spock.getpost "register" $ authRedirect "/" signupAction
loginAction :: GuideAction ctx ()
loginAction = do
@ -353,7 +352,7 @@ logoutAction = do
signupAction :: GuideAction ctx ()
signupAction = do
r <- runForm "register" registerForm
case r of
case r of
(v, Nothing) -> do
formHtml <- protectForm registerFormView v
lucidWithConfig $ renderRegister formHtml
@ -384,7 +383,7 @@ adminHook :: ListContains n User xs => GuideAction (HVect xs) (HVect (IsAdmin ':
adminHook = do
oldCtx <- getContext
let user = findFirst oldCtx
if user ^. userIsAdmin
if user ^. userIsAdmin
then return (IsAdmin :&: oldCtx)
else Spock.text "Not authorized."
@ -393,7 +392,7 @@ authRedirect :: Text -> GuideAction ctx a -> GuideAction ctx a
authRedirect path action = do
user <- getLoggedInUser
case user of
Just _ -> do
Just _ ->
Spock.redirect path
Nothing -> action
@ -404,9 +403,9 @@ authRedirect path action = do
-- templates and clears the cache whenever a change occurs, so that you
-- wouldn't see cached pages.
startTemplateWatcher :: IO ()
startTemplateWatcher = void $ do
startTemplateWatcher = void $
Slave.fork $ FSNotify.withManager $ \mgr -> do
FSNotify.watchTree mgr "templates/" (const True) $ \_ -> do
FSNotify.watchTree mgr "templates/" (const True) $ \_ ->
emptyCache
forever $ threadDelay 1000000

44
src/Guide/Routes.hs Normal file
View File

@ -0,0 +1,44 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
module Guide.Routes
( addRoute
, adminRoute
, authRoute
, deleteRoute
, haskellRoute
, feedRoute
, moveRoute
, renderRoute
, setRoute
) where
import Web.Spock (Path)
import Web.Routing.Combinators (PathState(Open))
haskellRoute :: Path '[] 'Open
haskellRoute = "haskell"
authRoute :: Path '[] 'Open
authRoute = "auth"
setRoute :: Path '[] 'Open
setRoute = "set"
addRoute :: Path '[] 'Open
addRoute = "add"
moveRoute :: Path '[] 'Open
moveRoute = "move"
deleteRoute :: Path '[] 'Open
deleteRoute = "delete"
feedRoute :: Path '[] 'Open
feedRoute = "feed"
renderRoute :: Path '[] 'Open
renderRoute = "render"
adminRoute :: Path '[] 'Open
adminRoute = "admin"

View File

@ -830,9 +830,9 @@ renderAdminLinks globalState = do
fullList <- liftIO $ forM allLinks $ \(lnk, location) -> do
resp <- if isURI (T.unpack lnk) then (do
request <- parseRequest $ T.unpack lnk
status <- responseStatus <$> httpNoBody request manager
print (lnk, status)
pure $ case status of
status' <- responseStatus <$> httpNoBody request manager
print (lnk, status')
pure $ case status' of
Status 200 _ -> OK
Status code err -> Broken (""+|code|+": "+||err||+"")
) `catch` (return . handleHttpException)
@ -883,7 +883,7 @@ renderAdminLinks globalState = do
sortLink (a, b, OK) = (\(x, y, z) -> ((a, b):x, y, z))
sortLink (a, b, Unparseable) = (\(x, y, z) -> (x, (a, b):y, z))
sortLink (a, b, Broken text) = (\(x, y, z) -> (x, y, (a, b, text):z))
sortLink (a, b, Broken text') = (\(x, y, z) -> (x, y, (a, b, text'):z))
allLinks :: [(Url, Text)]
allLinks = ordNub (findLinks globalState)

View File

@ -14,7 +14,6 @@ import Imports
import Text.Digestive
-- lucid
import Lucid hiding (for_)
import Guide.Views.Page
import Guide.Views.Utils
import Guide.Config
@ -34,18 +33,18 @@ loginForm = Login
-- | Render input elements for a 'Login'
-- Note: This does not include the 'Form' element.
--
-- Use 'Guide.Server.protectForm' to render the appropriate form element with CSRF protection.
-- Use 'Guide.Server.protectForm' to render the appropriate form element with CSRF protection.
loginFormView :: MonadIO m => View (HtmlT m ()) -> HtmlT m ()
loginFormView view = do
loginFormView view' = do
div_ $ do
errorList "email" view
label "email" view "Email: "
inputText "email" view
errorList "email" view'
label "email" view' "Email: "
inputText "email" view'
div_ $ do
errorList "password" view
label "password" view "Password: "
inputPassword "password" view
errorList "password" view'
label "password" view' "Password: "
inputPassword "password" view'
inputSubmit "Log in"
@ -54,11 +53,11 @@ loginView :: (MonadIO m) => User -> HtmlT m ()
loginView user = do
div_ $ do
-- TODO: Make nicer.
"You are registered and logged in as "
"You are registered and logged in as "
toHtml (user ^. userName)
renderLogin :: (MonadIO m, MonadReader Config m) => HtmlT m () -> HtmlT m ()
renderLogin content = do
renderPage $
renderPage $
pageDef & pageTitle .~ "Aelve Guide"
& pageContent .~ content

View File

@ -363,8 +363,8 @@ readWidget fp = liftIO $ do
readWidgets :: MonadIO m => m [(SectionType, Text)]
readWidgets = liftIO $ do
let isWidget = F.extension F.==? ".widget"
files <- F.find F.always isWidget "templates/"
concat <$> mapM readWidget files
files' <- F.find F.always isWidget "templates/"
concat <$> mapM readWidget files'
getJS :: MonadIO m => m Text
getJS = do
@ -382,7 +382,7 @@ getCSS = do
--
-- This sets the method (POST) of submission and includes a server-generated
-- token to help prevent cross-site request forgery (CSRF) attacks.
--
--
-- Briefly: this is necessary to prevent third party sites from impersonating
-- logged in users, because a POST to the right URL is not sufficient to
-- submit the form and perform an action. The CSRF token is only displayed
@ -392,9 +392,9 @@ protectForm :: MonadIO m
-> View (HtmlT m ())
-> GuideAction ctx (HtmlT m ())
protectForm render formView = do
(name, value) <- getCsrfTokenPair
(name', value) <- getCsrfTokenPair
return $ form formView "" [id_ "login-form"] $ do
input_ [ type_ "hidden", name_ name, value_ value ]
input_ [ type_ "hidden", name_ name', value_ value ]
render formView
getCsrfTokenPair :: GuideAction ctx (Text, Text)
@ -408,5 +408,3 @@ getCsrfHeader = do
csrfTokenName <- spc_csrfHeaderName <$> getSpockCfg
csrfTokenValue <- getCsrfToken
return (csrfTokenName, csrfTokenValue)