aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-11-22 11:33:34 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into sessions

Browse Source
This commit is contained in:
Artyom 2017-05-23 21:30:53 +03:00
commit ffddc9b720
No known key found for this signature in database
GPG Key ID: B8E35A33FF522710
21 changed files with 506 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

@ -47,6 +47,8 @@ it means that there's an extensive comment somewhere else in the code, which you
### Main modules
THIS SECTION IS OUTDATED
There are 4 main modules – `Guide.hs`, `JS.hs`, `View.hs`, and `Types.hs`.
`Guide.hs` contains:

15
guide.cabal
View File

@ -45,7 +45,7 @@ executable guide
library
exposed-modules:
Guide.App
Guide.Server
Guide.Main
Guide.ServerStuff
Guide.Session
Guide.Config
@ -61,6 +61,7 @@ library
Guide.Utils
Guide.Merge
Guide.Markdown
Guide.Search
Guide.JS
Guide.Views
Guide.Views.Page
@ -79,7 +80,7 @@ library
, Spock-lucid == 0.3.*
, Spock-digestive
, acid-state == 0.14.*
, aeson == 0.11.*
, aeson == 1.0.*
, aeson-pretty
, base >=4.9 && <4.10
, base-prelude
@ -100,25 +101,26 @@ library
, feed >= 0.3.11 && < 0.4
, filemanip == 0.3.6.*
, filepath
, fmt == 0.0.0.4
, fmt == 0.2.*
, focus
, friendly-time == 0.4.*
, fsnotify == 0.2.*
, hashable
, haskell-src-meta
, http-api-data
, http-types
, hvect
, ilist
, iproute == 1.7.*
, lucid >= 2.9.5 && < 3
, megaparsec == 5.0.*
, megaparsec == 5.*
, microlens-platform >= 0.3.2
, mmorph == 1.*
, mtl >= 2.1.1
, neat-interpolation == 0.3.*
, network
, network-uri
, patches-vector
, path-pieces
, random >= 1.1
, reroute
, safecopy
@ -136,6 +138,7 @@ library
, transformers
, uniplate
, unix
, utf8-string
, vector
, wai
, wai-middleware-metrics
@ -166,7 +169,7 @@ test-suite tests
MergeSpec
Selenium
type: exitcode-stdio-1.0
build-depends: QuickCheck < 2.9
build-depends: QuickCheck < 2.10
, base < 5
, base-prelude
, cmark

23
src/Guide/Config.hs
View File

@ -28,14 +28,23 @@ import Data.Default
import Guide.Utils
-- | Site config. Stored in @config.json@.
data Config = Config {
_baseUrl :: Url,
_googleToken :: Text,
_adminPassword :: Text,
_prerender :: Bool,
_discussLink :: Maybe Url }
_baseUrl :: Url, -- ^ URL where the site is deployed. Used
-- for generating feeds (which require
-- absolute URLs)
_googleToken :: Text, -- ^ Google site verification token. Will
-- be inserted into all pages
_adminPassword :: Text, -- ^ Password for the admin user
_prerender :: Bool, -- ^ Whether to prerender all pages when
-- the app is started
_discussLink :: Maybe Url -- ^ Link to a place to discuss the site.
-- Will be placed in the header
}
deriving (Eq, Show)
-- | Default instance: no base URL, no Google token, empty password, no
-- prerendering, no discussion link.
instance Default Config where
def = Config {
_baseUrl = "/",
@ -61,6 +70,8 @@ instance ToJSON Config where
"prerender" .= _prerender,
"discuss-link" .= _discussLink ]
-- | Read config from @config.json@ (creating a default config if the file
-- doesn't exist).
readConfig :: IO Config
readConfig = do
let filename = "config.json"
@ -78,6 +89,7 @@ readConfig = do
writeConfig cfg
return cfg
-- | Write a config to @config.json@.
writeConfig :: Config -> IO ()
writeConfig cfg = do
-- Create-and-rename is safer than just rewriting the file
@ -85,5 +97,6 @@ writeConfig cfg = do
BSL.writeFile newFile (Aeson.encodePretty cfg)
renameFile newFile "config.json"
-- | Apply a function to the config.
modifyConfig :: (Config -> IO Config) -> IO ()
modifyConfig func = writeConfig =<< func =<< readConfig

2
src/Guide/Handlers.hs
View File

@ -431,7 +431,7 @@ itemToFeedEntry baseUrl category item = do
Atom.entryContent = Just (Atom.HTMLContent (TL.unpack entryContent)) }
where
entryLink = baseUrl //
format "{}#item-{}" (categorySlug category, item^.uid)
format "{}#item-{}" (categorySlug category) (item^.uid)
entryBase = Atom.nullEntry
(T.unpack (uidToText (item^.uid)))
(Atom.TextString (T.unpack (item^.name)))

20
src/Guide/JS.hs
View File

@ -122,8 +122,8 @@ class JSFunction a where
instance JSFunction JS where
makeJSFunction fName fParams fDef =
let paramList = T.intercalate "," fParams
in JS $ "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
@ -131,12 +131,12 @@ instance JSFunction JS where
instance JSParams a => JSFunction (a -> JS) where
makeJSFunction fName _fParams _fDef = \args ->
let paramList = T.intercalate "," (map fromJS (jsParams args))
in JS $ ""%<fName>%"("%<paramList>%");"
in JS $ format "{}({});" fName paramList
-- This isn't a standalone function and so it doesn't have to be listed in
-- 'allJSFunctions'.
assign :: ToJS x => JS -> x -> JS
assign v x = JS $ format "{} = {};" (v, toJS x)
assign v x = JS $ format "{} = {};" v (toJS x)
-- TODO: all links here shouldn't be absolute [absolute-links]
@ -710,20 +710,20 @@ newtype JQuerySelector = JQuerySelector Text
deriving (ToJS, T.Buildable)
selectId :: Text -> JQuerySelector
selectId x = JQuerySelector $ format "#{}" [x]
selectId x = JQuerySelector $ format "#{}" x
selectUid :: Uid Node -> JQuerySelector
selectUid x = JQuerySelector $ format "#{}" [x]
selectUid x = JQuerySelector $ format "#{}" x
selectClass :: Text -> JQuerySelector
selectClass x = JQuerySelector $ format ".{}" [x]
selectClass x = JQuerySelector $ format ".{}" x
selectParent :: JQuerySelector -> JQuerySelector
selectParent x = JQuerySelector $ format ":has(> {})" [x]
selectParent x = JQuerySelector $ format ":has(> {})" x
selectChildren :: JQuerySelector -> JQuerySelector -> JQuerySelector
selectChildren a b = JQuerySelector $ format "{} > {}" (a, b)
selectChildren a b = JQuerySelector $ format "{} > {}" a b
selectSection :: JQuerySelector -> Text -> JQuerySelector
selectSection a b = JQuerySelector $ format "{} > .section.{}" (a, b)
selectSection a b = JQuerySelector $ format "{} > .section.{}" a b

