mirror of
https://github.com/aelve/guide.git
synced 2024-12-22 20:31:31 +03:00
Merge branch 'master' into front-ps
This commit is contained in:
Jens Krause
commit
aaf5c7d8b0
3
.gitignore
vendored
3
.gitignore
vendored
@ -25,6 +25,9 @@ state/
|
||||
config.json
|
||||
|
||||
# IDE/support
|
||||
.idea/
|
||||
.ideaHaskellLib/
|
||||
guide.iml
|
||||
.vscode/
|
||||
tags
|
||||
|
||||
|
||||
@ -1,7 +1,5 @@
|
||||
{-# LANGUAGE
|
||||
FlexibleContexts,
|
||||
GADTs
|
||||
#-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
-- run as: ./gen -o favicon.png -w 32 -h 32
|
||||
|
||||
|
||||
@ -76,6 +76,7 @@ library
|
||||
Guide.Views.Utils.Input
|
||||
Guide.Cache
|
||||
Guide.Api.ClientTypes
|
||||
Guide.Routes
|
||||
other-modules:
|
||||
Imports
|
||||
build-depends: Spock
|
||||
@ -110,6 +111,8 @@ library
|
||||
, hashable
|
||||
, haskell-src-meta
|
||||
, http-api-data
|
||||
, http-client
|
||||
, http-client-tls
|
||||
, http-types
|
||||
, hvect
|
||||
, ilist
|
||||
@ -139,6 +142,7 @@ library
|
||||
, text-all >= 0.4.1.0 && < 0.5
|
||||
, time >= 1.5
|
||||
, transformers
|
||||
, uniplate
|
||||
, unix
|
||||
, utf8-string
|
||||
, vector
|
||||
|
||||
@ -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 Network.Wai.Middleware.Cors
|
||||
@ -46,6 +46,7 @@ import Guide.Types
|
||||
import Guide.Api.ClientTypes (toCGrandCategory, toCCategoryDetail)
|
||||
import Guide.Utils
|
||||
import Guide.Views
|
||||
import Guide.Routes
|
||||
|
||||
methods :: GuideM ctx ()
|
||||
methods = do
|
||||
@ -67,40 +68,40 @@ apiMethods = Spock.subcomponent "api" $ do
|
||||
json $ toCCategoryDetail cat
|
||||
|
||||
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"
|
||||
@ -143,7 +144,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)
|
||||
@ -160,7 +161,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"
|
||||
@ -206,7 +207,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)
|
||||
@ -223,7 +224,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)
|
||||
@ -240,7 +241,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)
|
||||
@ -258,7 +259,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)
|
||||
@ -276,9 +277,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
|
||||
@ -296,7 +297,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)
|
||||
@ -313,7 +314,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')
|
||||
@ -321,7 +322,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')
|
||||
@ -332,68 +333,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
|
||||
@ -402,10 +401,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
|
||||
@ -419,7 +418,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
|
||||
|
||||
@ -433,7 +432,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)
|
||||
|
||||
@ -122,8 +122,8 @@ class JSFunction a where
|
||||
instance JSFunction JS where
|
||||
makeJSFunction fName fParams fDef =
|
||||
let paramList = T.intercalate "," fParams
|
||||
in JS $ format "function "#|fName|#"("#|paramList|#") {\n"
|
||||
#|indent 2 (build fDef)|#
|
||||
in JS $ format "function "+|fName|+"("+|paramList|+") {\n"
|
||||
+|indent 2 (build fDef)|+
|
||||
"}\n"
|
||||
|
||||
-- This generates a function that takes arguments and produces a Javascript
|
||||
|
||||
@ -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
|
||||
@ -257,10 +258,13 @@ guideApp waiMetrics = do
|
||||
s <- dbQuery GetGlobalState
|
||||
lucidIO $ renderAdmin s
|
||||
adminMethods
|
||||
Spock.get ("admin" <//> "links") $ do
|
||||
s <- dbQuery GetGlobalState
|
||||
lucidIO $ renderAdminLinks s
|
||||
|
||||
-- Donation page
|
||||
Spock.get "donate" $
|
||||
lucidWithConfig $ renderDonate
|
||||
lucidWithConfig renderDonate
|
||||
|
||||
-- Static pages
|
||||
Spock.get "unwritten-rules" $ lucidWithConfig $
|
||||
@ -271,55 +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) = fromCategorySlug path
|
||||
mbCategory <- dbQuery (GetCategoryMaybe catId)
|
||||
case mbCategory of
|
||||
Nothing -> Spock.jumpNext
|
||||
Just category -> do
|
||||
(time, mbIP, mbReferrer, mbUA) <- getRequestDetails
|
||||
baseUrl <- _baseUrl <$> getConfig
|
||||
dbUpdate $ RegisterAction (Action'CategoryVisit 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.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
|
||||
|
||||
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
|
||||
-- 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
|
||||
@ -388,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
|
||||
|
||||
@ -399,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
|
||||
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@ -71,17 +73,25 @@ data MarkdownInline = MarkdownInline {
|
||||
markdownInlineMdText :: Text,
|
||||
markdownInlineMdHtml :: ByteString,
|
||||
markdownInlineMdMarkdown :: ![MD.Node] }
|
||||
deriving (Generic, Data)
|
||||
|
||||
data MarkdownBlock = MarkdownBlock {
|
||||
markdownBlockMdText :: Text,
|
||||
markdownBlockMdHtml :: ByteString,
|
||||
markdownBlockMdMarkdown :: ![MD.Node] }
|
||||
deriving (Generic, Data)
|
||||
|
||||
data MarkdownTree = MarkdownTree {
|
||||
markdownTreeMdText :: Text,
|
||||
markdownTreeMdTree :: !(Document Text ByteString),
|
||||
markdownTreeMdIdPrefix :: Text,
|
||||
markdownTreeMdTOC :: Forest ([MD.Node], Text) }
|
||||
deriving (Generic, Data)
|
||||
|
||||
-- Orphan instances (to be deleted after migration to newer cmark-sections)
|
||||
deriving instance (Data a) => Data (Annotated a)
|
||||
deriving instance (Data a, Data b) => Data (Section a b)
|
||||
deriving instance (Data a, Data b) => Data (Document a b)
|
||||
|
||||
makeFields ''MarkdownInline
|
||||
makeFields ''MarkdownBlock
|
||||
|
||||
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"
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
@ -94,7 +95,7 @@ For an explanation of deriveSafeCopySorted, see Note [acid-state].
|
||||
data Trait = Trait {
|
||||
_traitUid :: Uid Trait,
|
||||
_traitContent :: MarkdownInline }
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
deriveSafeCopySorted 4 'extension ''Trait
|
||||
makeFields ''Trait
|
||||
@ -115,7 +116,7 @@ data ItemKind
|
||||
= Library (Maybe Text) -- Hackage name
|
||||
| Tool (Maybe Text) -- Hackage name
|
||||
| Other
|
||||
deriving (Eq, Show, Generic)
|
||||
deriving (Eq, Show, Generic, Data)
|
||||
|
||||
deriveSafeCopySimple 3 'extension ''ItemKind
|
||||
|
||||
@ -154,7 +155,7 @@ data ItemSection
|
||||
= ItemProsConsSection
|
||||
| ItemEcosystemSection
|
||||
| ItemNotesSection
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
deriving (Eq, Ord, Show, Generic, Data)
|
||||
|
||||
deriveSafeCopySimple 0 'base ''ItemSection
|
||||
|
||||
@ -181,7 +182,7 @@ data Item = Item {
|
||||
_itemLink :: Maybe Url, -- ^ Link to homepage or something
|
||||
_itemKind :: ItemKind -- ^ Is it a library, tool, etc
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
deriveSafeCopySorted 11 'extension ''Item
|
||||
makeFields ''Item
|
||||
@ -202,7 +203,7 @@ data CategoryStatus
|
||||
= CategoryStub -- ^ “Stub” = just created
|
||||
| CategoryWIP -- ^ “WIP” = work in progress
|
||||
| CategoryFinished -- ^ “Finished” = complete or nearly complete
|
||||
deriving (Eq, Show, Generic)
|
||||
deriving (Eq, Show, Generic, Data)
|
||||
|
||||
deriveSafeCopySimple 2 'extension ''CategoryStatus
|
||||
|
||||
@ -250,7 +251,7 @@ data Category = Category {
|
||||
-- all items in a group are deleted
|
||||
_categoryGroups :: Map Text Hue
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
deriveSafeCopySorted 11 'extension ''Category
|
||||
makeFields ''Category
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@ -25,8 +26,7 @@ import Data.SafeCopy hiding (kind)
|
||||
|
||||
|
||||
data Hue = NoHue | Hue Int
|
||||
deriving (Generic, Eq, Ord)
|
||||
-- generic deriving ^ is needed by purescript-bridge
|
||||
deriving (Eq, Ord, Generic, Data)
|
||||
|
||||
deriveSafeCopySimple 1 'extension ''Hue
|
||||
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@ -296,7 +297,7 @@ sockAddrToIP _ = Nothing
|
||||
|
||||
-- | Unique id, used for many things – categories, items, and anchor ids.
|
||||
newtype Uid a = Uid {uidToText :: Text}
|
||||
deriving (Eq, Ord, Show,
|
||||
deriving (Eq, Ord, Show, Data,
|
||||
ToHttpApiData, FromHttpApiData,
|
||||
T.Buildable, Hashable, A.ToJSON)
|
||||
|
||||
|
||||
@ -14,6 +14,7 @@ module Guide.Views
|
||||
-- * Pages
|
||||
renderRoot,
|
||||
renderAdmin,
|
||||
renderAdminLinks,
|
||||
renderDonate,
|
||||
renderCategoryPage,
|
||||
renderHaskellRoot,
|
||||
@ -35,6 +36,7 @@ import Guide.Views.Category as X
|
||||
|
||||
import Imports
|
||||
|
||||
import Data.Monoid ((<>))
|
||||
-- Text
|
||||
import qualified Data.Text.All as T
|
||||
import NeatInterpolation
|
||||
@ -42,10 +44,18 @@ import NeatInterpolation
|
||||
import Lucid hiding (for_)
|
||||
-- Network
|
||||
import Data.IP
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Client.TLS
|
||||
import Network.HTTP.Types.Status (Status(..))
|
||||
import Network.URI (isURI)
|
||||
-- Time
|
||||
import Data.Time.Format.Human
|
||||
-- Mustache (templates)
|
||||
import qualified Data.Aeson as A
|
||||
-- CMark
|
||||
import qualified CMark as MD
|
||||
-- Generic traversal (for finding links in content)
|
||||
import Data.Generics.Uniplate.Data (universeBi)
|
||||
|
||||
import Guide.Config
|
||||
import Guide.State
|
||||
@ -161,13 +171,16 @@ enabled, and in this case the relevant tag will always be “shown” and not
|
||||
|
||||
-- | Render the subtitle below the “Aelve Guide” header that is present on
|
||||
-- every page.
|
||||
renderSubtitle :: (MonadReader Config m) => HtmlT m ()
|
||||
renderSubtitle =
|
||||
renderSubtitle :: Monad m => HtmlT m ()
|
||||
renderSubtitle = pure ()
|
||||
{- previous version of the subtitle
|
||||
-----------------------------------
|
||||
div_ [class_ "subtitle"] $ do
|
||||
"alpha version • don't post on Reddit yet"
|
||||
lift (asks _discussLink) >>= \case
|
||||
Nothing -> return ()
|
||||
Just l -> " • " >> mkLink "discuss the site" l
|
||||
-}
|
||||
|
||||
-- | Render the main page (<https://guide.aelve.com>).
|
||||
renderRoot :: (MonadIO m, MonadReader Config m) => HtmlT m ()
|
||||
@ -237,8 +250,7 @@ renderStats globalState acts = do
|
||||
th_ "Visits"
|
||||
th_ "Unique visitors"
|
||||
tbody_ $ do
|
||||
let rawVisits :: [(Uid Category, Maybe IP
|
||||
)]
|
||||
let rawVisits :: [(Uid Category, Maybe IP)]
|
||||
rawVisits = [(catId, actionIP d) |
|
||||
(Action'CategoryVisit catId, d) <- acts']
|
||||
let visits :: [(Uid Category, (Int, Int))]
|
||||
@ -318,7 +330,7 @@ renderEdits globalState edits = do
|
||||
let editBlocks = groupBy (equating getIP) edits
|
||||
let ipNum = length $ groupWith getIP edits
|
||||
h1_ $ toHtml @Text $
|
||||
"Pending edits (IPs: "#|ipNum|#", blocks: "#|length editBlocks|#")"
|
||||
"Pending edits (IPs: "+|ipNum|+", blocks: "+|length editBlocks|+")"
|
||||
for_ editBlocks $ \editBlock -> div_ $ do
|
||||
blockNode <- thisNode
|
||||
h2_ $ do
|
||||
@ -793,3 +805,111 @@ on those <div>s.
|
||||
-- people instead just write “TODO fix grammar” in description and then such
|
||||
-- things could be displayed in gray font and also there'd be an
|
||||
-- automatically updated list of TODOs somewhere?)
|
||||
|
||||
data LinkStatus = OK | Unparseable | Broken String deriving Show
|
||||
|
||||
-- | Render links page with info about broken links
|
||||
renderAdminLinks :: (MonadIO m) => GlobalState -> HtmlT m ()
|
||||
renderAdminLinks globalState = do
|
||||
head_ $ do
|
||||
includeJS "/js.js"
|
||||
includeJS "/jquery.js"
|
||||
includeJS "/sorttable.js"
|
||||
includeCSS "/markup.css"
|
||||
includeCSS "/admin.css"
|
||||
includeCSS "/loader.css"
|
||||
title_ "Links – Aelve Guide"
|
||||
meta_ [name_ "viewport",
|
||||
content_ "width=device-width, initial-scale=1.0, user-scalable=yes"]
|
||||
|
||||
body_ $ do
|
||||
script_ $ fromJS $ JS.createAjaxIndicator ()
|
||||
h1_ "Links"
|
||||
div_ [id_ "stats"] $ do
|
||||
manager <- liftIO $ newManager tlsManagerSettings
|
||||
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 200 _ -> OK
|
||||
Status code err -> Broken (""+|code|+": "+||err||+"")
|
||||
) `catch` (return . handleHttpException)
|
||||
else
|
||||
pure Unparseable
|
||||
pure (toHtml location, a_ [href_ lnk] (toHtml lnk), resp)
|
||||
let (ok, unparseable, broken) = sortLinks fullList
|
||||
|
||||
h2_ "Broken Links"
|
||||
table_ [class_ "sortable"] $ do
|
||||
thead_ $ tr_ $ do
|
||||
th_ [class_ "sorttable_nosort"] "Category"
|
||||
th_ [class_ "sorttable_nosort"] "Link"
|
||||
th_ "Status"
|
||||
tbody_ $ do
|
||||
for_ broken $ \(location, lnk, reason) -> do
|
||||
tr_ $ do
|
||||
td_ location
|
||||
td_ lnk
|
||||
td_ $ toHtml reason
|
||||
h2_ "Unparseable Links"
|
||||
table_ [class_ "sortable"] $ do
|
||||
thead_ $ tr_ $ do
|
||||
th_ [class_ "sorttable_nosort"] "Category"
|
||||
th_ [class_ "sorttable_nosort"] "Link"
|
||||
tbody_ $ do
|
||||
for_ unparseable $ \(cat, l) -> do
|
||||
tr_ $ do
|
||||
td_ cat
|
||||
td_ l
|
||||
h2_ "OK Links"
|
||||
table_ [class_ "sortable"] $ do
|
||||
thead_ $ tr_ $ do
|
||||
th_ [class_ "sorttable_nosort"] "Category"
|
||||
th_ [class_ "sorttable_nosort"] "Link"
|
||||
tbody_ $ do
|
||||
for_ ok $ \(cat, l) -> do
|
||||
tr_ $ do
|
||||
td_ cat
|
||||
td_ l
|
||||
where
|
||||
handleHttpException :: HttpException -> LinkStatus
|
||||
handleHttpException (HttpExceptionRequest _ x) = Broken $ show x
|
||||
handleHttpException (InvalidUrlException _ x) = Broken x
|
||||
|
||||
sortLinks :: [(a, b, LinkStatus)] -> ([(a, b)], [(a, b)], [(a, b, String)])
|
||||
sortLinks = foldr sortLink ([], [], [])
|
||||
|
||||
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))
|
||||
|
||||
allLinks :: [(Url, Text)]
|
||||
allLinks = ordNub (findLinks globalState)
|
||||
|
||||
-- | Find all links in content, along with a human-readable description of
|
||||
-- where each link is located.
|
||||
findLinks :: GlobalState -> [(Url, Text)]
|
||||
findLinks = concatMap findLinksCategory . view categories
|
||||
|
||||
-- | Find all links in a single category.
|
||||
findLinksCategory :: Category -> [(Url, Text)]
|
||||
findLinksCategory cat =
|
||||
[(url, cat^.title <> " (category notes)")
|
||||
| url <- findLinksMD (cat^.notes)] ++
|
||||
[(url, cat^.title <> " / " <> item^.name)
|
||||
| item <- cat^.items
|
||||
, url <- findLinksItem item]
|
||||
|
||||
-- | Find all links in a single item.
|
||||
findLinksItem :: Item -> [Url]
|
||||
findLinksItem item = findLinksMD item' ++ maybeToList (item^.link)
|
||||
where
|
||||
-- we don't want to find any links in deleted traits
|
||||
item' = item & prosDeleted .~ []
|
||||
& consDeleted .~ []
|
||||
|
||||
-- | Find all Markdown links in /any/ structure, using generics.
|
||||
findLinksMD :: Data a => a -> [Url]
|
||||
findLinksMD a = [url | MD.LINK url _ <- universeBi a]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -106,15 +106,18 @@ pageDef = Page {
|
||||
}
|
||||
|
||||
subtitleDef
|
||||
:: (MonadIO m, MonadReader Config m)
|
||||
:: MonadIO m
|
||||
=> Page m
|
||||
-> HtmlT m ()
|
||||
subtitleDef _page = do
|
||||
subtitleDef _page = pure ()
|
||||
{- previous version of the subtitle
|
||||
-----------------------------------
|
||||
div_ [class_ "subtitle"] $ do
|
||||
"alpha version • don't share yet"
|
||||
lift (asks _discussLink) >>= \case
|
||||
Nothing -> return ()
|
||||
Just l -> " • " >> mkLink "discuss the site" l
|
||||
-}
|
||||
|
||||
headTagDef
|
||||
:: (MonadIO m, MonadReader Config m)
|
||||
|
||||
@ -110,7 +110,7 @@ import Guide.Views.Utils.Input
|
||||
-- | Add a script that does something on page load.
|
||||
onPageLoad :: Monad m => JS -> HtmlT m ()
|
||||
onPageLoad js = script_ $
|
||||
"$(document).ready(function(){"#|js|#"});"
|
||||
"$(document).ready(function(){"+|js|+"});"
|
||||
|
||||
-- | Add some empty space.
|
||||
emptySpan :: Monad m => Text -> HtmlT m ()
|
||||
@ -120,18 +120,18 @@ emptySpan w = span_ [style_ ("margin-left:" <> w)] mempty
|
||||
onEnter :: JS -> Attribute
|
||||
onEnter handler = onkeydown_ $
|
||||
"if (event.keyCode == 13 || event.keyCode == 10) {"
|
||||
#|handler|#" return false;}\n"
|
||||
+|handler|+" return false;}\n"
|
||||
|
||||
onCtrlEnter :: JS -> Attribute
|
||||
onCtrlEnter handler = onkeydown_ $
|
||||
"if ((event.keyCode == 13 || event.keyCode == 10) && " <>
|
||||
"(event.metaKey || event.ctrlKey)) {"
|
||||
#|handler|#" return false;}\n"
|
||||
+|handler|+" return false;}\n"
|
||||
|
||||
onEscape :: JS -> Attribute
|
||||
onEscape handler = onkeydown_ $
|
||||
"if (event.keyCode == 27) {"
|
||||
#|handler|#" return false;}\n"
|
||||
+|handler|+" return false;}\n"
|
||||
|
||||
textInput :: Monad m => [Attribute] -> HtmlT m ()
|
||||
textInput attrs = input_ (type_ "text" : attrs)
|
||||
@ -192,7 +192,7 @@ markdownEditor
|
||||
-> HtmlT m ()
|
||||
markdownEditor attr (view mdText -> s) submit cancel instr = do
|
||||
textareaUid <- randomLongUid
|
||||
let val = JS $ "document.getElementById(\""#|textareaUid|#"\").value"
|
||||
let val = JS $ "document.getElementById(\""+|textareaUid|+"\").value"
|
||||
-- Autocomplete has to be turned off thanks to
|
||||
-- <http://stackoverflow.com/q/8311455>.
|
||||
textarea_ ([uid_ textareaUid,
|
||||
@ -224,7 +224,7 @@ smallMarkdownEditor
|
||||
-> HtmlT m ()
|
||||
smallMarkdownEditor attr (view mdText -> s) submit mbCancel instr = do
|
||||
textareaId <- randomLongUid
|
||||
let val = JS $ "document.getElementById(\""#|textareaId|#"\").value"
|
||||
let val = JS $ "document.getElementById(\""+|textareaId|+"\").value"
|
||||
textarea_ ([class_ "fullwidth", uid_ textareaId, autocomplete_ "off"] ++
|
||||
[onEnter (submit val)] ++
|
||||
[onEscape cancel | Just cancel <- [mbCancel]] ++
|
||||
@ -368,8 +368,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
|
||||
@ -387,7 +387,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
|
||||
@ -397,9 +397,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)
|
||||
@ -413,5 +413,3 @@ getCsrfHeader = do
|
||||
csrfTokenName <- spc_csrfHeaderName <$> getSpockCfg
|
||||
csrfTokenValue <- getCsrfToken
|
||||
return (csrfTokenName, csrfTokenValue)
|
||||
|
||||
|
||||
|
||||
@ -9,39 +9,83 @@ module Imports
|
||||
(
|
||||
module X,
|
||||
LByteString,
|
||||
(+|),
|
||||
(|+),
|
||||
(+||),
|
||||
(||+),
|
||||
(|++|),
|
||||
(||++||),
|
||||
(|++||),
|
||||
(||++|)
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import BasePrelude as X hiding (Category, GeneralCategory, lazy, (&))
|
||||
import BasePrelude as X hiding (Category, GeneralCategory, lazy, (&))
|
||||
-- Lists
|
||||
import Data.List.Index as X
|
||||
import Data.List.Extra as X (takeEnd, dropEnd)
|
||||
import Data.List.Extra as X (dropEnd, takeEnd)
|
||||
import Data.List.Index as X
|
||||
-- Lenses
|
||||
import Lens.Micro.Platform as X
|
||||
import Lens.Micro.Platform as X
|
||||
-- Monads and monad transformers
|
||||
import Control.Monad.IO.Class as X
|
||||
import Control.Monad.State as X
|
||||
import Control.Monad.Reader as X
|
||||
import Control.Monad.IO.Class as X
|
||||
import Control.Monad.Reader as X
|
||||
import Control.Monad.State as X
|
||||
-- Common types
|
||||
import Data.Text.All as X (Text, LText)
|
||||
import Data.ByteString as X (ByteString)
|
||||
import Data.Map as X (Map)
|
||||
import Data.Set as X (Set)
|
||||
import Data.ByteString as X (ByteString)
|
||||
import Data.Map as X (Map)
|
||||
import Data.Set as X (Set)
|
||||
import Data.Text.All as X (LText, Text)
|
||||
-- Time
|
||||
import Data.Time as X
|
||||
import Data.Time as X
|
||||
-- Files
|
||||
import System.Directory as X
|
||||
import System.FilePath as X
|
||||
import System.Directory as X
|
||||
import System.FilePath as X
|
||||
-- Deepseq
|
||||
import Control.DeepSeq as X
|
||||
import Control.DeepSeq as X
|
||||
-- Hashable
|
||||
import Data.Hashable as X
|
||||
import Data.Hashable as X
|
||||
-- Lazy bytestring
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
-- Formatting
|
||||
import Fmt as X
|
||||
import Fmt as X hiding (( #| ), ( #|| ), (|#), (|##|),
|
||||
(|##||), (||#), (||##|), (||##||))
|
||||
import qualified Fmt as FMT (( #| ), ( #|| ), (|#), (|##|), (|##||),
|
||||
(||#), (||##|), (||##||))
|
||||
import Fmt.Internal (FromBuilder)
|
||||
|
||||
|
||||
type LByteString = BSL.ByteString
|
||||
-- LText is already provided by Data.Text.All
|
||||
|
||||
infixr 1 +|
|
||||
(+|) :: FromBuilder b => Builder -> Builder -> b
|
||||
(+|) = (FMT.#|)
|
||||
|
||||
infixr 1 |+
|
||||
(|+) :: (Buildable a, FromBuilder b) => a -> Builder -> b
|
||||
(|+) = (FMT.|#)
|
||||
|
||||
infixr 1 +||
|
||||
(+||) :: FromBuilder b => Builder -> Builder -> b
|
||||
(+||) = (FMT.#||)
|
||||
|
||||
infixr 1 ||+
|
||||
(||+) :: (Show a, FromBuilder b) => a -> Builder -> b
|
||||
(||+) = (FMT.||#)
|
||||
|
||||
infixr 1 |++|
|
||||
(|++|) :: (Buildable a, FromBuilder b) => a -> Builder -> b
|
||||
(|++|) = (FMT.|##|)
|
||||
|
||||
infixr 1 ||++||
|
||||
(||++||) :: (Show a, FromBuilder b) => a -> Builder -> b
|
||||
(||++||) = (FMT.||##||)
|
||||
|
||||
infixr 1 ||++|
|
||||
(|++||) :: (Show a, FromBuilder b) => a -> Builder -> b
|
||||
(|++||) = (FMT.|##||)
|
||||
|
||||
infixr 1 |++||
|
||||
(||++|) :: (Buildable a, FromBuilder b) => a -> Builder -> b
|
||||
(||++|) = (FMT.||##|)
|
||||
|
||||
@ -23,6 +23,8 @@ CSS
|
||||
============================================================
|
||||
|
||||
#search {
|
||||
/* TODO: this should rather be in the "h1+subtitle" block */
|
||||
margin-top: 1em;
|
||||
font-size: 200%;
|
||||
font-weight: 200;
|
||||
border: 1px solid #aaa;
|
||||
|
||||
@ -54,12 +54,12 @@ mainPageTests = session "main page" $ using [chromeCaps] $ do
|
||||
("content", "some-google-token")
|
||||
wd "has a title" $ do
|
||||
"h1" `shouldHaveText` "Aelve Guide | Haskell"
|
||||
describe "subtitle" $ do
|
||||
wd "is present" $ do
|
||||
sub <- select ".subtitle"
|
||||
fs <- fontSize sub; fs `shouldBeInRange` (15,17)
|
||||
wd "has a discuss link" $ do
|
||||
checkPresent ".subtitle a[href='http://discuss.link']"
|
||||
-- describe "subtitle" $ do
|
||||
-- wd "is present" $ do
|
||||
-- sub <- select ".subtitle"
|
||||
-- fs <- fontSize sub; fs `shouldBeInRange` (15,17)
|
||||
-- wd "has a discuss link" $ do
|
||||
-- checkPresent ".subtitle a[href='http://discuss.link']"
|
||||
describe "footer" $ do
|
||||
wd "is present" $ do
|
||||
checkPresent "#footer"
|
||||
@ -90,8 +90,8 @@ categoryTests = session "categories" $ using [chromeCaps] $ do
|
||||
titleLink <- select "h1 > a"
|
||||
titleLink `shouldHaveText` "Aelve Guide | Haskell"
|
||||
titleLink `shouldLinkToRelative` "/haskell"
|
||||
wd "has a subtitle" $ do
|
||||
checkPresent ".subtitle"
|
||||
-- wd "has a subtitle" $ do
|
||||
-- checkPresent ".subtitle"
|
||||
wd "doesn't have an add-category field" $ do
|
||||
checkNotPresent ".add-category"
|
||||
wd "is present on the main page" $ do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user