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:
commit
8679428dda
@ -75,6 +75,7 @@ library
|
||||
Guide.Views.Utils
|
||||
Guide.Views.Utils.Input
|
||||
Guide.Cache
|
||||
Guide.Routes
|
||||
other-modules:
|
||||
Imports
|
||||
build-depends: Spock
|
||||
|
@ -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)
|
||||
|
@ -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
44
src/Guide/Routes.hs
Normal 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"
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user