2
src/Guide/Server.hs → src/Guide/Main.hs
View File

@ -12,7 +12,7 @@ The main module.
* Run 'main' to actually start the server.
* Run 'mainWith' to run it with a custom config.
-}
module Guide.Server
module Guide.Main
(
main,
mainWith,

52
src/Guide/Markdown.hs
View File

@ -13,7 +13,7 @@ module Guide.Markdown
-- * Types
MarkdownInline(..),
MarkdownBlock(..),
MarkdownBlockWithTOC(..),
MarkdownTree(..),
-- * Lenses
mdHtml,
@ -26,11 +26,12 @@ module Guide.Markdown
-- * Converting text to Markdown
toMarkdownInline,
toMarkdownBlock,
toMarkdownBlockWithTOC,
toMarkdownTree,
-- * Misc
renderMD,
markdownNull,
extractPreface,
)
where
@ -76,15 +77,15 @@ data MarkdownBlock = MarkdownBlock {
markdownBlockMdHtml :: ByteString,
markdownBlockMdMarkdown :: ![MD.Node] }
data MarkdownBlockWithTOC = MarkdownBlockWithTOC {
markdownBlockWithTOCMdText :: Text,
markdownBlockWithTOCMdTree :: !(Document Text ByteString),
markdownBlockWithTOCMdIdPrefix :: Text,
markdownBlockWithTOCMdTOC :: Forest ([MD.Node], Text) }
data MarkdownTree = MarkdownTree {
markdownTreeMdText :: Text,
markdownTreeMdTree :: !(Document Text ByteString),
markdownTreeMdIdPrefix :: Text,
markdownTreeMdTOC :: Forest ([MD.Node], Text) }
makeFields ''MarkdownInline
makeFields ''MarkdownBlock
makeFields ''MarkdownBlockWithTOC
makeFields ''MarkdownTree
parseMD :: Text -> [MD.Node]
parseMD s =
@ -139,6 +140,19 @@ stringify = T.concat . map go
HTML_BLOCK _ -> ""
HTML_INLINE _ -> ""
-- | Extract everything before the first heading.
--
-- Note that if you render 'mdText' of the produced Markdown block, it won't
-- necessarily parse into 'mdHtml' from the same block. It's because rendered
-- Markdown might depend on links that are defined further in the tree.
extractPreface :: MarkdownTree -> MarkdownBlock
extractPreface = mkBlock . preface . view mdTree
where
mkBlock x = MarkdownBlock {
markdownBlockMdText = annSource x,
markdownBlockMdHtml = renderMD (annValue x),
markdownBlockMdMarkdown = annValue x }
-- | Flatten Markdown by concatenating all block elements.
extractInlines :: [MD.Node] -> [MD.Node]
extractInlines = concatMap go
@ -236,12 +250,12 @@ toMarkdownBlock s = MarkdownBlock {
doc = parseMD s
html = renderMD doc
toMarkdownBlockWithTOC :: Text -> Text -> MarkdownBlockWithTOC
toMarkdownBlockWithTOC idPrefix s = MarkdownBlockWithTOC {
markdownBlockWithTOCMdText = s,
markdownBlockWithTOCMdIdPrefix = idPrefix,
markdownBlockWithTOCMdTree = tree,
markdownBlockWithTOCMdTOC = toc }
toMarkdownTree :: Text -> Text -> MarkdownTree
toMarkdownTree idPrefix s = MarkdownTree {
markdownTreeMdText = s,
markdownTreeMdIdPrefix = idPrefix,
markdownTreeMdTree = tree,
markdownTreeMdTOC = toc }
where
blocks :: [MD.Node]
blocks = parseMD s
@ -281,7 +295,7 @@ instance Show MarkdownInline where
show = show . view mdText
instance Show MarkdownBlock where
show = show . view mdText
instance Show MarkdownBlockWithTOC where
instance Show MarkdownTree where
show = show . view mdText
instance A.ToJSON MarkdownInline where
@ -292,7 +306,7 @@ instance A.ToJSON MarkdownBlock where
toJSON md = A.object [
"text" A..= (md^.mdText),
"html" A..= T.decodeUtf8 (md^.mdHtml) ]
instance A.ToJSON MarkdownBlockWithTOC where
instance A.ToJSON MarkdownTree where
toJSON md = A.object [
"text" A..= (md^.mdText) ]
@ -302,7 +316,7 @@ instance ToHtml MarkdownInline where
instance ToHtml MarkdownBlock where
toHtmlRaw = toHtml
toHtml = toHtmlRaw . view mdHtml
instance ToHtml MarkdownBlockWithTOC where
instance ToHtml MarkdownTree where
toHtmlRaw = toHtml
toHtml = toHtmlRaw . renderDoc . view mdTree
where
@ -330,14 +344,14 @@ instance SafeCopy MarkdownBlock where
kind = base
putCopy = contain . safePut . view mdText
getCopy = contain $ toMarkdownBlock <$> safeGet
instance SafeCopy MarkdownBlockWithTOC where
instance SafeCopy MarkdownTree where
version = 0
kind = base
putCopy md = contain $ do
safePut (md ^. mdIdPrefix)
safePut (md ^. mdText)
getCopy = contain $
toMarkdownBlockWithTOC <$> safeGet <*> safeGet
toMarkdownTree <$> safeGet <*> safeGet
-- | Is a piece of Markdown empty?
markdownNull :: HasMdText a Text => a -> Bool

78
src/Guide/Search.hs Normal file
View File

@ -0,0 +1,78 @@
-- | The code that powers the searchbox.
module Guide.Search
(
SearchResult(..),
search,
)
where
import Imports
-- Text
import qualified Data.Text.All as T
-- Sets
import qualified Data.Set as S
import Guide.Types
import Guide.State
import Guide.Markdown
-- | A search result.
data SearchResult
-- | Category's title matches the query
= SRCategory Category
-- | Item's name matches the query
| SRItem Category Item
-- | Item's ecosystem matches the query
| SRItemEcosystem Category Item
deriving (Show, Generic)
{- | Find things matching a simple text query, and return results ranked by
importance. Categories are considered more important than items.
Currently 'search' doesn't do any fuzzy search whatsoever – only direct word
matches are considered. See 'match' for the description of the matching
algorithm.
-}
search :: Text -> GlobalState -> [SearchResult]
search query gs =
-- category titles
sortByRank [(SRCategory cat, rank)
| cat <- gs^.categories
, let rank = match query (cat^.title)
, rank > 0 ] ++
-- item names
sortByRank [(SRItem cat item, rank)
| cat <- gs^.categories
, item <- cat^.items
, let rank = match query (item^.name)
, rank > 0 ] ++
-- item ecosystems
sortByRank [(SRItemEcosystem cat item, rank)
| cat <- gs^.categories
, item <- cat^.items
, let rank = match query (item^.ecosystem.mdText)
, rank > 0 ]
where
sortByRank :: [(a, Int)] -> [a]
sortByRank = map fst . sortOn (Down . snd)
{- | How many words in two strings match?
Words are defined as sequences of letters, digits and characters like “-”;
separators are everything else. Comparisons are case-insensitive.
-}
match :: Text -> Text -> Int
match a b = common (getWords a) (getWords b)
where
isWordPart c = isLetter c || isDigit c || c == '-'
getWords =
map T.toTitle .
filter (not . T.null) .
T.split (not . isWordPart)
-- | Find how many elements two lists have in common.
common :: Ord a => [a] -> [a] -> Int
common a b = S.size (S.intersection (S.fromList a) (S.fromList b))

22
src/Guide/ServerStuff.hs
View File

@ -56,10 +56,13 @@ import Guide.Utils
import Guide.Markdown
-- | Global state of the site.
data ServerState = ServerState {
_config :: Config,
_db :: DB }
_config :: Config, -- ^ Config (doesn't change in runtime)
_db :: DB -- ^ DB connection
}
-- | Get config in a Spock monad.
getConfig :: (Monad m, HasSpock m, SpockState m ~ ServerState)
=> m Config
getConfig = _config <$> Spock.getState
@ -70,6 +73,9 @@ type DB = AcidState GlobalState
-- | Update something in the database. Don't forget to 'invalidateCache' or
-- use 'uncache' when you update something that is cached.
--
-- Example: @dbUpdate (DeleteCategory catId)@
--
dbUpdate :: (MonadIO m, HasSpock m, SpockState m ~ ServerState,
EventState event ~ GlobalState, UpdateEvent event)
=> event -> m (EventResult event)
@ -80,6 +86,9 @@ dbUpdate x = do
Acid.update db x
-- | Read something from the database.
--
-- Example: @dbQuery (GetCategory catId)@.
--
dbQuery :: (MonadIO m, HasSpock m, SpockState m ~ ServerState,
EventState event ~ GlobalState, QueryEvent event)
=> event -> m (EventResult event)
@ -150,8 +159,8 @@ addEdit ed = do
--
-- TODO: make this do cache invalidation.
--
-- TODO: many of these don't work when the changed category/item/etc has been
-- deleted; this should change.
-- TODO: many of these don't work when the changed category, item, etc has
-- been deleted; this should change.
undoEdit :: (MonadIO m, HasSpock m, SpockState m ~ ServerState)
=> Edit -> m (Either String ())
undoEdit (Edit'AddCategory catId _) = do
@ -238,6 +247,8 @@ undoEdit (Edit'MoveItem itemId direction) = do
undoEdit (Edit'MoveTrait itemId traitId direction) = do
Right () <$ dbUpdate (MoveTrait itemId traitId (not direction))
-- | Given an edit, invalidate cache items that should be invalidated when
-- that edit is undone.
invalidateCacheForEdit
:: (MonadIO m, HasSpock m, SpockState m ~ ServerState)
=> Edit -> m ()
@ -297,12 +308,15 @@ invalidateCacheForEdit ed = do
-- Handler helpers
----------------------------------------------------------------------------
-- | A path piece for items
itemVar :: Path '[Uid Item] 'Open
itemVar = "item" <//> var
-- | A path piece for categories
categoryVar :: Path '[Uid Category] 'Open
categoryVar = "category" <//> var
-- | A path pieces for traits
traitVar :: Path '[Uid Trait] 'Open
traitVar = "trait" <//> var

12
src/Guide/State.hs
View File

@ -307,7 +307,7 @@ addItem catId itemId name' created' kind' = do
_itemConsDeleted = [],
_itemEcosystem = toMarkdownBlock "",
_itemNotes = let pref = "item-notes-" <> uidToText itemId <> "-"
in toMarkdownBlockWithTOC pref "",
in toMarkdownTree pref "",
_itemLink = Nothing,
_itemKind = kind' }
categoryById catId . items %= (++ [newItem])
@ -444,7 +444,7 @@ setItemNotes :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
setItemNotes itemId notes' = do
let pref = "item-notes-" <> uidToText itemId <> "-"
oldNotes <- itemById itemId . notes <<.=
toMarkdownBlockWithTOC pref notes'
toMarkdownTree pref notes'
let edit = Edit'SetItemNotes itemId (oldNotes ^. mdText) notes'
(edit,) <$> use (itemById itemId)
@ -575,7 +575,7 @@ restoreCategory catId pos = do
Nothing -> return (Left "category not found in deleted categories")
Just category -> do
categoriesDeleted %= deleteFirst (hasUid catId)
categories %= insertAtGuaranteed pos category
categories %= insertOrAppend pos category
return (Right ())
restoreItem :: Uid Item -> Int -> Acid.Update GlobalState (Either String ())
@ -588,7 +588,7 @@ restoreItem itemId pos = do
let item = fromJust (find (hasUid itemId) (category^.itemsDeleted))
let category' = category
& itemsDeleted %~ deleteFirst (hasUid itemId)
& items %~ insertAtGuaranteed pos item
& items %~ insertOrAppend pos item
categories . each . filtered ourCategory .= category'
categoriesDeleted . each . filtered ourCategory .= category'
return (Right ())
@ -609,7 +609,7 @@ restoreTrait itemId traitId pos = do
(Just trait, _) -> do
let item' = item
& prosDeleted %~ deleteFirst (hasUid traitId)
& pros %~ insertAtGuaranteed pos trait
& pros %~ insertOrAppend pos trait
let category' = category
& items . each . filtered (hasUid itemId) .~ item'
& itemsDeleted . each . filtered (hasUid itemId) .~ item'
@ -619,7 +619,7 @@ restoreTrait itemId traitId pos = do
(_, Just trait) -> do
let item' = item
& consDeleted %~ deleteFirst (hasUid traitId)
& cons %~ insertAtGuaranteed pos trait
& cons %~ insertOrAppend pos trait
let category' = category
& items . each . filtered (hasUid itemId) .~ item'
& itemsDeleted . each . filtered (hasUid itemId) .~ item'

82
src/Guide/Types/Core.hs
View File

@ -90,6 +90,7 @@ For an explanation of deriveSafeCopySorted, see Note [acid-state].
-- Trait
----------------------------------------------------------------------------
-- | A trait (pro or con). Traits are stored in items.
data Trait = Trait {
_traitUid :: Uid Trait,
_traitContent :: MarkdownInline }
@ -109,6 +110,7 @@ instance A.ToJSON Trait where
-- Item
----------------------------------------------------------------------------
-- | Kind of an item (items can be libraries, tools, etc).
data ItemKind
= Library {_itemKindHackageName :: Maybe Text}
| Tool {_itemKindHackageName :: Maybe Text}
@ -154,20 +156,23 @@ instance A.ToJSON ItemSection where
-- TODO: add a field like “people to ask on IRC about this library if you
-- need help”
-- | An item (usually a library). Items are stored in categories.
data Item = Item {
_itemUid :: Uid Item,
_itemName :: Text,
_itemCreated :: UTCTime,
_itemGroup_ :: Maybe Text,
_itemDescription :: MarkdownBlock,
_itemPros :: [Trait],
_itemProsDeleted :: [Trait],
_itemCons :: [Trait],
_itemConsDeleted :: [Trait],
_itemEcosystem :: MarkdownBlock,
_itemNotes :: MarkdownBlockWithTOC,
_itemLink :: Maybe Url,
_itemKind :: ItemKind }
_itemUid :: Uid Item, -- ^ Item ID
_itemName :: Text, -- ^ Item title
_itemCreated :: UTCTime, -- ^ When the item was created
_itemGroup_ :: Maybe Text, -- ^ Item group (affects item's color)
_itemDescription :: MarkdownBlock, -- ^ Item summary
_itemPros :: [Trait], -- ^ Pros (positive traits)
_itemProsDeleted :: [Trait], -- ^ Deleted pros go here (so that
-- it'd be easy to restore them)
_itemCons :: [Trait], -- ^ Cons (negative traits)
_itemConsDeleted :: [Trait], -- ^ Deleted cons go here
_itemEcosystem :: MarkdownBlock, -- ^ The ecosystem section
_itemNotes :: MarkdownTree, -- ^ The notes section
_itemLink :: Maybe Url, -- ^ Link to homepage or something
_itemKind :: ItemKind -- ^ Is it a library, tool, etc
}
deriving (Show, Generic)
deriveSafeCopySorted 11 'extension ''Item
@ -184,10 +189,11 @@ instance A.ToJSON Item where
-- Category
----------------------------------------------------------------------------
-- | Category status
data CategoryStatus
= CategoryStub
| CategoryWIP
| CategoryFinished
= CategoryStub -- ^ “Stub” = just created
| CategoryWIP -- ^ “WIP” = work in progress
| CategoryFinished -- ^ “Finished” = complete or nearly complete
deriving (Eq, Show, Generic)
deriveSafeCopySimple 2 'extension ''CategoryStatus
@ -210,27 +216,29 @@ instance Migrate CategoryStatus where
migrate CategoryMostlyDone_v1 = CategoryFinished
migrate CategoryFinished_v1 = CategoryFinished
-- | A category
data Category = Category {
_categoryUid :: Uid Category,
_categoryTitle :: Text,
-- | The “grandcategory” of the category (“meta”, “basics”, “specialised
-- needs”, etc)
_categoryGroup_ :: Text,
-- | Enabled sections in this category. For instance, if this set contains
-- 'ItemNotesSection', then notes will be shown for each item.
_categoryUid :: Uid Category,
_categoryTitle :: Text,
-- | When the category was created
_categoryCreated :: UTCTime,
-- | The “grandcategory” of the category (“meta”, “basics”, etc)
_categoryGroup_ :: Text,
_categoryStatus :: CategoryStatus,
_categoryNotes :: MarkdownBlock,
-- | Items stored in the category
_categoryItems :: [Item],
-- | Items that were deleted from the category. We keep them here to make
-- it easier to restore them
_categoryItemsDeleted :: [Item],
-- | Enabled sections in this category. E.g, if this set contains
-- 'ItemNotesSection', then notes will be shown for each item
_categoryEnabledSections :: Set ItemSection,
_categoryCreated :: UTCTime,
_categoryStatus :: CategoryStatus,
_categoryNotes :: MarkdownBlock,
-- | All groups of items belonging to the category, as well as their
-- colors. We could assign colors to items when we render the category
-- (something like “if haven't seen this group yet, assign a new color to
-- it and render it with this color”, but this way is easier and also
-- allows us to keep the colors of all other groups the same when one item
-- has been deleted.
_categoryGroups :: Map Text Hue,
_categoryItems :: [Item],
_categoryItemsDeleted :: [Item] }
-- colors. Storing colors explicitly lets us keep colors consistent when
-- all items in a group are deleted
_categoryGroups :: Map Text Hue
}
deriving (Show, Generic)
deriveSafeCopySorted 11 'extension ''Category
@ -258,13 +266,17 @@ instance A.ToJSON Category where
toJSON = A.genericToJSON A.defaultOptions {
A.fieldLabelModifier = over _head toLower . drop (T.length "_category") }
-- | Category identifier (used in URLs). E.g. for a category with title
-- “Performance optimization” and UID “t3c9hwzo” the slug would be
-- @performance-optimization-t3c9hwzo@.
categorySlug :: Category -> Text
categorySlug category =
format "{}-{}" (makeSlug (category^.title), category^.uid)
format "{}-{}" (makeSlug (category^.title)) (category^.uid)
----------------------------------------------------------------------------
-- Utils
----------------------------------------------------------------------------
-- | A useful predicate; @hasUid x@ compares given object's UID with @x@.
hasUid :: HasUid a (Uid u) => Uid u -> a -> Bool
hasUid u x = x^.uid == u

139
src/Guide/Utils.hs
View File

@ -19,7 +19,7 @@ module Guide.Utils
moveUp,
moveDown,
deleteFirst,
insertAtGuaranteed,
insertOrAppend,
ordNub,
-- * 'Eq'
@ -96,7 +96,7 @@ import Data.IP
import Lucid hiding (for_)
import Web.Spock as Spock
import Text.HTML.SanitizeXSS (sanitaryURI)
import Web.PathPieces
import Web.HttpApiData
import qualified Network.Wai as Wai
-- Feeds
import qualified Text.Atom.Feed as Atom
@ -110,6 +110,9 @@ import qualified Language.Haskell.TH.Syntax as TH (lift)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.Meta (parseExp)
import Data.Generics.Uniplate.Data (transform)
-- needed for 'sanitiseUrl'
import qualified Codec.Binary.UTF8.String as UTF8
import qualified Network.URI as URI
----------------------------------------------------------------------------
@ -126,15 +129,24 @@ moveDown :: (a -> Bool) -> [a] -> [a]
moveDown p (x:y:xs) = if p x then y : x : xs else x : moveDown p (y:xs)
moveDown _ xs = xs
-- | Delete the first element that satisfies the predicate (if such an
-- element is present).
deleteFirst :: (a -> Bool) -> [a] -> [a]
deleteFirst _ [] = []
deleteFirst f (x:xs) = if f x then xs else x : deleteFirst f xs
insertAtGuaranteed :: Int -> a -> [a] -> [a]
insertAtGuaranteed _ a [] = [a]
insertAtGuaranteed 0 a xs = a:xs
insertAtGuaranteed n a (x:xs) = x : insertAtGuaranteed (n-1) a xs
-- | Insert given element into the list, or append it to the list if the
-- position is outside the list bounds.
insertOrAppend
:: Int -- ^ Preferred position
-> a -- ^ Element to insert
-> [a]
-> [a]
insertOrAppend _ a [] = [a]
insertOrAppend 0 a xs = a:xs
insertOrAppend n a (x:xs) = x : insertOrAppend (n-1) a xs
-- | A version of 'works in @O(n log n)@ instead of @O(n^2)@.
ordNub :: Ord a => [a] -> [a]
ordNub = go mempty
where
@ -146,6 +158,9 @@ ordNub = go mempty
-- Eq
----------------------------------------------------------------------------
-- | Like 'comparing', but for 'Eq' for 'Eq' comparison instead of 'Ord'. Can
-- be used with e.g. 'grourison instead of 'Ord'. Can be usedpBy'. with e.g.
-- 'groupBy'.
equating :: Eq b => (a -> b) -> (a -> a -> Bool)
equating f = (==) `on` f
@ -153,17 +168,28 @@ equating f = (==) `on` f
-- Urls
----------------------------------------------------------------------------
-- | A type for URLs.
type Url = Text
-- | Return 'Nothing' if the URL is unsafe (e.g. a @javascript:@ or @data:@
-- URL). Otherwise return the original URL, possibly adding @http://@ to it
-- if it doesn't have a scheme.
sanitiseUrl :: Url -> Maybe Url
sanitiseUrl u
| not (sanitaryURI u) = Nothing
| "http:" `T.isPrefixOf` u = Just u
| "https:" `T.isPrefixOf` u = Just u
| otherwise = Just ("http://" <> u)
| not (sanitaryURI u) = Nothing
| otherwise =
Just $ case URI.uriScheme <$> parse (T.toString u) of
Nothing -> "http://" <> u
Just "" -> "http://" <> u
_ -> u
where
-- code taken from implementation of 'sanitaryURI'
parse = URI.parseURIReference . escape
escape = URI.escapeURIString URI.isAllowedInURI .
UTF8.encodeString
-- | Make text suitable for inclusion into an URL (by turning spaces into
-- hyphens and so on)
-- hyphens and so on).
makeSlug :: Text -> Text
makeSlug =
T.intercalate "-" . T.words .
@ -208,7 +234,9 @@ sockAddrToIP _ = Nothing
-- | Unique id, used for many things – categories, items, and anchor ids.
newtype Uid a = Uid {uidToText :: Text}
deriving (Eq, Ord, Show, PathPiece, T.Buildable, Hashable, A.ToJSON)
deriving (Eq, Ord, Show,
ToHttpApiData, FromHttpApiData,
T.Buildable, Hashable, A.ToJSON)
-- This instance is written manually because otherwise it produces a warning:
-- • Redundant constraint: SafeCopy a
@ -222,11 +250,12 @@ instance SafeCopy (Uid a) where
instance IsString (Uid a) where
fromString = Uid . T.pack
-- | Generate a random text of given length from characters @a-z@ and digits.
randomText :: MonadIO m => Int -> m Text
randomText n = liftIO $ do
-- We don't want the 1st char to be a digit. Just in case (I don't really
-- have a good reason). Maybe to prevent Javascript from doing automatic
-- conversions or something (tho it should never happen).
-- conversions or something (though it should never happen).
x <- randomRIO ('a', 'z')
let randomChar = do
i <- randomRIO (0, 35)
@ -235,17 +264,36 @@ randomText n = liftIO $ do
xs <- replicateM (n-1) randomChar
return (T.pack (x:xs))
-- For probability tables, see
-- https://en.wikipedia.org/wiki/Birthday_problem#Probability_table
-- | Generate a random UID of length 12.
--
-- Probability of collision for
--
-- * a million UIDs: approximately 1e-6
-- * a billion UIDs: approximately 0.25
--
randomLongUid :: MonadIO m => m (Uid a)
randomLongUid = Uid <$> randomText 12
-- These are only used for items and categories (because their uids can occur
-- in links and so they should look a bit nicer).
-- | Generate a random UID of length 8.
--
-- These UIDs are only used for items and categories (because their uids can
-- occur in links and so they should look a bit nicer).
--
-- Probability of collision for
--
-- * a hundred thousand UIDs: approximately 0.5%
-- * a million UIDs: approximately 40%
--
randomShortUid :: MonadIO m => m (Uid a)
randomShortUid = Uid <$> randomText 8
-- | A marker for Uids that would be used with HTML nodes
data Node
-- | Generate a HTML @id@ attribute from an 'Uid'.
uid_ :: Uid Node -> Attribute
uid_ = id_ . uidToText
@ -253,9 +301,11 @@ uid_ = id_ . uidToText
-- Lucid
----------------------------------------------------------------------------
-- | Include Javascript into page by creating a @<script>@ tag.
includeJS :: Monad m => Url -> HtmlT m ()
includeJS url = with (script_ "") [src_ url]
-- | Include CSS into page.
includeCSS :: Monad m => Url -> HtmlT m ()
includeCSS url = link_ [rel_ "stylesheet", type_ "text/css", href_ url]
@ -263,11 +313,15 @@ includeCSS url = link_ [rel_ "stylesheet", type_ "text/css", href_ url]
-- Spock
----------------------------------------------------------------------------
-- | Serve an Atom feed.
atomFeed :: MonadIO m => Atom.Feed -> ActionCtxT ctx m ()
atomFeed feed = do
setHeader "Content-Type" "application/atom+xml; charset=utf-8"
bytes $ T.encodeUtf8 (T.pack (XML.ppElement (Atom.xmlFeed feed)))
-- | Get details of the request:
--
-- @(time, IP, referrer, user-agent)@
getRequestDetails
:: (MonadIO m, HasSpock (ActionCtxT ctx m))
=> ActionCtxT ctx m (UTCTime, Maybe IP, Maybe Text, Maybe Text)
@ -301,6 +355,10 @@ getRequestDetails = do
-- Template Haskell
----------------------------------------------------------------------------
-- | Parse a Haskell expression with haskell-src-meta. The difference between
-- @[|exp|]@ and @[hs|exp|]@ is the the former requires all variables in
-- @exp@ to be present in scope at the moment of generation, but the latter
-- doesn't. This makes 'hs' useful for 'changelog'.
hs :: QuasiQuoter
hs = QuasiQuoter {
quoteExp = either fail TH.lift . parseExp,
@ -308,12 +366,19 @@ hs = QuasiQuoter {
quoteType = fail "hs: can't parse types",
quoteDec = fail "hs: can't parse declarations" }
-- | Print splices generated by a TH splice (the printing will happen during
-- compilation, as a GHC warning). Useful for debugging.
--
-- For instance, you can dump splices generated with 'makeLenses' by
-- replacing a top-level invocation of 'makeLenses' in your code with:
--
-- @dumpSplices $ makeLenses ''Foo@
--
dumpSplices :: DecsQ -> DecsQ
dumpSplices x = do
ds <- x
-- “reportWarning (pprint ds)” doesn't work in Emacs because of
-- haskell-mode's parsing of compiler messages
mapM_ (reportWarning . pprint) ds
let code = lines (pprint ds)
reportWarning ("\n" ++ unlines (map (" " ++) code))
return ds
bangNotStrict :: Q Bang
@ -337,6 +402,7 @@ data Change
-- the final version of the record is)
| Added String Exp
-- | An ADT for versions. Only used in invocations of 'changelog'.
data TypeVersion = Current Int | Past Int
deriving (Show)
@ -539,9 +605,22 @@ changelog bareTyName (newVer, Past oldVer) changes = do
-- Return everything
sequence [oldTypeDecl, migrateInstanceDecl]
data GenConstructor = Copy Name | Custom String [(String, Q Type)]
-- | A type for specifying what constructors existed in an old version of a
-- sum datatype.
data GenConstructor
= Copy Name -- ^ Just reuse the constructor
-- existing now.
| Custom String [(String, Q Type)] -- ^ The previous version had a
-- constructor with such-and-such
-- name and such-and-such fields.
genVer :: Name -> Int -> [GenConstructor] -> Q [Dec]
-- | Generate an old version of a sum type (used for 'SafeCopy').
genVer
:: Name -- ^ Name of type to generate old version for
-> Int -- ^ Version to generate
-> [GenConstructor] -- ^ List of constructors in the version we're
-- generating
-> Q [Dec]
genVer tyName ver constructors = do
-- Get information about the new version of the datatype
TyConI (DataD _cxt _name _vars _kind cons _deriving) <- reify tyName
@ -590,9 +669,24 @@ genVer tyName ver constructors = do
(cxt [])
return [decl]
data MigrateConstructor = CopyM Name | CustomM String ExpQ
-- | A type for migrating constructors from an old version of a sum datatype.
data MigrateConstructor
= CopyM Name -- ^ Copy constructor without changes
| CustomM String ExpQ -- ^ The old constructor with such-and-such name
-- should be turned into a value of the new type
-- (i.e. type of current version) using
-- such-and-such code.
migrateVer :: Name -> Int -> [MigrateConstructor] -> Q Exp
-- | Generate 'SafeCopy' migration code for a sum datatype.
--
-- See @instance Migrate Edit@ for an example.
migrateVer
:: Name -- ^ Type we're migrating to
-> Int -- ^ Version we're migrating from
-> [MigrateConstructor] -- ^ For each constructor existing in the (old
-- version of) type, a specification of how to
-- migrate it.
-> Q Exp
migrateVer tyName ver constructors = do
-- Get information about the new version of the datatype
TyConI (DataD _cxt _name _vars _kind cons _deriving) <- reify tyName
@ -636,6 +730,7 @@ migrateVer tyName ver constructors = do
-- STM
----------------------------------------------------------------------------
-- | Lift an 'STM' action to any IO-supporting monad.
liftSTM :: MonadIO m => STM a -> m a
liftSTM = liftIO . atomically

56
src/Guide/Views.hs
View File

@ -50,6 +50,7 @@ import qualified Data.Aeson as A
import Guide.Config
import Guide.State
import Guide.Types
import Guide.Search
import Guide.Utils
import Guide.JS (JS(..))
import qualified Guide.JS as JS
@ -313,7 +314,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
@ -529,18 +530,7 @@ renderHaskellRoot globalState mbSearchQuery =
onEnter $ JS.addCategoryAndRedirect [inputValue] ]
case mbSearchQuery of
Nothing -> renderCategoryList (globalState^.categories)
Just query' -> do
let queryWords = T.words query'
let rank :: Category -> Int
rank cat = sum [
length (queryWords `intersect` (cat^..items.each.name)),
length (queryWords `intersect` T.words (cat^.title)) ]
let rankedCategories
| null queryWords = globalState^.categories
| otherwise = filter ((/= 0) . rank) .
reverse . sortOn rank
$ globalState^.categories
renderSearchResults rankedCategories
Just query' -> renderSearchResults (search query' globalState)
-- TODO: maybe add a button like “give me random category that is
-- unfinished”
@ -700,13 +690,39 @@ renderCategoryList allCats = cached CacheCategoryList $ do
a_ [class_ "category-link", href_ (categoryLink category)] $
toHtml (category^.title)
-- | Render a page with search results (just a list of categories).
renderSearchResults :: Monad m => [Category] -> HtmlT m ()
renderSearchResults cats = do
div_ [id_ "categories-search-results"] $
for_ cats $ \category -> do
a_ [class_ "category-link", href_ (categoryLink category)] $
toHtml (category^.title)
-- | Render a <div> with search results.
renderSearchResults :: Monad m => [SearchResult] -> HtmlT m ()
renderSearchResults rs = do
div_ [id_ "search-results"] $
mapM_ renderSearchResult rs
-- | Render one search result.
renderSearchResult :: Monad m => SearchResult -> HtmlT m ()
renderSearchResult r = do
div_ [class_ "search-result"] $
case r of
SRCategory cat -> do
a_ [class_ "category-link", href_ (categoryLink cat)] $
toHtml (cat^.title)
div_ [class_ "category-description notes-like"] $
toHtml (extractPreface $ toMarkdownTree "" $ cat^.notes.mdText)
SRItem cat item -> do
a_ [class_ "category-link in-item-sr", href_ (categoryLink cat)] $
toHtml (cat^.title)
span_ [class_ "breadcrumb"] "»"
a_ [class_ "item-link", href_ (itemLink cat item)] $
toHtml (item^.name)
div_ [class_ "description notes-like"] $
toHtml (item^.description)
SRItemEcosystem cat item -> do
a_ [class_ "category-link in-item-sr", href_ (categoryLink cat)] $
toHtml (cat^.title)
span_ [class_ "breadcrumb"] "»"
a_ [class_ "item-link", href_ (itemLink cat item)] $
toHtml (item^.name)
span_ [class_ "item-link-addition"] "'s ecosystem"
div_ [class_ "ecosystem notes-like"] $
toHtml (item^.ecosystem)
{- Note [enabled sections]
~~~~~~~~~~~~~~~~~~~~~~~~~~

22
src/Guide/Views/Utils.hs
View File

@ -109,7 +109,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 ()
@ -119,18 +119,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)
@ -142,7 +142,7 @@ clearInput :: JS
clearInput = JS "this.value = '';"
onFormSubmit :: (JS -> JS) -> Attribute
onFormSubmit f = onsubmit_ $ format "{} return false;" [f (JS "this")]
onFormSubmit f = onsubmit_ $ format "{} return false;" (f (JS "this"))
button :: Monad m => Text -> [Attribute] -> JS -> HtmlT m ()
button value attrs handler =
@ -191,7 +191,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,
@ -223,7 +223,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]] ++
@ -249,18 +249,18 @@ thisNode = do
return (JS.selectParent (JS.selectUid uid'))
itemNodeId :: Item -> Text
itemNodeId item = format "item-{}" [item^.uid]
itemNodeId item = format "item-{}" (item^.uid)
categoryNodeId :: Category -> Text
categoryNodeId category = format "category-{}" [category^.uid]
categoryNodeId category = format "category-{}" (category^.uid)
-- TODO: another absolute link to get rid of [absolute-links]
categoryLink :: Category -> Url
categoryLink category = format "/haskell/{}" [categorySlug category]
categoryLink category = format "/haskell/{}" (categorySlug category)
itemLink :: Category -> Item -> Url
itemLink category item =
format "/haskell/{}#{}" (categorySlug category, itemNodeId item)
format "/haskell/{}#{}" (categorySlug category) (itemNodeId item)
-- See Note [show-hide]; wheh changing these, also look at 'JS.switchSection'.
shown, noScriptShown :: Attribute

4
src/site/Main.hs
View File

@ -1,7 +1,7 @@
module Main where
import qualified Guide.Server
import qualified Guide.Main
import Prelude (IO)
main :: IO ()
main = Guide.Server.main
main = Guide.Main.main

10
stack.yaml
View File

@ -1,17 +1,15 @@
resolver: lts-7.9
resolver: lts-8.13
packages:
- location: .
- location:
git: https://github.com/aelve/stache-plus
commit: e8e7967d561148167eb1fe4112c6ad0e091490ab
commit: 789aeabbf8069dec80647160f127d047e8f5a330
extra-dep: true
extra-deps:
- cmark-sections-0.1.0.2
- http-client-0.5.1
- edit-distance-vector-1.0.0.4
- cmark-sections-0.1.0.3
- patches-vector-0.1.5.4
- fmt-0.0.0.4
- fmt-0.2.0.0
- Spock-digestive-0.3.0.0
- digestive-functors-0.8.2.0

4
static/cog.svg Normal file
View File

@ -0,0 +1,4 @@
<svg xmlns="http://www.w3.org/2000/svg" width="8" height="8" viewBox="0 0 8 8">
<path d="M3.5 0l-.5 1.19c-.1.03-.19.08-.28.13l-1.19-.5-.72.72.5 1.19c-.05.1-.09.18-.13.28l-1.19.5v1l1.19.5c.04.1.08.18.13.28l-.5 1.19.72.72 1.19-.5c.09.04.18.09.28.13l.5 1.19h1l.5-1.19c.09-.04.19-.08.28-.13l1.19.5.72-.72-.5-1.19c.04-.09.09-.19.13-.28l1.19-.5v-1l-1.19-.5c-.03-.09-.08-.19-.13-.28l.5-1.19-.72-.72-1.19.5c-.09-.04-.19-.09-.28-.13l-.5-1.19h-1zm.5 2.5c.83 0 1.5.67 1.5 1.5s-.67 1.5-1.5 1.5-1.5-.67-1.5-1.5.67-1.5 1.5-1.5z"
/>
</svg>
Side by Side

After

Width:  |  Height:  |  Size: 528 B

41
templates/css.widget
View File

@ -132,12 +132,6 @@ body {
margin-top: 3em;
}
#categories-search-results {
margin-top: 3em;
margin-bottom: 1em;
padding-left: 2em;
}
.category-group {
width: 340px;
padding: 0 30px;
@ -180,7 +174,6 @@ body {
line-height: 18px;
}
#categories-search-results .category-link,
.categories-finished .category-link {
font-size: 21px;
font-weight: 600;
@ -191,6 +184,40 @@ body {
white-space: nowrap;
}
/* search results */
#search-results {
margin-top: 3em;
margin-bottom: 1em;
}
.search-result {
padding: 0.9em 1.1em;
margin: 1.5em 1px;
box-shadow: 0 1px 5px rgba(0,0,0,0.12), 0 1px 2px rgba(0,0,0,0.24);
}
.search-result .category-link {
font-size: 22px;
font-weight: 600;
line-height: 28px;
}
.search-result .category-link.in-item-sr {
font-size: 21px;
color: #999;
}
.search-result .item-link, .search-result .item-link-addition {
font-size: 22px;
}
.search-result .breadcrumb {
color: #999;
font-size: 22px;
margin: 0px 6px;
}
/* category pages */
.category {

118
templates/item-info.widget
View File

@ -88,7 +88,7 @@ HTML: item-info-controls
</span>
<span>
{{> img-button
src = "/pencil.svg"
src = "/cog.svg"
title = "edit item info"
class = "edit-item-info"
action = [| editItemInfo({{{%js item.uid}}}); |] }}
@ -152,64 +152,84 @@ function editItemInfo(itemUid) {
switchSection("#item-" + itemUid + " .item-info", "editing");
}
CSS
------------------------------------------------------------
.item-info-edit-form label {
display: block;
margin-bottom: 5px;
margin-top: 15px;
}
.item-info-edit-form {
margin-top: 15px;
margin-bottom: 5px;
}
.form-btn-group {
margin-top: 20px;
margin-bottom: 5px;
}
.form-btn-group .save {
margin-right: 25px;
}
HTML: item-info-edit-form
------------------------------------------------------------
{{! "autocomplete=off" everywhere: http://stackoverflow.com/q/8311455 }}
<form onsubmit="submitItemInfo('{{item.uid}}', this); return false;">
<label>
Name<br>
<input name="name" value="{{item.name}}"
type="text" autocomplete="off">
<form class="item-info-edit-form" onsubmit="submitItemInfo('{{item.uid}}', this); return false;">
<label for="name">
Name
</label>
<br>
<input id="name" name="name" value="{{item.name}}"
type="text" autocomplete="off">
<label>
Kind<br>
<select name="kind" autocomplete="off">
{{! possible_kinds would have stuff like “library”, “tool”, “other” }}
{{#possible_kinds}}
<option value="{{name}}" {{%selectIf selected}}>{{caption}}</option>
{{/possible_kinds}}
<label for="kind">
Kind
</label>
<select id="kind" name="kind" autocomplete="off">
{{! possible_kinds would have stuff like “library”, “tool”, “other” }}
{{#possible_kinds}}
<option value="{{name}}" {{%selectIf selected}}>{{caption}}</option>
{{/possible_kinds}}
</select>
<label for="hackage-name">
Name on Hackage
</label>
<input id="hackage-name" name="hackage-name" value="{{#item.kind.hackageName}}{{.}}{{/item.kind.hackageName}}"
type="text" autocomplete="off">
<label for="site">
Site (optional)
</label>
<input id="site" name="link" value="{{item.link}}"
type="text" autocomplete="off">
<div class="form-group">
<label for="group">
Group
</label>
{{! When “new group” is selected in the list, we show a field for
entering new group's name }}
<select id="group" name="group" onchange="itemGroupSelectHandler(this);"
autocomplete="off">
<option value="-" {{%selectIf item_no_group}}>-</option>
{{# category_groups }}
<option value="{{name}}" {{%selectIf selected}}>{{name}}</option>
{{/ category_groups }}
<option value="">New group...</option>
</select>
</label>
<br>
<label>
Name on Hackage<br>
<input name="hackage-name" value="{{#item.kind.hackageName}}{{.}}{{/item.kind.hackageName}}"
type="text" autocomplete="off">
</label>
<br>
<label>
Site (optional)<br>
<input name="link" value="{{item.link}}"
type="text" autocomplete="off">
</label>
<br>
<label>
Group<br>
{{! When “new group” is selected in the list, we show a field for
entering new group's name }}
<select name="group" onchange="itemGroupSelectHandler(this);"
autocomplete="off">
<option value="-" {{%selectIf item_no_group}}>-</option>
{{# category_groups }}
<option value="{{name}}" {{%selectIf selected}}>{{name}}</option>
{{/ category_groups }}
<option value="">New group...</option>
</select>
</label>
<input hidden class="custom-group-input" name="custom-group"
type="text" autocomplete="off">
<br>
</div>
<input value="Save" class="save" type="submit">
<input value="Cancel" class="cancel" type="button"
onclick="itemInfoCancelEdit('{{item.uid}}');">
<div class="form-btn-group">
<input value="Save" class="save" type="submit">
<input value="Cancel" class="cancel" type="button"
onclick="itemInfoCancelEdit('{{item.uid}}');">
</div>
</form>

8
tests/MarkdownSpec.hs
View File

@ -101,7 +101,7 @@ tests = describe "Markdown" $ do
describe "block+toc Markdown" $ do
it "renders correctly" $ do
let s = "x\n\n# foo\n\n## foo\n\ny"
htmlToText (toMarkdownBlockWithTOC "i-" s) `shouldBe`
htmlToText (toMarkdownTree "i-" s) `shouldBe`
"<p>x</p>\n\
\<h1><span id=\"i-foo\"></span>foo</h1>\
\<h2><span id=\"i-foo_\"></span>foo</h2>\
@ -113,7 +113,7 @@ tests = describe "Markdown" $ do
headingMD = MD.Node Nothing (TEXT "foo") []
foo2MD = MD.Node (Just (PosInfo 7 1 7 1)) PARAGRAPH
[MD.Node Nothing (TEXT "y") []]
(toMarkdownBlockWithTOC "i-" s ^. mdTree) `shouldBe` Document {
(toMarkdownTree "i-" s ^. mdTree) `shouldBe` Document {
prefaceAnn = "<p>x</p>\n",
preface = Ann "x\n\n" [prefaceMD],
sections = [
@ -134,7 +134,7 @@ tests = describe "Markdown" $ do
it "has a correct TOC" $ do
let s = "x\n\n# foo\n\n## foo\n\ny"
let headingMD = MD.Node Nothing (TEXT "foo") []
(toMarkdownBlockWithTOC "i-" s ^. mdTOC) `shouldBe` [
(toMarkdownTree "i-" s ^. mdTOC) `shouldBe` [
Node {rootLabel = ([headingMD],"i-foo"),
subForest = [
Node {rootLabel = ([headingMD],"i-foo_"),
@ -157,7 +157,7 @@ blockMarkdowns f = do
describe "block MD" $
f ((view mdText &&& htmlToText) . toMarkdownBlock)
describe "block+toc MD" $
f ((view mdText &&& htmlToText) . toMarkdownBlockWithTOC "")
f ((view mdText &&& htmlToText) . toMarkdownTree "")
mdInlineExamples :: [Text]
mdInlineExamples = [

4
tests/WebSpec.hs
View File

@ -28,7 +28,7 @@ import Selenium
import qualified Test.WebDriver.Common.Keys as Key
-- Site
import qualified Guide.Server
import qualified Guide.Main
import Guide.Config (Config(..))
@ -611,7 +611,7 @@ run ts = do
--
-- Using 'Slave.fork' in 'Guide.mainWith' ensures that threads started
-- inside of 'mainWith' will be killed too when the thread dies.
tid <- Slave.fork $ Guide.Server.mainWith Config {
tid <- Slave.fork $ Guide.Main.mainWith Config {
_baseUrl = "/",
_googleToken = "some-google-token",
_adminPassword = "123",