diff --git a/README.md b/README.md index 54b4552..522e745 100644 --- a/README.md +++ b/README.md @@ -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: diff --git a/guide.cabal b/guide.cabal index cecbbd0..747e84a 100644 --- a/guide.cabal +++ b/guide.cabal @@ -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 diff --git a/src/Guide/Config.hs b/src/Guide/Config.hs index 3d7a832..70f2793 100644 --- a/src/Guide/Config.hs +++ b/src/Guide/Config.hs @@ -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 diff --git a/src/Guide/Handlers.hs b/src/Guide/Handlers.hs index ab8f393..ae4cb31 100644 --- a/src/Guide/Handlers.hs +++ b/src/Guide/Handlers.hs @@ -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))) diff --git a/src/Guide/JS.hs b/src/Guide/JS.hs index 90c27b1..6988661 100644 --- a/src/Guide/JS.hs +++ b/src/Guide/JS.hs @@ -122,8 +122,8 @@ class JSFunction a where instance JSFunction JS where makeJSFunction fName fParams fDef = let paramList = T.intercalate "," fParams - in JS $ "function "%%"("%%") {\n" - %% + 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 $ ""%%"("%%");" + 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 diff --git a/src/Guide/Server.hs b/src/Guide/Main.hs similarity index 99% rename from src/Guide/Server.hs rename to src/Guide/Main.hs index bf4e4e6..a6172a5 100644 --- a/src/Guide/Server.hs +++ b/src/Guide/Main.hs @@ -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, diff --git a/src/Guide/Markdown.hs b/src/Guide/Markdown.hs index a65f589..b02041c 100644 --- a/src/Guide/Markdown.hs +++ b/src/Guide/Markdown.hs @@ -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 diff --git a/src/Guide/Search.hs b/src/Guide/Search.hs new file mode 100644 index 0000000..1feab8e --- /dev/null +++ b/src/Guide/Search.hs @@ -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)) diff --git a/src/Guide/ServerStuff.hs b/src/Guide/ServerStuff.hs index ab7fff4..7a6e59c 100644 --- a/src/Guide/ServerStuff.hs +++ b/src/Guide/ServerStuff.hs @@ -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 diff --git a/src/Guide/State.hs b/src/Guide/State.hs index 96cc9cc..a4a2024 100644 --- a/src/Guide/State.hs +++ b/src/Guide/State.hs @@ -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' diff --git a/src/Guide/Types/Core.hs b/src/Guide/Types/Core.hs index 8074ca6..fcbe391 100644 --- a/src/Guide/Types/Core.hs +++ b/src/Guide/Types/Core.hs @@ -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 diff --git a/src/Guide/Utils.hs b/src/Guide/Utils.hs index c078f8f..280112f 100644 --- a/src/Guide/Utils.hs +++ b/src/Guide/Utils.hs @@ -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 @