From bd51f87bed0aac691a45efbb421d834bba9dfaf6 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Sun, 11 Aug 2019 13:19:39 +0300 Subject: [PATCH] Cleanup the way we work with record fields (#365) * Use 'fields' where appropriate * Don't use makeFields * Rename fields of Config * Don't use makeFields for Markdown types --- back/guide.cabal | 2 + back/src/Guide/Api/Methods.hs | 37 +-- back/src/Guide/Api/Server.hs | 15 +- back/src/Guide/Api/Types.hs | 134 +++++++---- back/src/Guide/Api/Utils.hs | 10 +- back/src/Guide/Config.hs | 111 ++++----- back/src/Guide/Database/Types.hs | 104 ++++---- back/src/Guide/Diff.hs | 5 +- back/src/Guide/Handlers.hs | 33 +-- back/src/Guide/Logger/Run.hs | 6 +- back/src/Guide/Main.hs | 36 +-- back/src/Guide/Markdown.hs | 115 +++++---- back/src/Guide/Matomo.hs | 2 +- back/src/Guide/Search.hs | 16 +- back/src/Guide/ServerStuff.hs | 24 +- back/src/Guide/State.hs | 329 +++++++++++++------------- back/src/Guide/Types/Core.hs | 135 ++++------- back/src/Guide/Types/User.hs | 75 +++--- back/src/Guide/Utils.hs | 9 + back/src/Guide/Views.hs | 125 +++++----- back/src/Guide/Views/Auth/Login.hs | 2 +- back/src/Guide/Views/Auth/Register.hs | 2 +- back/src/Guide/Views/Category.hs | 51 ++-- back/src/Guide/Views/Item.hs | 76 +++--- back/src/Guide/Views/Page.hs | 2 +- back/src/Guide/Views/Utils.hs | 20 +- back/tests/MarkdownSpec.hs | 12 +- back/tests/WebSpec.hs | 14 +- 28 files changed, 764 insertions(+), 738 deletions(-) diff --git a/back/guide.cabal b/back/guide.cabal index 5e13c69..d605ee5 100644 --- a/back/guide.cabal +++ b/back/guide.cabal @@ -214,6 +214,8 @@ library , ConstraintKinds , InstanceSigs , DerivingStrategies + , TemplateHaskellQuotes + , ScopedTypeVariables test-suite tests main-is: Main.hs diff --git a/back/src/Guide/Api/Methods.hs b/back/src/Guide/Api/Methods.hs index 54b3478..b5611ef 100644 --- a/back/src/Guide/Api/Methods.hs +++ b/back/src/Guide/Api/Methods.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -63,23 +64,23 @@ createCategory title' group' = -- | Edit category's note. setCategoryNotes :: Uid Category -> CTextEdit -> Guider NoContent -setCategoryNotes catId CTextEdit{..} = +setCategoryNotes catId $(fields 'CTextEdit) = logHandler "setCategoryNotes" [attr "catId" catId] $ do - serverModified <- markdownBlockMdSource . _categoryNotes <$> getCategoryOrFail catId + serverModified <- markdownBlockSource . categoryNotes <$> getCategoryOrFail catId checkConflict CTextEdit{..} serverModified addEdit . fst =<< dbUpdate (SetCategoryNotes catId cteModified) pure NoContent -- | Edit category's info (title, group, status, sections (pro/con, ecosystem, note)). setCategoryInfo :: Uid Category -> CCategoryInfoEdit -> Guider NoContent -setCategoryInfo catId CCategoryInfoEdit{..} = +setCategoryInfo catId $(fields 'CCategoryInfoEdit) = logHandler "setCategoryInfo" [attr "catId" catId] $ do category <- getCategoryOrFail catId -- TODO diff and merge (editTitle, _) <- dbUpdate $ SetCategoryTitle catId ccieTitle (editGroup, _) <- dbUpdate $ SetCategoryGroup catId ccieGroup (editStatus, _) <- dbUpdate $ SetCategoryStatus catId ccieStatus - let oldEnabledSections = category ^. enabledSections + let oldEnabledSections = categoryEnabledSections category let newEnabledSections = ccieSections (editSection, _) <- dbUpdate $ ChangeCategoryEnabledSections catId (newEnabledSections S.\\ oldEnabledSections) @@ -109,7 +110,7 @@ getItem itemId = -- -- Returns the ID of the created item. createItem :: Uid Category -> CCreateItem -> Guider (Uid Item) -createItem catId CCreateItem{..} = +createItem catId $(fields 'CCreateItem) = logHandler "createItem" [attr "catId" catId, attr "name" cciName] $ do _ <- getCategoryOrFail catId when (T.null cciName) $ @@ -123,7 +124,7 @@ createItem catId CCreateItem{..} = -- | Modify item info. Fields that are not present ('Nothing') are not modified. setItemInfo :: Uid Item -> CItemInfoEdit -> Guider NoContent -setItemInfo itemId CItemInfoEdit{..} = +setItemInfo itemId $(fields 'CItemInfoEdit) = logHandler "setItemInfo" [attr "itemId" itemId] $ do void $ getItemOrFail itemId -- TODO diff and merge @@ -137,27 +138,27 @@ setItemInfo itemId CItemInfoEdit{..} = -- | Set item's summary. setItemSummary :: Uid Item -> CTextEdit -> Guider NoContent -setItemSummary itemId CTextEdit{..} = +setItemSummary itemId $(fields 'CTextEdit) = logHandler "setItemSummary" [attr "itemId" itemId] $ do - serverModified <- markdownBlockMdSource . _itemSummary <$> getItemOrFail itemId + serverModified <- markdownBlockSource . itemSummary <$> getItemOrFail itemId checkConflict CTextEdit{..} serverModified addEdit . fst =<< dbUpdate (SetItemSummary itemId cteModified) pure NoContent -- | Set item's ecosystem. setItemEcosystem :: Uid Item -> CTextEdit -> Guider NoContent -setItemEcosystem itemId CTextEdit{..} = +setItemEcosystem itemId $(fields 'CTextEdit) = logHandler "setItemEcosystem" [attr "itemId" itemId] $ do - serverModified <- markdownBlockMdSource . _itemEcosystem <$> getItemOrFail itemId + serverModified <- markdownBlockSource . itemEcosystem <$> getItemOrFail itemId checkConflict CTextEdit{..} serverModified addEdit . fst =<< dbUpdate (SetItemEcosystem itemId cteModified) pure NoContent -- | Set item's notes. setItemNotes :: Uid Item -> CTextEdit -> Guider NoContent -setItemNotes itemId CTextEdit{..} = +setItemNotes itemId $(fields 'CTextEdit) = logHandler "setItemNotes" [attr "itemId" itemId] $ do - serverModified <- markdownTreeMdSource . _itemNotes <$> getItemOrFail itemId + serverModified <- markdownTreeSource . itemNotes <$> getItemOrFail itemId checkConflict CTextEdit{..} serverModified addEdit . fst =<< dbUpdate (SetItemNotes itemId cteModified) pure NoContent @@ -172,7 +173,7 @@ deleteItem itemId = -- | Move item up or down moveItem :: Uid Item -> CMove -> Guider NoContent -moveItem itemId CMove{..} = +moveItem itemId $(fields 'CMove) = logHandler "moveItem" [attr "itemId" itemId] $ do void $ getItemOrFail itemId addEdit =<< dbUpdate (MoveItem itemId (cmDirection == DirectionUp)) @@ -190,7 +191,7 @@ getTrait itemId traitId = -- | Create a trait (pro/con). createTrait :: Uid Item -> CCreateTrait -> Guider (Uid Trait) -createTrait itemId CCreateTrait{..} = +createTrait itemId $(fields 'CCreateTrait) = logHandler "createTrait" [attr "itemId" itemId] $ do when (T.null cctContent) $ throwError err400{errReasonPhrase = "'content' can not be empty"} @@ -202,9 +203,9 @@ createTrait itemId CCreateTrait{..} = -- | Update the text of a trait (pro/con). setTrait :: Uid Item -> Uid Trait -> CTextEdit -> Guider NoContent -setTrait itemId traitId CTextEdit{..} = +setTrait itemId traitId $(fields 'CTextEdit) = logHandler "setTrait" [attr "itemId" itemId, attr "traitId" traitId] $ do - serverModified <- markdownInlineMdSource . _traitContent <$> getTraitOrFail itemId traitId + serverModified <- markdownInlineSource . traitContent <$> getTraitOrFail itemId traitId checkConflict CTextEdit{..} serverModified addEdit . fst =<< dbUpdate (SetTraitContent itemId traitId cteModified) pure NoContent @@ -219,7 +220,7 @@ deleteTrait itemId traitId = -- | Move trait up or down moveTrait :: Uid Item -> Uid Trait -> CMove -> Guider NoContent -moveTrait itemId traitId CMove{..} = +moveTrait itemId traitId $(fields 'CMove) = logHandler "moveTrait" [attr "itemId" itemId, attr "traitId" traitId] $ do void $ getTraitOrFail itemId traitId addEdit =<< dbUpdate (MoveTrait itemId traitId (cmDirection == DirectionUp)) @@ -299,7 +300,7 @@ getTraitOrFail itemId traitId = do -- | Checker. When states of database before and after editing is different, fail with a conflict data. checkConflict :: CTextEdit -> Text -> Guider () -checkConflict CTextEdit{..} serverModified = do +checkConflict $(fields 'CTextEdit) serverModified = do let original = cteOriginal let modified = cteModified when (original /= serverModified) $ do diff --git a/back/src/Guide/Api/Server.hs b/back/src/Guide/Api/Server.hs index a3d8993..e8e00dc 100644 --- a/back/src/Guide/Api/Server.hs +++ b/back/src/Guide/Api/Server.hs @@ -15,7 +15,7 @@ import Imports import Data.Swagger.Lens hiding (format) import Network.Wai (Middleware, Request) -import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, corsOrigins, +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), corsOrigins, simpleCorsResourcePolicy) import Servant import Servant.API.Generic @@ -32,6 +32,7 @@ import Guide.State import qualified Network.Wai.Handler.Warp as Warp import qualified Data.Acid as Acid +import qualified Network.Wai.Middleware.Cors as Cors -- | The type that 'runApiServer' serves. type FullApi = @@ -41,19 +42,19 @@ type FullApi = -- | Serve the API on port 4400. runApiServer :: Logger -> Config -> Acid.AcidState GlobalState -> IO () runApiServer logger Config{..} db = do - logDebugIO logger $ format "API is running on port {}" _portApi + logDebugIO logger $ format "API is running on port {}" portApi let guideSettings = Warp.defaultSettings & Warp.setOnException (logException logger) - & Warp.setPort _portApi + & Warp.setPort portApi Warp.runSettings guideSettings $ corsPolicy $ serve (Proxy @FullApi) (fullServer db logger Config{..}) where corsPolicy :: Middleware corsPolicy = - if _cors then cors (const $ Just (policy _portApi)) - else cors (const Nothing) - policy :: Int -> CorsResourcePolicy - policy portApi = simpleCorsResourcePolicy + if cors then Cors.cors (const $ Just policy) + else Cors.cors (const Nothing) + policy :: CorsResourcePolicy + policy = simpleCorsResourcePolicy -- TODO: Add Guide's frontend address (and maybe others resources) -- to list of `corsOrigins` to allow CORS requests { corsOrigins = Just ( diff --git a/back/src/Guide/Api/Types.hs b/back/src/Guide/Api/Types.hs index 263ae0c..0726bb0 100644 --- a/back/src/Guide/Api/Types.hs +++ b/back/src/Guide/Api/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -69,7 +70,7 @@ import Guide.Api.Utils import Guide.Markdown import Guide.Search import Guide.Types.Core as G -import Guide.Utils (Uid (..), Url) +import Guide.Utils (Uid (..), Url, fields) import qualified Data.Aeson as A import Data.Swagger as S @@ -431,7 +432,7 @@ data CCategoryInfo = CCategoryInfo { cciId :: Uid Category , cciTitle :: Text , cciCreated :: UTCTime - , cciGroup_ :: Text + , cciGroup :: Text , cciStatus :: CategoryStatus } deriving (Show, Generic) @@ -454,13 +455,20 @@ instance ToSchema CCategoryInfo where -- | Factory to create a 'CCategoryInfo' from a 'Category' toCCategoryInfo :: Category -> CCategoryInfo -toCCategoryInfo Category{..} = CCategoryInfo - { cciId = _categoryUid - , cciTitle = _categoryTitle - , cciCreated = _categoryCreated - , cciGroup_ = _categoryGroup_ - , cciStatus = _categoryStatus +toCCategoryInfo $(fields 'Category) = CCategoryInfo + { cciId = categoryUid + , cciTitle = categoryTitle + , cciCreated = categoryCreated + , cciGroup = categoryGroup + , cciStatus = categoryStatus } + where + -- Ignored "heavy" fields + _ = categoryItems + _ = categoryItemsDeleted + _ = categoryNotes + -- Not heavy, just not particularly useful metadata + _ = categoryEnabledSections ---------------------------------------------------------------------------- -- CCategoryFull @@ -497,15 +505,20 @@ instance ToSchema CCategoryFull where -- | Factory to create a 'CCategoryFull' from a 'Category' toCCategoryFull :: Category -> CCategoryFull -toCCategoryFull Category{..} = CCategoryFull - { ccfId = _categoryUid - , ccfTitle = _categoryTitle - , ccfGroup = _categoryGroup_ - , ccfStatus = _categoryStatus - , ccfDescription = toCMarkdown _categoryNotes - , ccfSections = _categoryEnabledSections - , ccfItems = fmap toCItemFull _categoryItems +toCCategoryFull $(fields 'Category) = CCategoryFull + { ccfId = categoryUid + , ccfTitle = categoryTitle + , ccfGroup = categoryGroup + , ccfStatus = categoryStatus + , ccfDescription = toCMarkdown categoryNotes + , ccfSections = categoryEnabledSections + , ccfItems = fmap toCItemFull categoryItems } + where + -- Ignored fields + _ = categoryItemsDeleted + -- TODO: return creation time + _ = categoryCreated ---------------------------------------------------------------------------- -- CCategoryInfoEdit @@ -571,13 +584,20 @@ instance ToSchema CItemInfo where -- | Factory to create a 'CItemInfo' from an 'Item' toCItemInfo :: Item -> CItemInfo -toCItemInfo Item{..} = CItemInfo - { ciiId = _itemUid - , ciiCreated = _itemCreated - , ciiName = _itemName - , ciiHackage = _itemHackage - , ciiLink = _itemLink +toCItemInfo $(fields 'Item) = CItemInfo + { ciiId = itemUid + , ciiCreated = itemCreated + , ciiName = itemName + , ciiHackage = itemHackage + , ciiLink = itemLink } + where + -- We don't return "heavy" fields + _ = itemNotes + _ = itemEcosystem + _ = itemSummary + _ = (itemCons, itemConsDeleted) + _ = (itemPros, itemProsDeleted) ---------------------------------------------------------------------------- -- CItemInfoEdit @@ -662,19 +682,22 @@ instance ToSchema CItemFull where -- | Factory to create a 'CItemFull' from an 'Item' toCItemFull :: Item -> CItemFull -toCItemFull Item{..} = CItemFull - { cifId = _itemUid - , cifName = _itemName - , cifCreated = _itemCreated - , cifHackage = _itemHackage - , cifSummary = toCMarkdown _itemSummary - , cifPros = fmap toCTrait _itemPros - , cifCons = fmap toCTrait _itemCons - , cifEcosystem = toCMarkdown _itemEcosystem - , cifNotes = toCMarkdown _itemNotes - , cifLink = _itemLink - , cifToc = map toCTocHeading (markdownTreeMdTOC _itemNotes) +toCItemFull $(fields 'Item) = CItemFull + { cifId = itemUid + , cifName = itemName + , cifCreated = itemCreated + , cifHackage = itemHackage + , cifSummary = toCMarkdown itemSummary + , cifPros = fmap toCTrait itemPros + , cifCons = fmap toCTrait itemCons + , cifEcosystem = toCMarkdown itemEcosystem + , cifNotes = toCMarkdown itemNotes + , cifLink = itemLink + , cifToc = map toCTocHeading (markdownTreeTOC itemNotes) } + where + -- Ignored fields + _ = (itemProsDeleted, itemConsDeleted) ---------------------------------------------------------------------------- -- CTrait @@ -697,9 +720,9 @@ instance ToSchema CTrait where -- | Factory to create a 'CTrait' from a 'Trait' toCTrait :: Trait -> CTrait -toCTrait trait = CTrait - { ctId = trait ^. uid - , ctContent = toCMarkdown $ trait ^. content +toCTrait $(fields 'Trait) = CTrait + { ctId = traitUid + , ctContent = toCMarkdown traitContent } ---------------------------------------------------------------------------- @@ -730,22 +753,33 @@ instance ToSchema CMarkdown where class ToCMarkdown md where toCMarkdown :: md -> CMarkdown instance ToCMarkdown MarkdownInline where - toCMarkdown md = CMarkdown - { cmdText = md^.mdSource - , cmdHtml = toText (md^.mdHtml) + toCMarkdown $(fields 'MarkdownInline) = CMarkdown + { cmdText = markdownInlineSource + , cmdHtml = toText markdownInlineHtml } + where + -- Ignored fields + _ = markdownInlineMarkdown instance ToCMarkdown MarkdownBlock where - toCMarkdown md = CMarkdown - { cmdText = md^.mdSource - , cmdHtml = toText (md^.mdHtml) + toCMarkdown $(fields 'MarkdownBlock) = CMarkdown + { cmdText = markdownBlockSource + , cmdHtml = toText markdownBlockHtml } + where + -- Ignored fields + _ = markdownBlockMarkdown instance ToCMarkdown MarkdownTree where - toCMarkdown md = CMarkdown - { cmdText = md^.mdSource + toCMarkdown md@($(fields 'MarkdownTree)) = CMarkdown + { cmdText = markdownTreeSource , cmdHtml = toText . renderText $ toHtml md } + where + -- Ignored fields + _ = markdownTreeStructure + _ = markdownTreeTOC + _ = markdownTreeIdPrefix ---------------------------------------------------------------------------- -- CTocHeading @@ -773,8 +807,8 @@ instance ToSchema CTocHeading where -- | 'toCTocHeading' converts a table of contents into the format expected by the frontend. toCTocHeading :: Tree Heading -> CTocHeading -toCTocHeading Node{..} = CTocHeading - { cthContent = toCMarkdown $ headingMd rootLabel +toCTocHeading $(fields 'Node) = CTocHeading + { cthContent = toCMarkdown $ headingMarkdown rootLabel , cthSlug = headingSlug rootLabel , cthSubheadings = map toCTocHeading subForest } @@ -919,13 +953,13 @@ toCSearchResult (SRCategory cat) = -- is about). -- -- TODO: just extract the first paragraph, not the preface. - extractPreface $ toMarkdownTree "" $ cat^.G.notes.mdSource + extractPreface $ toMarkdownTree "" $ markdownBlockSource (categoryNotes cat) } toCSearchResult (SRItem cat item) = CSRItemResult $ CSRItem { csriCategory = toCCategoryInfo cat , csriInfo = toCItemInfo item - , csriSummary = Just (toCMarkdown (item ^. G.summary)) + , csriSummary = Just (toCMarkdown (itemSummary item)) , csriEcosystem = Nothing } -- TODO: currently if there are matches in both item description and item @@ -935,7 +969,7 @@ toCSearchResult (SRItemEcosystem cat item) = { csriCategory = toCCategoryInfo cat , csriInfo = toCItemInfo item , csriSummary = Nothing - , csriEcosystem = Just (toCMarkdown (item ^. ecosystem)) + , csriEcosystem = Just (toCMarkdown (itemEcosystem item)) } ---------------------------------------------------------------------------- diff --git a/back/src/Guide/Api/Utils.hs b/back/src/Guide/Api/Utils.hs index 7e30e1a..0263c20 100644 --- a/back/src/Guide/Api/Utils.hs +++ b/back/src/Guide/Api/Utils.hs @@ -48,13 +48,11 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrd -- | Nice JSON options. -- --- @ciConsDeleted@ becomes @cons_deleted@. Underscores at the end are --- dropped (useful for fields like @categoryGroup_@). +-- @ciConsDeleted@ becomes @cons_deleted@. jsonOptions :: Options -jsonOptions = defaultOptions{ fieldLabelModifier = camelTo2 '_' . trim } - where - trim :: String -> String - trim = dropWhileEnd (== '_') . dropWhile (not . isUpper) +jsonOptions = defaultOptions + { fieldLabelModifier = camelTo2 '_' . dropWhile (not . isUpper) + } -- | Swagger schema-generating options that match 'jsonOptions'. schemaOptions :: SchemaOptions diff --git a/back/src/Guide/Config.hs b/back/src/Guide/Config.hs index 0526c82..ffa08de 100644 --- a/back/src/Guide/Config.hs +++ b/back/src/Guide/Config.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- | Server config. For instance, the admin password is stored here, as well -- as the base url (for correct link generation in feeds). @@ -31,100 +32,102 @@ import qualified Data.ByteString.Lazy as BSL data Config = Config { -- | URL where the site is deployed. Used for generating feeds (which -- require absolute URLs). - _baseUrl :: Url, + baseUrl :: Url, -- | Google site verification token. Will be inserted into all pages. - _googleToken :: Text, + googleToken :: Text, -- | Password for the admin user. - _adminPassword :: Text, + adminPassword :: Text, -- | Link to a place to discuss the site. Will be placed in the header - _discussLink :: Maybe Url, + discussLink :: Maybe Url, -- | Link to Matomo to gather analytics about user actions. Format of the -- link shoud be like . - _matomoLink :: Maybe Url, + matomoLink :: Maybe Url, -- | Port for serving the main site (old backend and frontend). - _portMain :: Int, + portMain :: Int, -- | Port for serving the API. - _portApi :: Int, + portApi :: Int, -- | Port for serving EKG stats. - _portEkg :: Int, + portEkg :: Int, -- | CORS switch on/off. - _cors :: Bool, + cors :: Bool, -- | EKG switch on/off. - _ekg :: Bool, + ekg :: Bool, -- | Whether to log to @stderr@. - _logToStderr :: Bool, + logToStderr :: Bool, -- | Whether to log to a file. Can be turned on together with - -- '_logToStderr'. - _logToFile :: Maybe FilePath, + -- 'logToStderr'. + logToFile :: Maybe FilePath, -- | A formatting string for log timestamps. For the description of -- available formatters, see 'formatTime'. - _logTimeFormat :: String + logTimeFormat :: String } deriving (Eq, Show) +$(pure []) + -- | Default instance: no base URL, no Google token, empty password, no -- discussion link. instance Default Config where def = Config { - _baseUrl = "/", - _googleToken = "", - _adminPassword = "", - _discussLink = Nothing, - _matomoLink = Nothing, - _portMain = 8080, - _portApi = 4400, - _portEkg = 5050, - _cors = False, - _ekg = False, - _logToStderr = True, - _logToFile = Nothing, - _logTimeFormat = "%F %T UTC" + baseUrl = "/", + googleToken = "", + adminPassword = "", + discussLink = Nothing, + matomoLink = Nothing, + portMain = 8080, + portApi = 4400, + portEkg = 5050, + cors = False, + ekg = False, + logToStderr = True, + logToFile = Nothing, + logTimeFormat = "%F %T UTC" } instance FromJSON Config where parseJSON = withObject "config" $ \o -> do - _baseUrl <- o .:? "base-url" .!= _baseUrl def - _googleToken <- o .:? "google-token" .!= _googleToken def - _adminPassword <- o .:? "admin-password" .!= _adminPassword def - _discussLink <- o .:? "discuss-link" .!= _discussLink def - _matomoLink <- o .:? "matomo-link" .!= _matomoLink def - _portMain <- o .:? "port-main" .!= _portMain def - _portApi <- o .:? "port-api" .!= _portApi def - _portEkg <- o .:? "port-ekg" .!= _portEkg def - _cors <- o .:? "cors" .!= _cors def - _ekg <- o .:? "ekg" .!= _ekg def - _logToStderr <- o .:? "log-to-stderr" .!= _logToStderr def - _logToFile <- o .:? "log-to-file" .!= _logToFile def - _logTimeFormat <- o .:? "log-time-format" .!= _logTimeFormat def + baseUrl <- o .:? "base-url" .!= baseUrl def + googleToken <- o .:? "google-token" .!= googleToken def + adminPassword <- o .:? "admin-password" .!= adminPassword def + discussLink <- o .:? "discuss-link" .!= discussLink def + matomoLink <- o .:? "matomo-link" .!= matomoLink def + portMain <- o .:? "port-main" .!= portMain def + portApi <- o .:? "port-api" .!= portApi def + portEkg <- o .:? "port-ekg" .!= portEkg def + cors <- o .:? "cors" .!= cors def + ekg <- o .:? "ekg" .!= ekg def + logToStderr <- o .:? "log-to-stderr" .!= logToStderr def + logToFile <- o .:? "log-to-file" .!= logToFile def + logTimeFormat <- o .:? "log-time-format" .!= logTimeFormat def return Config{..} instance ToJSON Config where - toJSON Config{..} = object [ - "base-url" .= _baseUrl, - "google-token" .= _googleToken, - "admin-password" .= _adminPassword, - "discuss-link" .= _discussLink, - "matomo-link" .= _matomoLink, - "port-main" .= _portMain, - "port-api" .= _portApi, - "port-ekg" .= _portEkg, - "cors" .= _cors, - "ekg" .= _ekg, - "log-to-stderr" .= _logToStderr, - "log-to-file" .= _logToFile, - "log-time-format" .= _logTimeFormat + toJSON $(fields 'Config) = object [ + "base-url" .= baseUrl, + "google-token" .= googleToken, + "admin-password" .= adminPassword, + "discuss-link" .= discussLink, + "matomo-link" .= matomoLink, + "port-main" .= portMain, + "port-api" .= portApi, + "port-ekg" .= portEkg, + "cors" .= cors, + "ekg" .= ekg, + "log-to-stderr" .= logToStderr, + "log-to-file" .= logToFile, + "log-time-format" .= logTimeFormat ] -- | Read config from @config.json@ (creating a default config if the file diff --git a/back/src/Guide/Database/Types.hs b/back/src/Guide/Database/Types.hs index 7e08de1..6c7c748 100644 --- a/back/src/Guide/Database/Types.hs +++ b/back/src/Guide/Database/Types.hs @@ -35,7 +35,7 @@ import Named import Guide.Markdown (toMarkdownBlock, toMarkdownTree, toMarkdownInline) import Guide.Types.Core (Category (..), CategoryStatus, Item (..), ItemSection, Trait (..), TraitType) -import Guide.Utils (Uid (..), makeClassWithLenses) +import Guide.Utils (Uid (..), makeClassWithLenses, fields) -- | Custom datatype errors for database @@ -108,6 +108,10 @@ makeClassWithLenses ''TraitRow -- -- | To fetch items (they have an order) use 'getItemRowsByCategory' from 'Get' module. -- | To fetch deleted items use 'getDeletedItemRowsByCategory' from 'Get' module +-- +-- TODO: somehow handle the case when item IDs don't match the @itemsOrder@? +-- +-- TODO: use 'fields' for pattern-matching. categoryRowToCategory :: "items" :! [Item] -> "itemsDeleted" :! [Item] @@ -119,29 +123,32 @@ categoryRowToCategory CategoryRow{..} = Category - { _categoryUid = categoryRowUid - , _categoryTitle = categoryRowTitle - , _categoryCreated = categoryRowCreated - , _categoryGroup_ = categoryRowGroup - , _categoryStatus = categoryRowStatus - , _categoryNotes = toMarkdownBlock categoryRowNotes - , _categoryItems = items - , _categoryItemsDeleted = itemsDeleted - , _categoryEnabledSections = categoryRowEnabledSections + { categoryUid = categoryRowUid + , categoryTitle = categoryRowTitle + , categoryCreated = categoryRowCreated + , categoryGroup = categoryRowGroup + , categoryStatus = categoryRowStatus + , categoryNotes = toMarkdownBlock categoryRowNotes + , categoryItems = items + , categoryItemsDeleted = itemsDeleted + , categoryEnabledSections = categoryRowEnabledSections } -- | Convert Category to CategoryRow. categoryToRowCategory :: Category -> CategoryRow -categoryToRowCategory Category {..} = CategoryRow - { categoryRowUid = _categoryUid - , categoryRowTitle = _categoryTitle - , categoryRowCreated = _categoryCreated - , categoryRowGroup = _categoryGroup_ - , categoryRowStatus = _categoryStatus - , categoryRowNotes = toText $ show _categoryNotes -- TODO fix! - , categoryRowEnabledSections = _categoryEnabledSections - , categoryRowItemsOrder = map _itemUid _categoryItems +categoryToRowCategory $(fields 'Category) = CategoryRow + { categoryRowUid = categoryUid + , categoryRowTitle = categoryTitle + , categoryRowCreated = categoryCreated + , categoryRowGroup = categoryGroup + , categoryRowStatus = categoryStatus + , categoryRowNotes = toText $ show categoryNotes -- TODO fix! + , categoryRowEnabledSections = categoryEnabledSections + , categoryRowItemsOrder = map itemUid categoryItems } + where + -- Ignored fields + _ = categoryItemsDeleted -- | Convert ItemRow to Item. -- @@ -162,44 +169,47 @@ itemRowToItem ItemRow{..} = Item - { _itemUid = itemRowUid - , _itemName = itemRowName - , _itemCreated = itemRowCreated - , _itemHackage = itemRowHackage - , _itemSummary = toMarkdownBlock itemRowSummary - , _itemPros = proTraits - , _itemProsDeleted = proDeletedTraits - , _itemCons = conTraits - , _itemConsDeleted = conDeletedTraits - , _itemEcosystem = toMarkdownBlock itemRowEcosystem - , _itemNotes = toMarkdownTree prefix itemRowNotes - , _itemLink = itemRowLink + { itemUid = itemRowUid + , itemName = itemRowName + , itemCreated = itemRowCreated + , itemHackage = itemRowHackage + , itemSummary = toMarkdownBlock itemRowSummary + , itemPros = proTraits + , itemProsDeleted = proDeletedTraits + , itemCons = conTraits + , itemConsDeleted = conDeletedTraits + , itemEcosystem = toMarkdownBlock itemRowEcosystem + , itemNotes = toMarkdownTree prefix itemRowNotes + , itemLink = itemRowLink } where prefix = "item-notes-" <> uidToText itemRowUid <> "-" -- | Convert Item to ItemRow. itemToRowItem :: Uid Category -> "deleted" :! Bool -> Item -> ItemRow -itemToRowItem catId (arg #deleted -> deleted) Item{..} = ItemRow - { itemRowUid = _itemUid - , itemRowName = _itemName - , itemRowCreated = _itemCreated - , itemRowLink = _itemLink - , itemRowHackage = _itemHackage - , itemRowSummary = toText $ show _itemSummary - , itemRowEcosystem = toText $ show _itemEcosystem - , itemRowNotes = toText $ show _itemNotes +itemToRowItem catId (arg #deleted -> deleted) $(fields 'Item) = ItemRow + { itemRowUid = itemUid + , itemRowName = itemName + , itemRowCreated = itemCreated + , itemRowLink = itemLink + , itemRowHackage = itemHackage + , itemRowSummary = toText $ show itemSummary -- TODO fix + , itemRowEcosystem = toText $ show itemEcosystem -- TODO fix + , itemRowNotes = toText $ show itemNotes -- TODO fix , itemRowDeleted = deleted , itemRowCategoryUid = catId - , itemRowProsOrder = map _traitUid _itemPros - , itemRowConsOrder = map _traitUid _itemCons + , itemRowProsOrder = map traitUid itemPros + , itemRowConsOrder = map traitUid itemCons } + where + -- Ignored fields + _ = (itemConsDeleted, itemProsDeleted) -- | Convert TraitRow to Trait. traitRowToTrait :: TraitRow -> Trait traitRowToTrait TraitRow{..} = Trait - { _traitUid = traitRowUid - , _traitContent = toMarkdownInline traitRowContent + { traitUid = traitRowUid + , traitContent = toMarkdownInline traitRowContent } -- Convert Trait to TraitRow @@ -209,10 +219,10 @@ traitToTraitRow -> TraitType -> Trait -> TraitRow -traitToTraitRow itemId (arg #deleted -> deleted) traitType Trait{..} = +traitToTraitRow itemId (arg #deleted -> deleted) traitType $(fields 'Trait) = TraitRow - { traitRowUid = _traitUid - , traitRowContent = toText $ show _traitContent + { traitRowUid = traitUid + , traitRowContent = toText $ show traitContent -- TODO fix , traitRowDeleted = deleted , traitRowType = traitType , traitRowItemUid = itemId diff --git a/back/src/Guide/Diff.hs b/back/src/Guide/Diff.hs index 6019557..f7d49b7 100644 --- a/back/src/Guide/Diff.hs +++ b/back/src/Guide/Diff.hs @@ -25,6 +25,7 @@ import Data.Vector (Vector) import Guide.Diff.Merge (merge) import Guide.Diff.Tokenize (tokenize) +import Guide.Utils (makeClassWithLenses) import qualified Data.Patch as PV import qualified Data.Vector as V @@ -45,9 +46,7 @@ data DiffChunk | Plain Text -- ^ This part should be rendered as not modified deriving (Eq, Show) -flip makeLensesFor ''Diff - [ ("diffContextAbove", "_diffContextAbove") - , ("diffContextBelow", "_diffContextBelow") ] +makeClassWithLenses ''Diff diff :: Text -- ^ Original text diff --git a/back/src/Guide/Handlers.hs b/back/src/Guide/Handlers.hs index e4b1439..39d56cb 100644 --- a/back/src/Guide/Handlers.hs +++ b/back/src/Guide/Handlers.hs @@ -101,7 +101,7 @@ setMethods = do addEdit edit do (edit, _) <- dbUpdate (SetCategoryStatus catId status') addEdit edit - do oldEnabledSections <- view enabledSections <$> dbQuery (GetCategory catId) + do oldEnabledSections <- categoryEnabledSections <$> dbQuery (GetCategory catId) let newEnabledSections = S.fromList . concat $ [ [ItemProsConsSection | prosConsEnabled'] , [ItemEcosystemSection | ecosystemEnabled'] @@ -118,7 +118,7 @@ setMethods = do Spock.post (setRoute categoryVar "notes") $ \catId -> do original <- param' "original" content' <- param' "content" - modified <- view (notes.mdSource) <$> dbQuery (GetCategory catId) + modified <- markdownBlockSource . categoryNotes <$> dbQuery (GetCategory catId) if modified == original then do (edit, category) <- dbUpdate (SetCategoryNotes catId content') @@ -161,7 +161,7 @@ setMethods = do Spock.post (setRoute itemVar "description") $ \itemId -> do original <- param' "original" content' <- param' "content" - modified <- view (summary.mdSource) <$> dbQuery (GetItem itemId) + modified <- markdownBlockSource . itemSummary <$> dbQuery (GetItem itemId) if modified == original then do (edit, item) <- dbUpdate (SetItemSummary itemId content') @@ -176,7 +176,7 @@ setMethods = do Spock.post (setRoute itemVar "ecosystem") $ \itemId -> do original <- param' "original" content' <- param' "content" - modified <- view (ecosystem.mdSource) <$> dbQuery (GetItem itemId) + modified <- markdownBlockSource . itemEcosystem <$> dbQuery (GetItem itemId) if modified == original then do (edit, item) <- dbUpdate (SetItemEcosystem itemId content') @@ -191,7 +191,7 @@ setMethods = do Spock.post (setRoute itemVar "notes") $ \itemId -> do original <- param' "original" content' <- param' "content" - modified <- view (notes.mdSource) <$> dbQuery (GetItem itemId) + modified <- markdownTreeSource . itemNotes <$> dbQuery (GetItem itemId) if modified == original then do (edit, item) <- dbUpdate (SetItemNotes itemId content') @@ -207,7 +207,8 @@ setMethods = do Spock.post (setRoute itemVar traitVar) $ \itemId traitId -> do original <- param' "original" content' <- param' "content" - modified <- view (content.mdSource) <$> dbQuery (GetTrait itemId traitId) + modified <- markdownInlineSource . traitContent <$> + dbQuery (GetTrait itemId traitId) if modified == original then do (edit, trait) <- dbUpdate (SetTraitContent itemId traitId content') @@ -286,18 +287,18 @@ otherMethods = do -- # Feeds -- TODO: this link shouldn't be absolute [absolute-links] - baseUrl <- (// "haskell") . _baseUrl <$> getConfig + baseUrl <- (// "haskell") . baseUrl <$> getConfig -- Feed for items in a category Spock.get (feedRoute categoryVar) $ \catId -> do category <- dbQuery (GetCategory catId) - let sortedItems = sortBy (flip cmp) (category^.items) - where cmp = comparing (^.created) <> comparing (^.uid) + let sortedItems = sortBy (flip cmp) (categoryItems category) + where cmp = comparing itemCreated <> comparing itemUid let route = "feed" categoryVar - let feedUrl = baseUrl // Spock.renderRoute route (category^.uid) - feedTitle = Atom.TextString (category^.title <> " – Haskell – Aelve Guide") + let feedUrl = baseUrl // Spock.renderRoute route (categoryUid category) + feedTitle = Atom.TextString (categoryTitle category <> " – Haskell – Aelve Guide") feedLastUpdate = case sortedItems of - item:_ -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created) + item:_ -> Feed.toFeedDateStringUTC Feed.AtomKind (itemCreated item) _ -> "" let feedBase = Atom.nullFeed feedUrl feedTitle (toText feedLastUpdate) entries <- liftIO $ mapM (itemToFeedEntry baseUrl category) sortedItems @@ -364,8 +365,8 @@ itemToFeedEntry baseUrl category item = do Atom.entryContent = Just (Atom.HTMLContent (toText entryContent)) } where entryLink = baseUrl // - format "{}#item-{}" (categorySlug category) (item^.uid) + format "{}#item-{}" (categorySlug category) (itemUid item) entryBase = Atom.nullEntry - (uidToText (item^.uid)) - (Atom.TextString (item^.name)) - (toText (Feed.toFeedDateStringUTC Feed.AtomKind (item^.created))) + (uidToText (itemUid item)) + (Atom.TextString (itemName item)) + (toText (Feed.toFeedDateStringUTC Feed.AtomKind (itemCreated item))) diff --git a/back/src/Guide/Logger/Run.hs b/back/src/Guide/Logger/Run.hs index 24c6a55..5c8d6c3 100644 --- a/back/src/Guide/Logger/Run.hs +++ b/back/src/Guide/Logger/Run.hs @@ -41,11 +41,11 @@ withLogger :: Config -> (Logger -> IO ()) -> IO () withLogger Config{..} act = do logLvlEnv <- lookupEnv "LOG_LEVEL" let logLvl = fromMaybe Debug (readMaybe =<< logLvlEnv) - mbWithFile _logToFile AppendMode $ \logFileHandle -> do + mbWithFile logToFile AppendMode $ \logFileHandle -> do let logHandler logLine@(Di.Core.Log _ lvl _ _) = when (lvl >= logLvl) $ do - let formattedLogLine = showLogLine _logTimeFormat logLine - when _logToStderr $ sayErr formattedLogLine + let formattedLogLine = showLogLine logTimeFormat logLine + when logToStderr $ sayErr formattedLogLine whenJust logFileHandle $ \h -> hSay h formattedLogLine Di.Core.new logHandler $ \logger -> act logger `catch` \(e :: SomeException) -> diff --git a/back/src/Guide/Main.hs b/back/src/Guide/Main.hs index ad9caf6..5065933 100644 --- a/back/src/Guide/Main.hs +++ b/back/src/Guide/Main.hs @@ -160,7 +160,7 @@ mainWith config@Config{..} = withLogger config $ \logger -> do ekgId <- newIORef Nothing workFinished <- newEmptyMVar let finishWork = do - when _ekg $ do + when ekg $ do -- Killing EKG has to be done last, because of -- logDebugIO logger "Killing EKG" @@ -200,19 +200,19 @@ ekgMetrics -> IORef (Maybe ThreadId) -> IO (Maybe EKG.WaiMetrics) ekgMetrics logger Config{..} db ekgId = - if _ekg + if ekg then do - ekg <- do - logDebugIO logger $ format "EKG is running on port {}" _portEkg - EKG.forkServer "localhost" _portEkg - writeIORef ekgId (Just (EKG.serverThreadId ekg)) - waiMetrics <- EKG.registerWaiMetrics (EKG.serverMetricStore ekg) - categoryGauge <- EKG.getGauge "db.categories" ekg - itemGauge <- EKG.getGauge "db.items" ekg + ekgServer <- do + logDebugIO logger $ format "EKG is running on port {}" portEkg + EKG.forkServer "localhost" portEkg + writeIORef ekgId (Just (EKG.serverThreadId ekgServer)) + waiMetrics <- EKG.registerWaiMetrics (EKG.serverMetricStore ekgServer) + categoryGauge <- EKG.getGauge "db.categories" ekgServer + itemGauge <- EKG.getGauge "db.items" ekgServer void $ async $ forever $ do globalState <- Acid.query db GetGlobalState - let allCategories = globalState^.categories - let allItems = allCategories^..each.items.each + let allCategories = categories globalState + let allItems = allCategories ^.. each . _categoryItems . each EKG.Gauge.set categoryGauge (fromIntegral (length allCategories)) EKG.Gauge.set itemGauge (fromIntegral (length allItems)) threadDelay (1000000 * 60) @@ -242,8 +242,8 @@ runOldServer logger config@Config{..} db mWaiMetrics = do spc_maxRequestSize = Just (1024*1024), spc_csrfProtection = True, spc_sessionCfg = sessionCfg } - logDebugIO logger $ format "Spock is running on port {}" _portMain - runSpockNoBanner _portMain $ spock spockConfig $ guideApp mWaiMetrics + logDebugIO logger $ format "Spock is running on port {}" portMain + runSpockNoBanner portMain $ spock spockConfig $ guideApp mWaiMetrics -- TODO: Fix indentation after rebasing. guideApp :: Maybe EKG.WaiMetrics -> GuideApp () @@ -350,7 +350,7 @@ loginAction = do LoginUser loginEmail (toByteString loginUserPassword) case loginAttempt of Right user -> do - modifySession (sessionUserID ?~ (user ^. userID)) + modifySession (sessionUserID ?~ userID user) Spock.redirect "/" -- TODO: *properly* show error message/validation of input Left err -> do @@ -377,7 +377,7 @@ signupAction = do success <- dbUpdate $ CreateUser user if success then do - modifySession (sessionUserID ?~ (user ^. userID)) + modifySession (sessionUserID ?~ userID user) Spock.redirect "" else do formHtml <- protectForm registerFormView v @@ -398,7 +398,7 @@ adminHook :: ListContains n User xs => GuideAction (HVect xs) (HVect (IsAdmin ': adminHook = do oldCtx <- getContext let user = findFirst oldCtx - if user ^. userIsAdmin + if userIsAdmin user then return (IsAdmin :&: oldCtx) else Spock.text "Not authorized." @@ -435,6 +435,6 @@ installTerminationCatcher thread = void $ do createAdminUser :: GuideApp () createAdminUser = do dbUpdate DeleteAllUsers - pass <- toByteString . _adminPassword <$> getConfig + pass <- toByteString . adminPassword <$> getConfig user <- makeUser "admin" "admin@guide.aelve.com" pass - void $ dbUpdate $ CreateUser (user & userIsAdmin .~ True) + void $ dbUpdate $ CreateUser (user & _userIsAdmin .~ True) diff --git a/back/src/Guide/Markdown.hs b/back/src/Guide/Markdown.hs index 3a62ed0..97e3240 100644 --- a/back/src/Guide/Markdown.hs +++ b/back/src/Guide/Markdown.hs @@ -13,18 +13,13 @@ module Guide.Markdown ( -- * Types MarkdownInline(..), + MarkdownInlineLenses(..), MarkdownBlock(..), + MarkdownBlockLenses(..), MarkdownTree(..), + MarkdownTreeLenses(..), Heading(..), - -- * Lenses - mdHtml, - mdSource, - mdMarkdown, - mdIdPrefix, - mdTree, - mdTOC, - -- * Converting text to Markdown toMarkdownInline, toMarkdownBlock, @@ -32,7 +27,6 @@ module Guide.Markdown -- * Misc renderMD, - markdownNull, extractPreface, ) where @@ -66,33 +60,33 @@ import qualified Data.Text as T data MarkdownInline = MarkdownInline { - markdownInlineMdSource :: Text, - markdownInlineMdHtml :: ByteString, - markdownInlineMdMarkdown :: ![MD.Node] } + markdownInlineSource :: Text, + markdownInlineHtml :: ByteString, + markdownInlineMarkdown :: ![MD.Node] } deriving (Generic, Data, Eq) data MarkdownBlock = MarkdownBlock { - markdownBlockMdSource :: Text, - markdownBlockMdHtml :: ByteString, - markdownBlockMdMarkdown :: ![MD.Node] } + markdownBlockSource :: Text, + markdownBlockHtml :: ByteString, + markdownBlockMarkdown :: ![MD.Node] } deriving (Generic, Data) data MarkdownTree = MarkdownTree { - markdownTreeMdSource :: Text, - markdownTreeMdTree :: !(Document Text ByteString), - markdownTreeMdIdPrefix :: Text, - markdownTreeMdTOC :: Forest Heading } + markdownTreeSource :: Text, + markdownTreeStructure :: !(Document Text ByteString), + markdownTreeIdPrefix :: Text, + markdownTreeTOC :: Forest Heading } deriving (Generic, Data) -- | Table-of-contents heading data Heading = Heading - { headingMd :: MarkdownInline + { headingMarkdown :: MarkdownInline , headingSlug :: Text } deriving (Generic, Data, Eq) -makeFields ''MarkdownInline -makeFields ''MarkdownBlock -makeFields ''MarkdownTree +makeClassWithLenses ''MarkdownInline +makeClassWithLenses ''MarkdownBlock +makeClassWithLenses ''MarkdownTree parseMD :: Text -> [MD.Node] parseMD s = @@ -149,16 +143,17 @@ stringify = T.concat . map go -- | Extract everything before the first heading. -- --- Note that if you render 'mdSource' 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. +-- Note that if you render 'markdownBlockSource' of the produced Markdown +-- block, it won't necessarily parse into 'markdownBlockHtml' 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 +extractPreface = mkBlock . preface . markdownTreeStructure where mkBlock x = MarkdownBlock { - markdownBlockMdSource = getSource x, - markdownBlockMdHtml = renderMD (stripSource x), - markdownBlockMdMarkdown = stripSource x } + markdownBlockSource = getSource x, + markdownBlockHtml = renderMD (stripSource x), + markdownBlockMarkdown = stripSource x } -- | Flatten Markdown by concatenating all block elements. extractInlines :: [MD.Node] -> [MD.Node] @@ -241,28 +236,28 @@ parseLink = either (Left . show) Right . parse p "" toMarkdownInline :: Text -> MarkdownInline toMarkdownInline s = MarkdownInline { - markdownInlineMdSource = s, - markdownInlineMdHtml = html, - markdownInlineMdMarkdown = inlines } + markdownInlineSource = s, + markdownInlineHtml = html, + markdownInlineMarkdown = inlines } where inlines = extractInlines (parseMD s) html = renderMD inlines toMarkdownBlock :: Text -> MarkdownBlock toMarkdownBlock s = MarkdownBlock { - markdownBlockMdSource = s, - markdownBlockMdHtml = html, - markdownBlockMdMarkdown = doc } + markdownBlockSource = s, + markdownBlockHtml = html, + markdownBlockMarkdown = doc } where doc = parseMD s html = renderMD doc toMarkdownTree :: Text -> Text -> MarkdownTree toMarkdownTree idPrefix s = MarkdownTree { - markdownTreeMdSource = s, - markdownTreeMdIdPrefix = idPrefix, - markdownTreeMdTree = tree, - markdownTreeMdTOC = toc } + markdownTreeSource = s, + markdownTreeIdPrefix = idPrefix, + markdownTreeStructure = tree, + markdownTreeTOC = toc } where blocks :: [MD.Node] blocks = parseMD s @@ -281,9 +276,9 @@ toMarkdownTree idPrefix s = MarkdownTree { nodesToMdInline :: WithSource [MD.Node] -> MarkdownInline nodesToMdInline (WithSource src nodes) = MarkdownInline - { markdownInlineMdSource = src - , markdownInlineMdHtml = html - , markdownInlineMdMarkdown = inlines + { markdownInlineSource = src + , markdownInlineHtml = html + , markdownInlineMarkdown = inlines } where inlines = extractInlines nodes @@ -310,34 +305,34 @@ slugifyDocument slugify doc = doc { return sec{headingAnn = slug} instance Show MarkdownInline where - show = show . view mdSource + show = show . markdownInlineSource instance Show MarkdownBlock where - show = show . view mdSource + show = show . markdownBlockSource instance Show MarkdownTree where - show = show . view mdSource + show = show . markdownTreeSource deriving instance Show Heading instance A.ToJSON MarkdownInline where toJSON md = A.object [ - "text" A..= (md^.mdSource), - "html" A..= toText (md^.mdHtml) ] + "text" A..= markdownInlineSource md, + "html" A..= toText (markdownInlineHtml md) ] instance A.ToJSON MarkdownBlock where toJSON md = A.object [ - "text" A..= (md^.mdSource), - "html" A..= toText (md^.mdHtml) ] + "text" A..= markdownBlockSource md, + "html" A..= toText (markdownBlockHtml md) ] instance A.ToJSON MarkdownTree where toJSON md = A.object [ - "text" A..= (md^.mdSource) ] + "text" A..= markdownTreeSource md ] instance ToHtml MarkdownInline where toHtmlRaw = toHtml - toHtml = toHtmlRaw . view mdHtml + toHtml = toHtmlRaw . markdownInlineHtml instance ToHtml MarkdownBlock where toHtmlRaw = toHtml - toHtml = toHtmlRaw . view mdHtml + toHtml = toHtmlRaw . markdownBlockHtml instance ToHtml MarkdownTree where toHtmlRaw = toHtml - toHtml = toHtmlRaw . renderDoc . view mdTree + toHtml = toHtmlRaw . renderDoc . markdownTreeStructure where renderDoc Document{..} = BS.concat $ prefaceAnn : @@ -356,22 +351,18 @@ instance ToHtml MarkdownTree where instance SafeCopy MarkdownInline where version = 0 kind = base - putCopy = contain . safePut . view mdSource + putCopy = contain . safePut . markdownInlineSource getCopy = contain $ toMarkdownInline <$> safeGet instance SafeCopy MarkdownBlock where version = 0 kind = base - putCopy = contain . safePut . view mdSource + putCopy = contain . safePut . markdownBlockSource getCopy = contain $ toMarkdownBlock <$> safeGet instance SafeCopy MarkdownTree where version = 0 kind = base putCopy md = contain $ do - safePut (md ^. mdIdPrefix) - safePut (md ^. mdSource) + safePut (markdownTreeIdPrefix md) + safePut (markdownTreeSource md) getCopy = contain $ toMarkdownTree <$> safeGet <*> safeGet - --- | Is a piece of Markdown empty? -markdownNull :: HasMdSource a Text => a -> Bool -markdownNull = T.null . view mdSource diff --git a/back/src/Guide/Matomo.hs b/back/src/Guide/Matomo.hs index cac59a2..f965ab6 100644 --- a/back/src/Guide/Matomo.hs +++ b/back/src/Guide/Matomo.hs @@ -41,7 +41,7 @@ data Matomo = Matomo postMatomo :: Matomo -> Guider () postMatomo Matomo{..} = push "postMatomo" $ do Context Config{..} _ _ <- ask - whenJust _matomoLink $ \matomo -> liftIO $ + whenJust matomoLink $ \matomo -> liftIO $ void $ async $ do manager <- getGlobalManager req <- setQueryString diff --git a/back/src/Guide/Search.hs b/back/src/Guide/Search.hs index 97c0181..5d0b219 100644 --- a/back/src/Guide/Search.hs +++ b/back/src/Guide/Search.hs @@ -37,20 +37,20 @@ search :: Text -> GlobalState -> [SearchResult] search query gs = -- category titles sortByRank [(SRCategory cat, rank) - | cat <- gs^.categories - , let rank = match query (cat^.title) + | cat <- categories gs + , let rank = match query (categoryTitle cat) , rank > 0 ] ++ -- item names sortByRank [(SRItem cat item, rank) - | cat <- gs^.categories - , item <- cat^.items - , let rank = match query (item^.name) + | cat <- categories gs + , item <- categoryItems cat + , let rank = match query (itemName item) , rank > 0 ] ++ -- item ecosystems sortByRank [(SRItemEcosystem cat item, rank) - | cat <- gs^.categories - , item <- cat^.items - , let rank = match query (item^.ecosystem.mdSource) + | cat <- categories gs + , item <- categoryItems cat + , let rank = match query (markdownBlockSource (itemEcosystem item)) , rank > 0 ] where sortByRank :: [(a, Int)] -> [a] diff --git a/back/src/Guide/ServerStuff.hs b/back/src/Guide/ServerStuff.hs index 47fb90a..abe1b86 100644 --- a/back/src/Guide/ServerStuff.hs +++ b/back/src/Guide/ServerStuff.hs @@ -108,64 +108,64 @@ undoEdit (Edit'AddPro itemId traitId _) = do undoEdit (Edit'AddCon itemId traitId _) = do void <$> dbUpdate (DeleteTrait itemId traitId) undoEdit (Edit'SetCategoryTitle catId old new) = do - now <- view title <$> dbQuery (GetCategory catId) + now <- categoryTitle <$> dbQuery (GetCategory catId) if now /= new then return (Left "title has been changed further") else Right () <$ dbUpdate (SetCategoryTitle catId old) undoEdit (Edit'SetCategoryGroup catId old new) = do - now <- view group_ <$> dbQuery (GetCategory catId) + now <- categoryGroup <$> dbQuery (GetCategory catId) if now /= new then return (Left "group has been changed further") else Right () <$ dbUpdate (SetCategoryGroup catId old) undoEdit (Edit'SetCategoryStatus catId old new) = do - now <- view status <$> dbQuery (GetCategory catId) + now <- categoryStatus <$> dbQuery (GetCategory catId) if now /= new then return (Left "status has been changed further") else Right () <$ dbUpdate (SetCategoryStatus catId old) undoEdit (Edit'ChangeCategoryEnabledSections catId toEnable toDisable) = do - enabledNow <- view enabledSections <$> dbQuery (GetCategory catId) + enabledNow <- categoryEnabledSections <$> dbQuery (GetCategory catId) if any (`elem` enabledNow) toDisable || any (`notElem` enabledNow) toEnable then return (Left "enabled-sections has been changed further") else Right () <$ dbUpdate (ChangeCategoryEnabledSections catId toDisable toEnable) undoEdit (Edit'SetCategoryNotes catId old new) = do - now <- view (notes.mdSource) <$> dbQuery (GetCategory catId) + now <- markdownBlockSource . categoryNotes <$> dbQuery (GetCategory catId) if now /= new then return (Left "notes have been changed further") else Right () <$ dbUpdate (SetCategoryNotes catId old) undoEdit (Edit'SetItemName itemId old new) = do - now <- view name <$> dbQuery (GetItem itemId) + now <- itemName <$> dbQuery (GetItem itemId) if now /= new then return (Left "name has been changed further") else Right () <$ dbUpdate (SetItemName itemId old) undoEdit (Edit'SetItemLink itemId old new) = do - now <- view link <$> dbQuery (GetItem itemId) + now <- itemLink <$> dbQuery (GetItem itemId) if now /= new then return (Left "link has been changed further") else Right () <$ dbUpdate (SetItemLink itemId old) undoEdit (Edit'SetItemGroup _ _ _) = do return (Left "groups are not supported anymore") undoEdit (Edit'SetItemHackage itemId old new) = do - now <- view hackage <$> dbQuery (GetItem itemId) + now <- itemHackage <$> dbQuery (GetItem itemId) if now /= new then return (Left "Hackage name has been changed further") else Right () <$ dbUpdate (SetItemHackage itemId old) undoEdit (Edit'SetItemSummary itemId old new) = do - now <- view (summary.mdSource) <$> dbQuery (GetItem itemId) + now <- markdownBlockSource . itemSummary <$> dbQuery (GetItem itemId) if now /= new then return (Left "description has been changed further") else Right () <$ dbUpdate (SetItemSummary itemId old) undoEdit (Edit'SetItemNotes itemId old new) = do - now <- view (notes.mdSource) <$> dbQuery (GetItem itemId) + now <- markdownTreeSource . itemNotes <$> dbQuery (GetItem itemId) if now /= new then return (Left "notes have been changed further") else Right () <$ dbUpdate (SetItemNotes itemId old) undoEdit (Edit'SetItemEcosystem itemId old new) = do - now <- view (ecosystem.mdSource) <$> dbQuery (GetItem itemId) + now <- markdownBlockSource . itemEcosystem <$> dbQuery (GetItem itemId) if now /= new then return (Left "ecosystem has been changed further") else Right () <$ dbUpdate (SetItemEcosystem itemId old) undoEdit (Edit'SetTraitContent itemId traitId old new) = do - now <- view (content.mdSource) <$> dbQuery (GetTrait itemId traitId) + now <- markdownInlineSource . traitContent <$> dbQuery (GetTrait itemId traitId) if now /= new then return (Left "trait has been changed further") else Right () <$ dbUpdate (SetTraitContent itemId traitId old) diff --git a/back/src/Guide/State.hs b/back/src/Guide/State.hs index 0f88591..2794889 100644 --- a/back/src/Guide/State.hs +++ b/back/src/Guide/State.hs @@ -19,11 +19,8 @@ module Guide.State -- * type of global state GlobalState(..), - categories, - categoriesDeleted, - pendingEdits, - editIdCounter, - findCategoryByItem, + GlobalStateLenses(..), + findCategoryByItem, emptyState, -- * acid-state methods @@ -180,42 +177,42 @@ Guide.hs emptyState :: GlobalState emptyState = GlobalState { - _categories = [], - _categoriesDeleted = [], - _pendingEdits = [], - _editIdCounter = 0, - _sessionStore = M.empty, - _users = M.empty, - _dirty = True } + categories = [], + categoriesDeleted = [], + pendingEdits = [], + editIdCounter = 0, + sessionStore = M.empty, + users = M.empty, + dirty = True } data GlobalState = GlobalState { - _categories :: [Category], - _categoriesDeleted :: [Category], + categories :: [Category], + categoriesDeleted :: [Category], -- | Pending edits, newest first - _pendingEdits :: [(Edit, EditDetails)], + pendingEdits :: [(Edit, EditDetails)], -- | ID of next edit that will be made - _editIdCounter :: Int, + editIdCounter :: Int, -- | Sessions - _sessionStore :: Map SessionId GuideSession, + sessionStore :: Map SessionId GuideSession, -- | Users - _users :: Map (Uid User) User, + users :: Map (Uid User) User, -- | The dirty bit (needed to choose whether to make a checkpoint or not) - _dirty :: Bool } + dirty :: Bool } deriving (Show) deriveSafeCopySorted 9 'extension ''GlobalState -makeLenses ''GlobalState +makeClassWithLenses ''GlobalState changelog ''GlobalState (Current 9, Past 8) [ -- TODO: it's silly that we have to reference 'Action' and keep it in the -- codebase even though we have no use for 'Action' anymore - Removed "_actions" [t|[(Action, ActionDetails)]|] + Removed "actions" [t|[(Action, ActionDetails)]|] ] deriveSafeCopySorted 8 'extension ''GlobalState_v8 changelog ''GlobalState (Past 8, Past 7) [ - Added "_sessionStore" [hs|M.empty|], - Added "_users" [hs|M.empty|] + Added "sessionStore" [hs|M.empty|], + Added "users" [hs|M.empty|] ] deriveSafeCopySorted 7 'base ''GlobalState_v7 @@ -227,8 +224,8 @@ traitById traitId = singular $ maybeTraitById :: Uid Trait -> Traversal' Item Trait maybeTraitById traitId = - (pros.each . filtered (hasUid traitId)) `failing` - (cons.each . filtered (hasUid traitId)) + (_itemPros . each . filtered ((== traitId) . traitUid)) `failing` + (_itemCons . each . filtered ((== traitId) . traitUid)) categoryById :: Uid Category -> Lens' GlobalState Category categoryById catId = singular $ @@ -237,7 +234,7 @@ categoryById catId = singular $ toString (uidToText catId)) maybeCategoryById :: Uid Category -> Traversal' GlobalState Category -maybeCategoryById catId = categories.each . filtered (hasUid catId) +maybeCategoryById catId = _categories . each . filtered ((== catId) . categoryUid) itemById :: Uid Item -> Lens' GlobalState Item itemById itemId = singular $ @@ -246,15 +243,16 @@ itemById itemId = singular $ toString (uidToText itemId)) maybeItemById :: Uid Item -> Traversal' GlobalState Item -maybeItemById itemId = categories.each . items.each . filtered (hasUid itemId) +maybeItemById itemId = + _categories . each . _categoryItems . each . filtered ((== itemId) . itemUid) findCategoryByItem :: Uid Item -> GlobalState -> Category findCategoryByItem itemId s = - fromMaybe (error err) (find hasItem (s^.categories)) + fromMaybe (error err) (find hasItem (categories s)) where err = "findCategoryByItem: couldn't find category with item with uid " ++ toString (uidToText itemId) - hasItem category = itemId `elem` (category^..items.each.uid) + hasItem category = itemId `elem` (category ^.. _categoryItems . each . _itemUid) -- | 'PublicDB' contains all safe data from 'GlobalState'. -- Difference from 'GlobalState': @@ -277,27 +275,30 @@ deriveSafeCopySorted 1 'base ''PublicDB -- | Converts 'GlobalState' to 'PublicDB' type stripping private data. toPublicDB :: GlobalState -> PublicDB -toPublicDB GlobalState{..} = +toPublicDB $(fields 'GlobalState) = PublicDB { - publicCategories = _categories, - publicCategoriesDeleted = _categoriesDeleted, - publicPendingEdits = _pendingEdits, - publicEditIdCounter = _editIdCounter, - publicUsers = fmap userToPublic _users + publicCategories = categories, + publicCategoriesDeleted = categoriesDeleted, + publicPendingEdits = pendingEdits, + publicEditIdCounter = editIdCounter, + publicUsers = fmap userToPublic users } + where + -- Ignored fields + _ = (dirty, sessionStore) -- | Converts 'PublicDB' to 'GlobalState' type filling in non-existing data with -- default values. fromPublicDB :: PublicDB -> GlobalState -fromPublicDB PublicDB{..} = +fromPublicDB $(fields 'PublicDB) = GlobalState { - _categories = publicCategories, - _categoriesDeleted = publicCategoriesDeleted, - _pendingEdits = publicPendingEdits, - _editIdCounter = publicEditIdCounter, - _sessionStore = M.empty, - _users = fmap publicUserToUser publicUsers, - _dirty = True + categories = publicCategories, + categoriesDeleted = publicCategoriesDeleted, + pendingEdits = publicPendingEdits, + editIdCounter = publicEditIdCounter, + sessionStore = M.empty, + users = fmap publicUserToUser publicUsers, + dirty = True } -- get @@ -306,7 +307,7 @@ getGlobalState :: Acid.Query GlobalState GlobalState getGlobalState = view id getCategories :: Acid.Query GlobalState [Category] -getCategories = view categories +getCategories = view _categories getCategory :: Uid Category -> Acid.Query GlobalState Category getCategory uid' = view (categoryById uid') @@ -342,19 +343,19 @@ addCategory -> Acid.Update GlobalState (Edit, Category) addCategory catId title' group' created' = do let newCategory = Category { - _categoryUid = catId, - _categoryTitle = title', - _categoryGroup_ = group', - _categoryEnabledSections = S.fromList [ + categoryUid = catId, + categoryTitle = title', + categoryGroup = group', + categoryEnabledSections = S.fromList [ ItemProsConsSection, ItemEcosystemSection, ItemNotesSection ], - _categoryCreated = created', - _categoryStatus = CategoryStub, - _categoryNotes = toMarkdownBlock "", - _categoryItems = [], - _categoryItemsDeleted = [] } - categories %= (newCategory :) + categoryCreated = created', + categoryStatus = CategoryStub, + categoryNotes = toMarkdownBlock "", + categoryItems = [], + categoryItemsDeleted = [] } + _categories %= (newCategory :) let edit = Edit'AddCategory catId title' group' return (edit, newCategory) @@ -366,20 +367,20 @@ addItem -> Acid.Update GlobalState (Edit, Item) addItem catId itemId name' created' = do let newItem = Item { - _itemUid = itemId, - _itemName = name', - _itemCreated = created', - _itemHackage = Nothing, - _itemSummary = toMarkdownBlock "", - _itemPros = [], - _itemProsDeleted = [], - _itemCons = [], - _itemConsDeleted = [], - _itemEcosystem = toMarkdownBlock "", - _itemNotes = let pref = "item-notes-" <> uidToText itemId <> "-" - in toMarkdownTree pref "", - _itemLink = Nothing} - categoryById catId . items %= (++ [newItem]) + itemUid = itemId, + itemName = name', + itemCreated = created', + itemHackage = Nothing, + itemSummary = toMarkdownBlock "", + itemPros = [], + itemProsDeleted = [], + itemCons = [], + itemConsDeleted = [], + itemEcosystem = toMarkdownBlock "", + itemNotes = let pref = "item-notes-" <> uidToText itemId <> "-" + in toMarkdownTree pref "", + itemLink = Nothing} + categoryById catId . _categoryItems %= (++ [newItem]) let edit = Edit'AddItem catId itemId name' return (edit, newItem) @@ -390,7 +391,7 @@ addPro -> Acid.Update GlobalState (Edit, Trait) addPro itemId traitId text' = do let newTrait = Trait traitId (toMarkdownInline text') - itemById itemId . pros %= (++ [newTrait]) + itemById itemId . _itemPros %= (++ [newTrait]) let edit = Edit'AddPro itemId traitId text' return (edit, newTrait) @@ -401,7 +402,7 @@ addCon -> Acid.Update GlobalState (Edit, Trait) addCon itemId traitId text' = do let newTrait = Trait traitId (toMarkdownInline text') - itemById itemId . cons %= (++ [newTrait]) + itemById itemId . _itemCons %= (++ [newTrait]) let edit = Edit'AddCon itemId traitId text' return (edit, newTrait) @@ -417,25 +418,25 @@ setGlobalState = (id .=) setCategoryTitle :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category) setCategoryTitle catId title' = do - oldTitle <- categoryById catId . title <<.= title' + oldTitle <- categoryById catId . _categoryTitle <<.= title' let edit = Edit'SetCategoryTitle catId oldTitle title' (edit,) <$> use (categoryById catId) setCategoryGroup :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category) setCategoryGroup catId group' = do - oldGroup <- categoryById catId . group_ <<.= group' + oldGroup <- categoryById catId . _categoryGroup <<.= group' let edit = Edit'SetCategoryGroup catId oldGroup group' (edit,) <$> use (categoryById catId) setCategoryNotes :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category) setCategoryNotes catId notes' = do - oldNotes <- categoryById catId . notes <<.= toMarkdownBlock notes' - let edit = Edit'SetCategoryNotes catId (oldNotes ^. mdSource) notes' + oldNotes <- categoryById catId . _categoryNotes <<.= toMarkdownBlock notes' + let edit = Edit'SetCategoryNotes catId (markdownBlockSource oldNotes) notes' (edit,) <$> use (categoryById catId) setCategoryStatus :: Uid Category -> CategoryStatus -> Acid.Update GlobalState (Edit, Category) setCategoryStatus catId status' = do - oldStatus <- categoryById catId . status <<.= status' + oldStatus <- categoryById catId . _categoryStatus <<.= status' let edit = Edit'SetCategoryStatus catId oldStatus status' (edit,) <$> use (categoryById catId) @@ -445,59 +446,57 @@ changeCategoryEnabledSections -> Set ItemSection -- ^ Sections to disable -> Acid.Update GlobalState (Edit, Category) changeCategoryEnabledSections catId toEnable toDisable = do - categoryById catId . enabledSections %= \sections -> + categoryById catId . _categoryEnabledSections %= \sections -> (sections <> toEnable) S.\\ toDisable let edit = Edit'ChangeCategoryEnabledSections catId toEnable toDisable (edit,) <$> use (categoryById catId) setItemName :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item) setItemName itemId name' = do - oldName <- itemById itemId . name <<.= name' + oldName <- itemById itemId . _itemName <<.= name' let edit = Edit'SetItemName itemId oldName name' (edit,) <$> use (itemById itemId) setItemLink :: Uid Item -> Maybe Url -> Acid.Update GlobalState (Edit, Item) setItemLink itemId link' = do - oldLink <- itemById itemId . link <<.= link' + oldLink <- itemById itemId . _itemLink <<.= link' let edit = Edit'SetItemLink itemId oldLink link' (edit,) <$> use (itemById itemId) setItemHackage :: Uid Item -> Maybe Text -> Acid.Update GlobalState (Edit, Item) setItemHackage itemId hackage' = do - oldName <- itemById itemId . hackage <<.= hackage' + oldName <- itemById itemId . _itemHackage <<.= hackage' let edit = Edit'SetItemHackage itemId oldName hackage' (edit,) <$> use (itemById itemId) setItemSummary :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item) setItemSummary itemId description' = do - oldDescr <- itemById itemId . summary <<.= + oldDescr <- itemById itemId . _itemSummary <<.= toMarkdownBlock description' let edit = Edit'SetItemSummary itemId - (oldDescr ^. mdSource) description' + (markdownBlockSource oldDescr) description' (edit,) <$> use (itemById itemId) setItemNotes :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item) setItemNotes itemId notes' = do let pref = "item-notes-" <> uidToText itemId <> "-" - oldNotes <- itemById itemId . notes <<.= - toMarkdownTree pref notes' - let edit = Edit'SetItemNotes itemId (oldNotes ^. mdSource) notes' + oldNotes <- itemById itemId . _itemNotes <<.= toMarkdownTree pref notes' + let edit = Edit'SetItemNotes itemId (markdownTreeSource oldNotes) notes' (edit,) <$> use (itemById itemId) setItemEcosystem :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item) setItemEcosystem itemId ecosystem' = do - oldEcosystem <- itemById itemId . ecosystem <<.= - toMarkdownBlock ecosystem' + oldEcosystem <- itemById itemId . _itemEcosystem <<.= toMarkdownBlock ecosystem' let edit = Edit'SetItemEcosystem itemId - (oldEcosystem ^. mdSource) ecosystem' + (markdownBlockSource oldEcosystem) ecosystem' (edit,) <$> use (itemById itemId) setTraitContent :: Uid Item -> Uid Trait -> Text -> Acid.Update GlobalState (Edit, Trait) setTraitContent itemId traitId content' = do - oldContent <- itemById itemId . traitById traitId . content <<.= + oldContent <- itemById itemId . traitById traitId . _traitContent <<.= toMarkdownInline content' let edit = Edit'SetTraitContent itemId traitId - (oldContent ^. mdSource) content' + (markdownInlineSource oldContent) content' (edit,) <$> use (itemById itemId . traitById traitId) -- delete @@ -508,17 +507,17 @@ deleteCategory catId = do case mbCategory of Nothing -> return (Left "category not found") Just category -> do - mbCategoryPos <- findIndex (hasUid catId) <$> use categories + mbCategoryPos <- findIndex ((== catId) . categoryUid) <$> use _categories case mbCategoryPos of Nothing -> return (Left "category not found") Just categoryPos -> do - categories %= deleteAt categoryPos - categoriesDeleted %= (category:) + _categories %= deleteAt categoryPos + _categoriesDeleted %= (category:) return (Right (Edit'DeleteCategory catId categoryPos)) deleteItem :: Uid Item -> Acid.Update GlobalState (Either String Edit) deleteItem itemId = do - catId <- view uid . findCategoryByItem itemId <$> get + catId <- categoryUid . findCategoryByItem itemId <$> get let categoryLens :: Lens' GlobalState Category categoryLens = categoryById catId let itemLens :: Lens' GlobalState Item @@ -527,12 +526,12 @@ deleteItem itemId = do case mbItem of Nothing -> return (Left "item not found") Just item -> do - allItems <- use (categoryLens.items) - case findIndex (hasUid itemId) allItems of + allItems <- use (categoryLens . _categoryItems) + case findIndex ((== itemId) . itemUid) allItems of Nothing -> return (Left "item not found") Just itemPos -> do - categoryLens.items %= deleteAt itemPos - categoryLens.itemsDeleted %= (item:) + categoryLens . _categoryItems %= deleteAt itemPos + categoryLens . _categoryItemsDeleted %= (item:) return (Right (Edit'DeleteItem itemId itemPos)) deleteTrait :: Uid Item -> Uid Trait -> Acid.Update GlobalState (Either String Edit) @@ -545,27 +544,31 @@ deleteTrait itemId traitId = do Just item -> do -- Determine whether the trait is a pro or a con, and proceed -- accordingly - case (find (hasUid traitId) (item^.pros), - find (hasUid traitId) (item^.cons)) of + case (find ((== traitId) . traitUid) (itemPros item), + find ((== traitId) . traitUid) (itemCons item)) of -- It's in neither group, which means it was deleted. Do nothing. (Nothing, Nothing) -> return (Left "trait not found") -- It's a pro (Just trait, _) -> do - mbTraitPos <- findIndex (hasUid traitId) <$> use (itemLens.pros) + mbTraitPos <- + findIndex ((== traitId) . traitUid) <$> + use (itemLens . _itemPros) case mbTraitPos of Nothing -> return (Left "trait not found") Just traitPos -> do - itemLens.pros %= deleteAt traitPos - itemLens.prosDeleted %= (trait:) + itemLens . _itemPros %= deleteAt traitPos + itemLens . _itemProsDeleted %= (trait:) return (Right (Edit'DeleteTrait itemId traitId traitPos)) -- It's a con (_, Just trait) -> do - mbTraitPos <- findIndex (hasUid traitId) <$> use (itemLens.cons) + mbTraitPos <- + findIndex ((== traitId) . traitUid) <$> + use (itemLens . _itemCons) case mbTraitPos of Nothing -> return (Left "trait not found") Just traitPos -> do - itemLens.cons %= deleteAt traitPos - itemLens.consDeleted %= (trait:) + itemLens . _itemCons %= deleteAt traitPos + itemLens . _itemConsDeleted %= (trait:) return (Right (Edit'DeleteTrait itemId traitId traitPos)) -- other methods @@ -576,8 +579,8 @@ moveItem -> Acid.Update GlobalState Edit moveItem itemId up = do let move = if up then moveUp else moveDown - catId <- view uid . findCategoryByItem itemId <$> get - categoryById catId . items %= move (hasUid itemId) + catId <- categoryUid . findCategoryByItem itemId <$> get + categoryById catId . _categoryItems %= move ((== itemId) . itemUid) return (Edit'MoveItem itemId up) moveTrait @@ -590,67 +593,67 @@ moveTrait itemId traitId up = do -- The trait is only going to be present in one of the lists so let's do it -- in each list because we're too lazy to figure out whether it's a pro or -- a con - itemById itemId . pros %= move (hasUid traitId) - itemById itemId . cons %= move (hasUid traitId) + itemById itemId . _itemPros %= move ((== traitId) . traitUid) + itemById itemId . _itemCons %= move ((== traitId) . traitUid) return (Edit'MoveTrait itemId traitId up) restoreCategory :: Uid Category -> Int -> Acid.Update GlobalState (Either String ()) restoreCategory catId pos = do - deleted <- use categoriesDeleted - case find (hasUid catId) deleted of + deleted <- use _categoriesDeleted + case find ((== catId) . categoryUid) deleted of Nothing -> return (Left "category not found in deleted categories") Just category -> do - categoriesDeleted %= deleteFirst (hasUid catId) - categories %= insertOrAppend pos category + _categoriesDeleted %= deleteFirst ((== catId) . categoryUid) + _categories %= insertOrAppend pos category return (Right ()) restoreItem :: Uid Item -> Int -> Acid.Update GlobalState (Either String ()) restoreItem itemId pos = do - let ourCategory = any (hasUid itemId) . view itemsDeleted - allCategories <- use (categories <> categoriesDeleted) + let ourCategory = any ((== itemId) . itemUid) . categoryItemsDeleted + allCategories <- use (_categories <> _categoriesDeleted) case find ourCategory allCategories of Nothing -> return (Left "item not found in deleted items") Just category -> do - let item = fromJust (find (hasUid itemId) (category^.itemsDeleted)) + let item = fromJust (find ((== itemId) . itemUid) (categoryItemsDeleted category)) let category' = category - & itemsDeleted %~ deleteFirst (hasUid itemId) - & items %~ insertOrAppend pos item - categories . each . filtered ourCategory .= category' - categoriesDeleted . each . filtered ourCategory .= category' + & _categoryItemsDeleted %~ deleteFirst ((== itemId) . itemUid) + & _categoryItems %~ insertOrAppend pos item + _categories . each . filtered ourCategory .= category' + _categoriesDeleted . each . filtered ourCategory .= category' return (Right ()) restoreTrait :: Uid Item -> Uid Trait -> Int -> Acid.Update GlobalState (Either String ()) restoreTrait itemId traitId pos = do - let getItems = view (items <> itemsDeleted) - ourCategory = any (hasUid itemId) . getItems - allCategories <- use (categories <> categoriesDeleted) + let getItems = view (_categoryItems <> _categoryItemsDeleted) + ourCategory = any ((== itemId) . itemUid) . getItems + allCategories <- use (_categories <> _categoriesDeleted) case find ourCategory allCategories of Nothing -> return (Left "item -that the trait belongs to- not found") Just category -> do - let item = fromJust (find (hasUid itemId) (getItems category)) - case (find (hasUid traitId) (item^.prosDeleted), - find (hasUid traitId) (item^.consDeleted)) of + let item = fromJust (find ((== itemId) . itemUid) (getItems category)) + case (find ((== traitId) . traitUid) (itemProsDeleted item), + find ((== traitId) . traitUid) (itemConsDeleted item)) of (Nothing, Nothing) -> return (Left "trait not found in deleted traits") (Just trait, _) -> do let item' = item - & prosDeleted %~ deleteFirst (hasUid traitId) - & pros %~ insertOrAppend pos trait + & _itemProsDeleted %~ deleteFirst ((== traitId) . traitUid) + & _itemPros %~ insertOrAppend pos trait let category' = category - & items . each . filtered (hasUid itemId) .~ item' - & itemsDeleted . each . filtered (hasUid itemId) .~ item' - categories . each . filtered ourCategory .= category' - categoriesDeleted . each . filtered ourCategory .= category' + & _categoryItems . each . filtered ((== itemId) . itemUid) .~ item' + & _categoryItemsDeleted . each . filtered ((== itemId) . itemUid) .~ item' + _categories . each . filtered ourCategory .= category' + _categoriesDeleted . each . filtered ourCategory .= category' return (Right ()) (_, Just trait) -> do let item' = item - & consDeleted %~ deleteFirst (hasUid traitId) - & cons %~ insertOrAppend pos trait + & _itemConsDeleted %~ deleteFirst ((== traitId) . traitUid) + & _itemCons %~ insertOrAppend pos trait let category' = category - & items . each . filtered (hasUid itemId) .~ item' - & itemsDeleted . each . filtered (hasUid itemId) .~ item' - categories . each . filtered ourCategory .= category' - categoriesDeleted . each . filtered ourCategory .= category' + & _categoryItems . each . filtered ((== itemId) . itemUid) .~ item' + & _categoryItemsDeleted . each . filtered ((== itemId) . itemUid) .~ item' + _categories . each . filtered ourCategory .= category' + _categoriesDeleted . each . filtered ourCategory .= category' return (Right ()) -- TODO: maybe have a single list of traits with pro/con being signified by @@ -659,7 +662,7 @@ restoreTrait itemId traitId pos = do getEdit :: Int -> Acid.Query GlobalState (Edit, EditDetails) getEdit n = do - edits <- view pendingEdits + edits <- view _pendingEdits case find ((== n) . editId . snd) edits of Nothing -> error ("no edit with id " ++ show n) Just edit -> return edit @@ -670,7 +673,7 @@ getEdits -> Int -- ^ Id of earliest edit -> Acid.Query GlobalState [(Edit, EditDetails)] getEdits m n = - filter (\(_, d) -> n <= editId d && editId d <= m) <$> view pendingEdits + filter (\(_, d) -> n <= editId d && editId d <= m) <$> view _pendingEdits -- | The edit won't be registered if it's vacuous (see 'isVacuousEdit'). registerEdit @@ -679,21 +682,21 @@ registerEdit -> UTCTime -> Acid.Update GlobalState () registerEdit ed ip date = do - id' <- use editIdCounter + id' <- use _editIdCounter let details = EditDetails { editIP = ip, editDate = date, editId = id' } - pendingEdits %= ((ed, details):) - editIdCounter += 1 + _pendingEdits %= ((ed, details):) + _editIdCounter += 1 removePendingEdit :: Int -> Acid.Update GlobalState (Edit, EditDetails) removePendingEdit n = do - edits <- use pendingEdits + edits <- use _pendingEdits case find ((== n) . editId . snd) edits of Nothing -> error ("no edit with id " ++ show n) Just edit -> do - pendingEdits %= deleteFirst ((== n) . editId . snd) + _pendingEdits %= deleteFirst ((== n) . editId . snd) return edit removePendingEdits @@ -701,51 +704,51 @@ removePendingEdits -> Int -- ^ Id of earliest edit -> Acid.Update GlobalState () removePendingEdits m n = do - pendingEdits %= filter (\(_, d) -> editId d < n || m < editId d) + _pendingEdits %= filter (\(_, d) -> editId d < n || m < editId d) setDirty :: Acid.Update GlobalState () -setDirty = dirty .= True +setDirty = _dirty .= True unsetDirty :: Acid.Update GlobalState Bool -unsetDirty = dirty <<.= False +unsetDirty = _dirty <<.= False -- | Retrieves a session by 'SessionID'. -- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'. loadSession :: SessionId -> Acid.Query GlobalState (Maybe GuideSession) -loadSession key = view (sessionStore . at key) +loadSession key = view (_sessionStore . at key) -- | Stores a session object. -- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'. storeSession :: GuideSession -> Acid.Update GlobalState () storeSession sess = do - sessionStore %= M.insert (sess ^. sess_id) sess + _sessionStore %= M.insert (sess ^. sess_id) sess setDirty -- | Deletes a session by 'SessionID'. -- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'. deleteSession :: SessionId -> Acid.Update GlobalState () deleteSession key = do - sessionStore %= M.delete key + _sessionStore %= M.delete key setDirty -- | Retrieves all sessions. -- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'. getSessions :: Acid.Query GlobalState [GuideSession] getSessions = do - m <- view sessionStore + m <- view _sessionStore return . map snd $ M.toList m -- | Retrieves a user by their unique identifier. getUser :: Uid User -> Acid.Query GlobalState (Maybe User) -getUser key = view (users . at key) +getUser key = view (_users . at key) -- | Creates a user, maintaining unique constraints on certain fields. createUser :: User -> Acid.Update GlobalState Bool createUser user = do - m <- toList <$> use users - if all (canCreateUser user) (m ^.. each) + m :: [User] <- toList <$> use _users + if all (canCreateUser user) m then do - users %= M.insert (user ^. userID) user + _users %= M.insert (userID user) user return True else return False @@ -753,21 +756,21 @@ createUser user = do -- | Remove a user completely. Unsets all user sessions with this user ID. deleteUser :: Uid User -> Acid.Update GlobalState () deleteUser key = do - users %= M.delete key + _users %= M.delete key logoutUserGlobally key setDirty deleteAllUsers :: Acid.Update GlobalState () deleteAllUsers = do - mapM_ logoutUserGlobally . M.keys =<< use users - users .= mempty + mapM_ logoutUserGlobally . M.keys =<< use _users + _users .= mempty setDirty -- | Given an email address and a password, return the user if it exists -- and the password is correct. loginUser :: Text -> ByteString -> Acid.Query GlobalState (Either String User) loginUser email password = do - matches <- filter (\u -> u ^. userEmail == email) . toList <$> view users + matches <- filter (\u -> userEmail u == email) . toList <$> view _users case matches of [user] -> if verifyUser user password @@ -779,14 +782,14 @@ loginUser email password = do -- | Global logout of all of a user's active sessions logoutUserGlobally :: Uid User -> Acid.Update GlobalState () logoutUserGlobally key = do - sessions <- use sessionStore + sessions <- use _sessionStore for_ (M.toList sessions) $ \(sessID, sess) -> do when ((sess ^. sess_data.sessionUserID) == Just key) $ do - sessionStore . ix sessID . sess_data . sessionUserID .= Nothing + _sessionStore . ix sessID . sess_data . sessionUserID .= Nothing -- | Retrieve all users with the 'userIsAdmin' field set to True. getAdminUsers :: Acid.Query GlobalState [User] -getAdminUsers = filter (^. userIsAdmin) . toList <$> view users +getAdminUsers = filter userIsAdmin . toList <$> view _users -- | Populate the database with info from the public DB. importPublicDB :: PublicDB -> Acid.Update GlobalState () diff --git a/back/src/Guide/Types/Core.hs b/back/src/Guide/Types/Core.hs index bdecda3..1436e54 100644 --- a/back/src/Guide/Types/Core.hs +++ b/back/src/Guide/Types/Core.hs @@ -13,43 +13,20 @@ -- The whole site is a list of categories ('Category'). Categories have -- items ('Item') in them. Items have some sections (fields inside of -- 'Item'), as well as traits ('Trait'). --- --- It is recommended to use lenses to access fields of various types. All --- those lenses are exported from this module. Some lenses (like 'uid' and --- 'name') are overloaded and can be used with many types. module Guide.Types.Core ( Trait(..), + TraitLenses(..), TraitType (..), ItemKind(..), hackageName, ItemSection(..), Item(..), - pros, - prosDeleted, - cons, - consDeleted, - ecosystem, - hackage, - link, + ItemLenses(..), CategoryStatus(..), Category(..), - title, - group_, - status, - enabledSections, - items, - itemsDeleted, - categorySlug, - - -- * Overloaded things - uid, - hasUid, - content, - name, - summary, - notes, - created, + CategoryLenses(..), + categorySlug, ) where @@ -86,19 +63,19 @@ For an explanation of deriveSafeCopySorted, see Note [acid-state]. -- | A trait (pro or con). Traits are stored in items. data Trait = Trait { - _traitUid :: Uid Trait, - _traitContent :: MarkdownInline } + traitUid :: Uid Trait, + traitContent :: MarkdownInline } deriving (Show, Generic, Data) deriveSafeCopySorted 4 'extension ''Trait -makeFields ''Trait +makeClassWithLenses ''Trait changelog ''Trait (Current 4, Past 3) [] deriveSafeCopySorted 3 'base ''Trait_v3 instance A.ToJSON Trait where toJSON = A.genericToJSON A.defaultOptions { - A.fieldLabelModifier = over _head toLower . drop (T.length "_trait") } + A.fieldLabelModifier = over _head toLower . drop (T.length "trait") } -- | ADT for trait type. Traits can be pros (positive traits) and cons -- (negative traits). @@ -156,7 +133,7 @@ instance Migrate ItemKind where migrate Other_v2 = Other -- | Different kinds of sections inside items. This type is only used for --- '_categoryEnabledSections'. +-- 'categoryEnabledSections'. data ItemSection = ItemProsConsSection | ItemEcosystemSection @@ -176,39 +153,39 @@ instance A.FromJSON ItemSection where -- | An item (usually a library). Items are stored in categories. data Item = Item { - _itemUid :: Uid Item, -- ^ Item ID - _itemName :: Text, -- ^ Item title - _itemCreated :: UTCTime, -- ^ When the item was created - _itemHackage :: Maybe Text, -- ^ Package name on Hackage - _itemSummary :: 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 + itemUid :: Uid Item, -- ^ Item ID + itemName :: Text, -- ^ Item title + itemCreated :: UTCTime, -- ^ When the item was created + itemHackage :: Maybe Text, -- ^ Package name on Hackage + itemSummary :: 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 } deriving (Show, Generic, Data) deriveSafeCopySorted 13 'extension ''Item -makeFields ''Item +makeClassWithLenses ''Item changelog ''Item (Current 13, Past 12) - [Removed "_itemGroup_" [t|Maybe Text|] ] + [Removed "itemGroup_" [t|Maybe Text|] ] deriveSafeCopySorted 12 'extension ''Item_v12 changelog ''Item (Past 12, Past 11) - [Removed "_itemKind" [t|ItemKind|], - Added "_itemHackage" [hs| - case _itemKind of + [Removed "itemKind" [t|ItemKind|], + Added "itemHackage" [hs| + case itemKind of Library m -> m Tool m -> m Other -> Nothing |], - Removed "_itemDescription" [t|MarkdownBlock|], - Added "_itemSummary" [hs| - _itemDescription |] ] + Removed "itemDescription" [t|MarkdownBlock|], + Added "itemSummary" [hs| + itemDescription |] ] deriveSafeCopySorted 11 'extension ''Item_v11 changelog ''Item (Past 11, Past 10) [] @@ -216,7 +193,7 @@ deriveSafeCopySorted 10 'base ''Item_v10 instance A.ToJSON Item where toJSON = A.genericToJSON A.defaultOptions { - A.fieldLabelModifier = over _head toLower . drop (T.length "_item") } + A.fieldLabelModifier = over _head toLower . drop (T.length "item") } ---------------------------------------------------------------------------- -- Category @@ -254,45 +231,45 @@ instance Migrate CategoryStatus where -- | A category data Category = Category { - _categoryUid :: Uid Category, - _categoryTitle :: Text, + categoryUid :: Uid Category, + categoryTitle :: Text, -- | When the category was created - _categoryCreated :: UTCTime, + categoryCreated :: UTCTime, -- | The “grandcategory” of the category (“meta”, “basics”, etc) - _categoryGroup_ :: Text, - _categoryStatus :: CategoryStatus, - _categoryNotes :: MarkdownBlock, + categoryGroup :: Text, + categoryStatus :: CategoryStatus, + categoryNotes :: MarkdownBlock, -- | Items stored in the category - _categoryItems :: [Item], + categoryItems :: [Item], -- | Items that were deleted from the category. We keep them here to make -- it easier to restore them - _categoryItemsDeleted :: [Item], + 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 + categoryEnabledSections :: Set ItemSection } deriving (Show, Generic, Data) deriveSafeCopySorted 12 'extension ''Category -makeFields ''Category +makeClassWithLenses ''Category changelog ''Category (Current 12, Past 11) - [Removed "_categoryGroups" [t|Map Text Hue|] ] + [Removed "categoryGroups" [t|Map Text Hue|] ] deriveSafeCopySorted 11 'extension ''Category_v11 changelog ''Category (Past 11, Past 10) - [Removed "_categoryProsConsEnabled" [t|Bool|], - Removed "_categoryEcosystemEnabled" [t|Bool|], - Removed "_categoryNotesEnabled" [t|Bool|], - Added "_categoryEnabledSections" [hs| + [Removed "categoryProsConsEnabled" [t|Bool|], + Removed "categoryEcosystemEnabled" [t|Bool|], + Removed "categoryNotesEnabled" [t|Bool|], + Added "categoryEnabledSections" [hs| S.fromList $ concat - [ [ItemProsConsSection | _categoryProsConsEnabled] - , [ItemEcosystemSection | _categoryEcosystemEnabled] - , [ItemNotesSection | _categoryNotesEnabled] ] |] ] + [ [ItemProsConsSection | categoryProsConsEnabled] + , [ItemEcosystemSection | categoryEcosystemEnabled] + , [ItemNotesSection | categoryNotesEnabled] ] |] ] deriveSafeCopySorted 10 'extension ''Category_v10 changelog ''Category (Past 10, Past 9) - [Added "_categoryNotesEnabled" [hs|True|]] + [Added "categoryNotesEnabled" [hs|True|]] deriveSafeCopySorted 9 'extension ''Category_v9 changelog ''Category (Past 9, Past 8) [] @@ -300,19 +277,11 @@ deriveSafeCopySorted 8 'base ''Category_v8 instance A.ToJSON Category where toJSON = A.genericToJSON A.defaultOptions { - A.fieldLabelModifier = over _head toLower . drop (T.length "_category") } + 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) - ----------------------------------------------------------------------------- --- 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 + format "{}-{}" (makeSlug (categoryTitle category)) (categoryUid category) diff --git a/back/src/Guide/Types/User.hs b/back/src/Guide/Types/User.hs index 93aa56e..52ce01b 100644 --- a/back/src/Guide/Types/User.hs +++ b/back/src/Guide/Types/User.hs @@ -5,16 +5,12 @@ -- | A type for users. Currently unused. module Guide.Types.User ( - User, - userID, - userName, - userEmail, - userPassword, - userIsAdmin, + User(..), + UserLenses(..), makeUser, verifyUser, canCreateUser, - PublicUser, + PublicUser(..), userToPublic, publicUserToUser ) @@ -34,20 +30,20 @@ import Guide.Utils data User = User { -- | Unique, pseudorandom identifier for user. - _userID :: Uid User, + userID :: Uid User, -- | Unique username for user. - _userName :: Text, + userName :: Text, -- | Unique email address for user. - _userEmail :: Text, + userEmail :: Text, -- | Scrypt generated password field, contains salt + hash. - _userPassword :: Maybe ByteString, + userPassword :: Maybe ByteString, -- | Flag set if user is an administrator. - _userIsAdmin :: Bool + userIsAdmin :: Bool } deriving (Show) deriveSafeCopySorted 0 'base ''User -makeLenses ''User +makeClassWithLenses ''User -- | Creates a user object with an SCrypt encrypted password. makeUser :: MonadIO m => Text -> Text -> ByteString -> m User @@ -55,29 +51,29 @@ makeUser username email password = do encPass <- liftIO $ encryptPassIO' (Pass password) userid <- randomLongUid return User { - _userID = userid, - _userName = username, - _userEmail = email, - _userPassword = Just $ getEncryptedPass encPass, - _userIsAdmin = False } + userID = userid, + userName = username, + userEmail = email, + userPassword = Just $ getEncryptedPass encPass, + userIsAdmin = False } -- | Verifies a given password corresponds to a user's encrypted password. verifyUser :: User -> ByteString -> Bool verifyUser user password = - case user ^. userPassword of + case userPassword user of Just encPass -> verifyPass' (Pass password) (EncryptedPass encPass) Nothing -> False -- | Looks at two users, and returns true if all unique fields are different. canCreateUser :: User -> User -> Bool -canCreateUser userFoo userBar = - all (\f -> f userFoo userBar) fieldTests - where - fieldNotEq field a b = a ^. field /= b ^. field - fieldTests = [ - fieldNotEq userID, - fieldNotEq userName, - fieldNotEq userEmail ] +canCreateUser $(fieldsPrefixed "a_" 'User) $(fieldsPrefixed "b_" 'User) = + a_userID /= b_userID && + a_userName /= b_userName && + a_userEmail /= b_userEmail + where + -- Ignored fields + _ = (a_userIsAdmin, b_userIsAdmin) + _ = (a_userPassword, b_userPassword) -- | 'PublicUser' contains all safe User data. -- Removed from 'User': @@ -93,21 +89,24 @@ deriveSafeCopySorted 0 'base ''PublicUser -- | Converts 'User' to 'PublicUser' type. userToPublic :: User -> PublicUser -userToPublic User{..} = +userToPublic $(fields 'User) = PublicUser { - publicUserID = _userID, - publicUserName = _userName, - publicUserEmail = _userEmail, - publicUserIsAdmin = _userIsAdmin + publicUserID = userID, + publicUserName = userName, + publicUserEmail = userEmail, + publicUserIsAdmin = userIsAdmin } + where + -- Ignored fields + _ = userPassword -- | Converts 'PublicUser' to 'User' filling password with Nothing. publicUserToUser :: PublicUser -> User -publicUserToUser PublicUser{..} = +publicUserToUser $(fields 'PublicUser) = User { - _userID = publicUserID, - _userName = publicUserName, - _userEmail = publicUserEmail, - _userPassword = Nothing, - _userIsAdmin = publicUserIsAdmin + userID = publicUserID, + userName = publicUserName, + userEmail = publicUserEmail, + userPassword = Nothing, + userIsAdmin = publicUserIsAdmin } diff --git a/back/src/Guide/Utils.hs b/back/src/Guide/Utils.hs index 4ed390f..11adee4 100644 --- a/back/src/Guide/Utils.hs +++ b/back/src/Guide/Utils.hs @@ -515,6 +515,15 @@ dumpSplices x = do -- will warn on all unused fields. Thus 'fields' brings safety whenever you -- want to guarantee that a certain function uses all fields of @Foo@. -- +-- To explicitly ignore a field, match it against @_@: +-- +-- @ +-- f $(fields 'Foo) = ... +-- where +-- -- Ignored fields +-- _ = (fooUselessField1, fooUselessField2) +-- @ +-- -- Usage examples include @ToJSON@ instances and various encoders in -- general: -- diff --git a/back/src/Guide/Views.hs b/back/src/Guide/Views.hs index 7962065..e120f48 100644 --- a/back/src/Guide/Views.hs +++ b/back/src/Guide/Views.hs @@ -212,7 +212,7 @@ renderAdmin globalState = do button "Create checkpoint" [uid_ buttonUid] $ JS.createCheckpoint [JS.selectUid buttonUid] div_ [id_ "edits"] $ - renderEdits globalState (map (,Nothing) (globalState ^. pendingEdits)) + renderEdits globalState (map (,Nothing) (pendingEdits globalState)) -- | Group edits by IP and render them. renderEdits @@ -267,44 +267,45 @@ renderEdit globalState edit = do quote a = "“" *> a <* "”" -- We're searching for everything (items/categories) both in normal lists -- and in lists of deleted things. Just in case. - let allCategories = globalState^.categories ++ - globalState^.categoriesDeleted - let findCategory catId = fromMaybe err (find (hasUid catId) allCategories) + let allCategories = categories globalState ++ + categoriesDeleted globalState + let findCategory catId = fromMaybe err (find ((== catId) . categoryUid) allCategories) where err = error ("renderEdit: couldn't find category with uid = " ++ toString (uidToText catId)) let findItem itemId = (category, item) where - getItems = view (items <> itemsDeleted) - ourCategory = any (hasUid itemId) . getItems + getItems = view (_categoryItems <> _categoryItemsDeleted) + ourCategory = any ((== itemId) . itemUid) . getItems err = error ("renderEdit: couldn't find item with uid = " ++ toString (uidToText itemId)) category = fromMaybe err (find ourCategory allCategories) - item = fromJust (find (hasUid itemId) (getItems category)) + item = fromJust (find ((== itemId) . itemUid) (getItems category)) let findTrait itemId traitId = (category, item, trait) where (category, item) = findItem itemId - getTraits = view (cons <> consDeleted <> pros <> prosDeleted) + getTraits = view (_itemCons <> _itemConsDeleted <> + _itemPros <> _itemProsDeleted) err = error ("renderEdit: couldn't find trait with uid = " ++ toString (uidToText traitId)) - trait = fromMaybe err (find (hasUid traitId) (getTraits item)) + trait = fromMaybe err (find ((== traitId) . traitUid) (getTraits item)) let printCategory catId = do let category = findCategory catId - quote $ a_ [href_ (categoryLink category)] $ - toHtml (category ^. title) + quote $ a_ [href_ (mkCategoryLink category)] $ + toHtml (categoryTitle category) let printItem itemId = do let (category, item) = findItem itemId - quote $ a_ [href_ (itemLink category item)] $ - toHtml (item ^. name) + quote $ a_ [href_ (mkItemLink category item)] $ + toHtml (itemName item) let printCategoryWithItems catId = do let category = findCategory catId - quote $ toHtml (category ^. title) - let catItems = category ^. items + quote $ toHtml (categoryTitle category) + let catItems = categoryItems category toHtml $ " with " ++ show (length catItems) ++ " items:" ul_ $ for_ catItems $ \item -> - li_ $ toHtml (item ^. name) + li_ $ toHtml (itemName item) case edit of -- Add @@ -385,7 +386,7 @@ renderEdit globalState edit = do Edit'SetTraitContent itemId _traitId oldContent newContent -> do p_ $ (if T.null oldContent then "added" else "changed") >> " trait of item " >> printItem itemId >> - " from category " >> printCategory (findItem itemId ^. _1.uid) + " from category " >> printCategory (findItem itemId ^. _1 . _categoryUid) renderDiff oldContent newContent -- Delete @@ -393,12 +394,12 @@ renderEdit globalState edit = do "deleted category " >> printCategoryWithItems catId Edit'DeleteItem itemId _pos -> p_ $ do let (category, item) = findItem itemId - "deleted item " >> quote (toHtml (item^.name)) - " from category " >> quote (toHtml (category^.title)) + "deleted item " >> quote (toHtml (itemName item)) + " from category " >> quote (toHtml (categoryTitle category)) Edit'DeleteTrait itemId traitId _pos -> do let (_, item, trait) = findTrait itemId traitId - p_ $ "deleted trait from item " >> quote (toHtml (item^.name)) - pre_ $ code_ $ toHtml $ trait^.content + p_ $ "deleted trait from item " >> quote (toHtml (itemName item)) + pre_ $ code_ $ toHtml $ traitContent trait -- Other Edit'MoveItem itemId direction -> p_ $ do @@ -406,9 +407,9 @@ renderEdit globalState edit = do if direction then " up" else " down" Edit'MoveTrait itemId traitId direction -> do let (_, item, trait) = findTrait itemId traitId - p_ $ "moved trait of item " >> quote (toHtml (item^.name)) >> + p_ $ "moved trait of item " >> quote (toHtml (itemName item)) >> if direction then " up" else " down" - pre_ $ code_ $ toHtml $ trait^.content + pre_ $ code_ $ toHtml $ traitContent trait renderDiff :: Monad m => Text -> Text -> HtmlT m () renderDiff old new = @@ -473,7 +474,7 @@ renderHaskellRoot globalState mbSearchQuery = autocomplete_ "off", onEnter $ JS.addCategoryAndRedirect [inputValue] ] case mbSearchQuery of - Nothing -> renderCategoryList (globalState^.categories) + Nothing -> renderCategoryList (categories globalState) Just query' -> renderSearchResults (search query' globalState) -- TODO: maybe add a button like “give me random category that is -- unfinished” @@ -483,7 +484,7 @@ renderCategoryPage :: (MonadIO m, MonadReader Config m) => Category -> HtmlT m () renderCategoryPage category = do - wrapPage (category^.title <> " – Haskell – Aelve Guide") $ do + wrapPage (categoryTitle category <> " – Haskell – Aelve Guide") $ do onPageLoad $ JS.expandHash () haskellHeader renderNoScriptWarning @@ -520,9 +521,9 @@ wrapPage pageTitle' page = doctypehtml_ $ do meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0, user-scalable=yes"] link_ [rel_ "icon", href_ "/favicon.ico"] - googleToken <- _googleToken <$> lift ask - unless (T.null googleToken) $ - meta_ [name_ "google-site-verification", content_ googleToken] + token <- googleToken <$> lift ask + unless (T.null token) $ + meta_ [name_ "google-site-verification", content_ token] -- Report all Javascript errors with alerts script_ [text| window.onerror = function (msg, url, lineNo, columnNo, error) { @@ -590,35 +591,35 @@ renderSearch mbSearchQuery = renderCategoryList :: forall m. MonadIO m => [Category] -> HtmlT m () renderCategoryList allCats = div_ [id_ "categories"] $ - for_ (groupWith (view group_) allCats) $ \catsInGroup -> + for_ (groupWith categoryGroup allCats) $ \catsInGroup -> div_ [class_ "category-group"] $ do -- Grandcategory name - h2_ $ toHtml (catsInGroup^?!_head.group_) + h2_ $ toHtml (categoryGroup (head catsInGroup)) -- Finished categories - do let cats = filter ((== CategoryFinished) . view status) catsInGroup + do let cats = filter ((== CategoryFinished) . categoryStatus) catsInGroup unless (null cats) $ div_ [class_ "categories-finished"] $ do - mapM_ mkCategoryLink cats + mapM_ mkCategoryLinkHtml cats -- In-progress categories, separated with commas - do let cats = filter ((== CategoryWIP) . view status) catsInGroup + do let cats = filter ((== CategoryWIP) . categoryStatus) catsInGroup unless (null cats) $ div_ [class_ "categories-wip"] $ do h3_ "In progress" p_ $ sequence_ $ intersperse ", " $ - map mkCategoryLink cats + map mkCategoryLinkHtml cats -- Stub categories, separated with commas - do let cats = filter ((== CategoryStub) . view status) catsInGroup + do let cats = filter ((== CategoryStub) . categoryStatus) catsInGroup unless (null cats) $ div_ [class_ "categories-stub"] $ do h3_ "To be written" p_ $ sequence_ $ intersperse ", " $ - map mkCategoryLink cats + map mkCategoryLinkHtml cats where -- TODO: this link shouldn't be absolute [absolute-links] - mkCategoryLink :: Category -> HtmlT m () - mkCategoryLink category = - a_ [class_ "category-link", href_ (categoryLink category)] $ - toHtml (category^.title) + mkCategoryLinkHtml :: Category -> HtmlT m () + mkCategoryLinkHtml category = + a_ [class_ "category-link", href_ (mkCategoryLink category)] $ + toHtml (categoryTitle category) -- | Render a
with search results. renderSearchResults :: Monad m => [SearchResult] -> HtmlT m () @@ -632,27 +633,29 @@ renderSearchResult r = do div_ [class_ "search-result"] $ case r of SRCategory cat -> do - a_ [class_ "category-link", href_ (categoryLink cat)] $ - toHtml (cat^.title) + a_ [class_ "category-link", href_ (mkCategoryLink cat)] $ + toHtml (categoryTitle cat) div_ [class_ "category-description notes-like"] $ - toHtml (extractPreface $ toMarkdownTree "" $ cat^.notes.mdSource) + toHtml $ extractPreface $ + toMarkdownTree "" $ + markdownBlockSource (categoryNotes cat) SRItem cat item -> do - a_ [class_ "category-link in-item-sr", href_ (categoryLink cat)] $ - toHtml (cat^.title) + a_ [class_ "category-link in-item-sr", href_ (mkCategoryLink cat)] $ + toHtml (categoryTitle cat) span_ [class_ "breadcrumb"] "»" - a_ [class_ "item-link", href_ (itemLink cat item)] $ - toHtml (item^.name) + a_ [class_ "item-link", href_ (mkItemLink cat item)] $ + toHtml (itemName item) div_ [class_ "description notes-like"] $ - toHtml (item^.summary) + toHtml (itemSummary item) SRItemEcosystem cat item -> do - a_ [class_ "category-link in-item-sr", href_ (categoryLink cat)] $ - toHtml (cat^.title) + a_ [class_ "category-link in-item-sr", href_ (mkCategoryLink cat)] $ + toHtml (categoryTitle cat) span_ [class_ "breadcrumb"] "»" - a_ [class_ "item-link", href_ (itemLink cat item)] $ - toHtml (item^.name) + a_ [class_ "item-link", href_ (mkItemLink cat item)] $ + toHtml (itemName item) span_ [class_ "item-link-addition"] "'s ecosystem" div_ [class_ "ecosystem notes-like"] $ - toHtml (item^.ecosystem) + toHtml (itemEcosystem item) {- Note [enabled sections] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -820,24 +823,24 @@ renderArchivalStatus = \case -- | 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 +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, categoryTitle cat <> " (category notes)") + | url <- findLinksMD (categoryNotes cat)] ++ + [(url, categoryTitle cat <> " / " <> itemName item) + | item <- categoryItems cat , url <- findLinksItem item] -- | Find all links in a single item. findLinksItem :: Item -> [Url] -findLinksItem item = findLinksMD item' ++ maybeToList (item^.link) +findLinksItem item = findLinksMD item' ++ maybeToList (itemLink item) where -- we don't want to find any links in deleted traits - item' = item & prosDeleted .~ [] - & consDeleted .~ [] + item' = item & _itemProsDeleted .~ [] + & _itemConsDeleted .~ [] -- | Find all Markdown links in /any/ structure, using generics. findLinksMD :: Data a => a -> [Url] diff --git a/back/src/Guide/Views/Auth/Login.hs b/back/src/Guide/Views/Auth/Login.hs index af28a4b..455a7d1 100644 --- a/back/src/Guide/Views/Auth/Login.hs +++ b/back/src/Guide/Views/Auth/Login.hs @@ -53,7 +53,7 @@ loginView user = do div_ $ do -- TODO: Make nicer. "You are registered and logged in as " - toHtml (user ^. userName) + toHtml (userName user) renderLogin :: (MonadIO m, MonadReader Config m) => HtmlT m () -> HtmlT m () renderLogin content = do diff --git a/back/src/Guide/Views/Auth/Register.hs b/back/src/Guide/Views/Auth/Register.hs index 2c44b18..3cc7ec9 100644 --- a/back/src/Guide/Views/Auth/Register.hs +++ b/back/src/Guide/Views/Auth/Register.hs @@ -69,7 +69,7 @@ registerView user = do div_ $ do -- TODO: Make nicer. "You are registered and logged in as " - toHtml (user ^. userName) + toHtml (userName user) renderRegister :: (MonadIO m, MonadReader Config m) => HtmlT m () -> HtmlT m () renderRegister content = do diff --git a/back/src/Guide/Views/Category.hs b/back/src/Guide/Views/Category.hs index dcc5aef..f45c3d6 100644 --- a/back/src/Guide/Views/Category.hs +++ b/back/src/Guide/Views/Category.hs @@ -43,13 +43,13 @@ renderCategory category = div_ [class_ "category", id_ (categoryNodeId category) renderCategoryInfo category renderCategoryNotes category itemsNode <- div_ [class_ "items"] $ do - mapM_ (renderItem category) (category^.items) + mapM_ (renderItem category) (categoryItems category) thisNode textInput [ class_ " add-item ", placeholder_ "add an item", autocomplete_ "off", - onEnter $ JS.addItem (itemsNode, category^.uid, inputValue) <> + onEnter $ JS.addItem (itemsNode, categoryUid category, inputValue) <> clearInput ] ---------------------------------------------------------------------------- @@ -60,7 +60,7 @@ renderCategory category = div_ [class_ "category", id_ (categoryNodeId category) -- form + possibly status banner). renderCategoryInfo :: MonadIO m => Category -> HtmlT m () renderCategoryInfo category = - let thisId = "category-info-" <> uidToText (category^.uid) + let thisId = "category-info-" <> uidToText (categoryUid category) this = JS.selectId thisId in div_ [id_ thisId, class_ "category-info"] $ do section "normal" [shown, noScriptShown] $ do @@ -68,25 +68,25 @@ renderCategoryInfo category = -- TODO: this link shouldn't be absolute [absolute-links] span_ [class_ "controls"] $ a_ [class_ "category-feed", - href_ ("/haskell/feed/category/" <> uidToText (category^.uid))] $ + href_ ("/haskell/feed/category/" <> uidToText (categoryUid category))] $ img_ [src_ "/rss-alt.svg", alt_ "category feed", title_ "category feed"] - a_ [href_ (categoryLink category), class_ "category-title"] $ - toHtml (category^.title) + a_ [href_ (mkCategoryLink category), class_ "category-title"] $ + toHtml (categoryTitle category) emptySpan "1em" span_ [class_ "group"] $ - toHtml (category^.group_) + toHtml (categoryGroup category) emptySpan "1em" textButton "edit" $ JS.switchSection (this, "editing" :: Text) emptySpan "1em" textButton "delete" $ - JS.deleteCategoryAndRedirect [category^.uid] + JS.deleteCategoryAndRedirect [categoryUid category] renderCategoryStatus category section "editing" [] $ do let formSubmitHandler formNode = - JS.submitCategoryInfo (this, category^.uid, formNode) + JS.submitCategoryInfo (this, categoryUid category, formNode) form_ [onFormSubmit formSubmitHandler] $ do -- All inputs have "autocomplete = off" thanks to -- @@ -94,40 +94,40 @@ renderCategoryInfo category = "Title" >> br_ [] input_ [type_ "text", name_ "title", autocomplete_ "off", - value_ (category^.title)] + value_ (categoryTitle category)] br_ [] label_ $ do "Group" >> br_ [] input_ [type_ "text", name_ "group", autocomplete_ "off", - value_ (category^.group_)] + value_ (categoryGroup category)] br_ [] label_ $ do "Status" >> br_ [] select_ [name_ "status", autocomplete_ "off"] $ do option_ [value_ "finished"] "Complete" - & selectedIf (category^.status == CategoryFinished) + & selectedIf (categoryStatus category == CategoryFinished) option_ [value_ "wip"] "Work in progress" - & selectedIf (category^.status == CategoryWIP) + & selectedIf (categoryStatus category == CategoryWIP) option_ [value_ "stub"] "Stub" - & selectedIf (category^.status == CategoryStub) + & selectedIf (categoryStatus category == CategoryStub) br_ [] label_ $ do input_ [type_ "checkbox", name_ "pros-cons-enabled", autocomplete_ "off"] - & checkedIf (ItemProsConsSection `elem` category^.enabledSections) + & checkedIf (ItemProsConsSection `elem` categoryEnabledSections category) "Pros/cons enabled" br_ [] label_ $ do input_ [type_ "checkbox", name_ "ecosystem-enabled", autocomplete_ "off"] - & checkedIf (ItemEcosystemSection `elem` category^.enabledSections) + & checkedIf (ItemEcosystemSection `elem` categoryEnabledSections category) "“Ecosystem” field enabled" br_ [] label_ $ do input_ [type_ "checkbox", name_ "notes-enabled", autocomplete_ "off"] - & checkedIf (ItemNotesSection `elem` category^.enabledSections) + & checkedIf (ItemNotesSection `elem` categoryEnabledSections category) "“Notes” field enabled" br_ [] input_ [type_ "submit", value_ "Save", class_ "save"] @@ -138,7 +138,7 @@ renderCategoryInfo category = -- unfinished category. renderCategoryStatus :: MonadIO m => Category -> HtmlT m () renderCategoryStatus category = do - case category^.status of + case categoryStatus category of CategoryFinished -> return () CategoryWIP -> catBanner $ do "This category is a work in progress" @@ -153,14 +153,14 @@ renderCategoryStatus category = do -- | Render category notes (or “description”). renderCategoryNotes :: MonadIO m => Category -> HtmlT m () renderCategoryNotes category = - let thisId = "category-notes-" <> uidToText (category^.uid) + let thisId = "category-notes-" <> uidToText (categoryUid category) this = JS.selectId thisId in div_ [id_ thisId, class_ "category-notes"] $ do section "normal" [shown, noScriptShown] $ do div_ [class_ "notes-like"] $ do - if markdownNull (category^.notes) + if markdownBlockSource (categoryNotes category) == "" then p_ "write something here!" - else toHtml (category^.notes) + else toHtml (categoryNotes category) textButton "edit description" $ JS.switchSection (this, "editing" :: Text) <> JS.focusOn [(this `JS.selectSection` "editing") @@ -168,14 +168,17 @@ renderCategoryNotes category = JS.selectClass "editor"] section "editing" [] $ do - contents <- if markdownNull (category^.notes) + contents <- if markdownBlockSource (categoryNotes category) == "" then liftIO $ toMarkdownBlock <$> T.readFile "static/category-notes-template.md" - else return (category^.notes) + else return (categoryNotes category) markdownEditor 10 -- rows contents (\val -> JS.withThis JS.submitCategoryNotes - (this, category^.uid, category^.notes.mdSource, val)) + (this, + categoryUid category, + markdownBlockSource (categoryNotes category), + val)) (JS.withThis JS.switchSection (this, "normal" :: Text)) "or press Ctrl+Enter to save" diff --git a/back/src/Guide/Views/Item.hs b/back/src/Guide/Views/Item.hs index 0c247b2..ade7c3f 100644 --- a/back/src/Guide/Views/Item.hs +++ b/back/src/Guide/Views/Item.hs @@ -58,13 +58,13 @@ renderItem category item = div_ [class_ "item-body", style_ ("background-color:#F0F0F0")] $ do -- See Note [enabled sections] renderItemDescription item - hiddenIf (ItemProsConsSection `notElem` category^.enabledSections) $ + hiddenIf (ItemProsConsSection `notElem` categoryEnabledSections category) $ div_ [class_ "pros-cons-wrapper"] $ renderItemTraits item - hiddenIf (ItemEcosystemSection `notElem` category^.enabledSections) $ + hiddenIf (ItemEcosystemSection `notElem` categoryEnabledSections category) $ div_ [class_ "ecosystem-wrapper"] $ renderItemEcosystem item - hiddenIf (ItemNotesSection `notElem` category^.enabledSections) $ + hiddenIf (ItemNotesSection `notElem` categoryEnabledSections category) $ div_ [class_ "notes-wrapper"] $ renderItemNotes category item @@ -74,21 +74,21 @@ renderItemForFeed => Category -> Item -> HtmlT m () renderItemForFeed category item = do h1_ $ renderItemTitle item - unless (markdownNull (item^.summary)) $ - toHtml (item^.summary) - when (ItemProsConsSection `elem` category^.enabledSections) $ do + unless (markdownBlockSource (itemSummary item) == "") $ + toHtml (itemSummary item) + when (ItemProsConsSection `elem` categoryEnabledSections category) $ do h2_ "Pros" - ul_ $ mapM_ (p_ . li_ . toHtml . view content) (item^.pros) + ul_ $ mapM_ (p_ . li_ . toHtml . traitContent) (itemPros item) h2_ "Cons" - ul_ $ mapM_ (p_ . li_ . toHtml . view content) (item^.cons) - when (ItemEcosystemSection `elem` category^.enabledSections) $ do - unless (markdownNull (item^.ecosystem)) $ do + ul_ $ mapM_ (p_ . li_ . toHtml . traitContent) (itemCons item) + when (ItemEcosystemSection `elem` categoryEnabledSections category) $ do + unless (markdownBlockSource (itemEcosystem item) == "") $ do h2_ "Ecosystem" - toHtml (item^.ecosystem) + toHtml (itemEcosystem item) -- TODO: include .notes-like style here? otherwise the headers are too big - unless (markdownNull (item^.notes)) $ do + unless (markdownTreeSource (itemNotes item) == "") $ do h2_ "Notes" - toHtml (item^.notes) + toHtml (itemNotes item) ---------------------------------------------------------------------------- -- Helpers @@ -109,8 +109,8 @@ renderItemInfo cat item = mustache "item-info" $ A.object [ "category" A..= cat, "item" A..= item, - "link_to_item" A..= itemLink cat item, - "hackage" A..= (item^.hackage) ] + "link_to_item" A..= mkItemLink cat item, + "hackage" A..= itemHackage item ] -- | Render item description. renderItemDescription :: MonadIO m => Item -> HtmlT m () @@ -120,7 +120,7 @@ renderItemDescription item = mustache "item-description" $ -- | Render the “ecosystem” section. renderItemEcosystem :: MonadIO m => Item -> HtmlT m () renderItemEcosystem item = - let thisId = "item-ecosystem-" <> uidToText (item^.uid) + let thisId = "item-ecosystem-" <> uidToText (itemUid item) this = JS.selectId thisId in div_ [id_ thisId, class_ "item-ecosystem"] $ do @@ -134,8 +134,8 @@ renderItemEcosystem item = `JS.selectChildren` JS.selectClass "editor"] div_ [class_ "notes-like"] $ do - unless (markdownNull (item^.ecosystem)) $ - toHtml (item^.ecosystem) + unless (markdownBlockSource (itemEcosystem item) == "") $ + toHtml (itemEcosystem item) section "editing" [] $ do strong_ "Ecosystem" @@ -145,9 +145,9 @@ renderItemEcosystem item = JS.switchSection (this, "normal" :: Text) markdownEditor 3 -- rows - (item^.ecosystem) + (itemEcosystem item) (\val -> JS.withThis JS.submitItemEcosystem - (this, item^.uid, item^.ecosystem.mdSource, val)) + (this, itemUid item, markdownBlockSource (itemEcosystem item), val)) (JS.withThis JS.switchSection (this, "normal" :: Text)) "or press Ctrl+Enter to save" @@ -171,14 +171,14 @@ renderItemTraits item = div_ [class_ "item-traits"] $ do -- and only
  • elements can be children of
      listUid <- randomLongUid ul_ [uid_ listUid] $ - mapM_ (renderTrait (item^.uid)) (item^.pros) + mapM_ (renderTrait (itemUid item)) (itemPros item) section "editable" [] $ do smallMarkdownEditor 3 -- rows (toMarkdownInline "") -- TODO: clearing the editor should be moved into 'addPro' and -- done only if the request succeeds - (\val -> JS.withThis JS.addPro (JS.selectUid listUid, item^.uid, val)) + (\val -> JS.withThis JS.addPro (JS.selectUid listUid, itemUid item, val)) Nothing "press Ctrl+Enter or Enter to add" (Just "add pro") -- placeholder @@ -199,14 +199,14 @@ renderItemTraits item = div_ [class_ "item-traits"] $ do JS.switchSectionsEverywhere (this, "normal" :: Text) listUid <- randomLongUid ul_ [uid_ listUid] $ - mapM_ (renderTrait (item^.uid)) (item^.cons) + mapM_ (renderTrait (itemUid item)) (itemCons item) section "editable" [] $ do smallMarkdownEditor 3 -- rows (toMarkdownInline "") -- TODO: clearing the editor should be moved into 'addCon' and -- done only if the request succeeds - (\val -> JS.withThis JS.addCon (JS.selectUid listUid, item^.uid, val)) + (\val -> JS.withThis JS.addCon (JS.selectUid listUid, itemUid item, val)) Nothing "press Ctrl+Enter or Enter to add" (Just "add con") -- placeholder @@ -225,11 +225,11 @@ renderTrait itemUid trait = renderItemNotes :: MonadIO m => Category -> Item -> HtmlT m () renderItemNotes category item = do -- Don't change this ID, it's used in e.g. 'JS.expandHash' - let thisId = "item-notes-" <> uidToText (item^.uid) + let thisId = "item-notes-" <> uidToText (itemUid item) this = JS.selectId thisId editingSectionUid <- randomLongUid div_ [id_ thisId, class_ "item-notes"] $ do - let notesLink = categoryLink category <> "#" <> thisId + let notesLink = mkCategoryLink category <> "#" <> thisId a_ [href_ notesLink] $ strong_ "Notes" @@ -237,7 +237,7 @@ renderItemNotes category item = do renderTree [] = return () renderTree xs = ul_ $ do for_ xs $ \(Node {-(is, id')-} (Heading hMd id') children) -> li_ $ do - let handler = fromJS (JS.expandItemNotes [item^.uid]) + let handler = fromJS (JS.expandItemNotes [itemUid item]) -- The link has to be absolute because sometimes we are -- looking at items from pages different from the proper -- category pages (e.g. if a search from the main page @@ -247,12 +247,12 @@ renderItemNotes category item = do -- there's no search (or rather, there is search but it -- doesn't return items, only categories); however, it might -- start happening and then it's better to be prepared. - fullLink = categoryLink category <> "#" <> id' + fullLink = mkCategoryLink category <> "#" <> id' a_ [href_ fullLink, onclick_ handler] $ - toHtmlRaw (markdownInlineMdHtml hMd) + toHtmlRaw (markdownInlineHtml hMd) renderTree children let renderTOC = do - let toc = item^.notes.mdTOC + let toc = markdownTreeTOC (itemNotes item) div_ [class_ "notes-toc"] $ do if null toc then p_ (emptySpan "1.5em" >> "") @@ -260,14 +260,14 @@ renderItemNotes category item = do section "collapsed" [shown] $ do textButton "expand notes" $ - JS.expandItemNotes [item^.uid] + JS.expandItemNotes [itemUid item] renderTOC section "expanded" [noScriptShown] $ do textareaUid <- randomLongUid - contents <- if markdownNull (item^.notes) + contents <- if markdownTreeSource (itemNotes item) == "" then liftIO $ T.readFile "static/item-notes-template.md" - else return (item^.notes.mdSource) + else return (markdownTreeSource (itemNotes item)) let buttons = do textButton "collapse notes" $ JS.switchSection (this, "collapsed" :: Text) @@ -278,19 +278,19 @@ renderItemNotes category item = do this, JS.selectUid editingSectionUid, textareaUid, -- See Note [blurb diffing] - markdownNull (item^.notes), + markdownTreeSource (itemNotes item) == "", contents, - item^.uid) <> + itemUid item) <> JS.switchSection (this, "editing" :: Text) <> JS.autosizeTextarea [JS.selectUid textareaUid] <> JS.focusOn [JS.selectUid textareaUid] buttons renderTOC div_ [class_ "notes-like"] $ do - if markdownNull (item^.notes) + if markdownTreeSource (itemNotes item) == "" then p_ "add something!" - else toHtml (item^.notes) - unless (markdownNull (item^.notes)) $ + else toHtml (itemNotes item) + unless (markdownTreeSource (itemNotes item) == "") $ buttons -- TODO: [easy] the lower “hide notes” should scroll back to item when -- the notes are closed (but don't scroll if it's already visible after diff --git a/back/src/Guide/Views/Page.hs b/back/src/Guide/Views/Page.hs index 63b449f..3343317 100644 --- a/back/src/Guide/Views/Page.hs +++ b/back/src/Guide/Views/Page.hs @@ -128,7 +128,7 @@ headTagDef page = do meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0, user-scalable=yes"] link_ [rel_ "icon", href_ "/favicon.ico"] - googleToken <- _googleToken <$> lift ask + googleToken <- googleToken <$> lift ask unless (T.null googleToken) $ meta_ [name_ "google-site-verification", content_ googleToken] -- Report all Javascript errors with alerts diff --git a/back/src/Guide/Views/Utils.hs b/back/src/Guide/Views/Utils.hs index a0e1607..6a7b1fe 100644 --- a/back/src/Guide/Views/Utils.hs +++ b/back/src/Guide/Views/Utils.hs @@ -19,8 +19,8 @@ module Guide.Views.Utils selectedIf, checkedIf, hiddenIf, - categoryLink, - itemLink, + mkCategoryLink, + mkItemLink, -- * HTML components button, @@ -195,7 +195,7 @@ markdownEditor -> JS -- ^ “Cancel” handler -> Text -- ^ Instruction (e.g. “press Ctrl+Enter to save”) -> HtmlT m () -markdownEditor rows (view mdSource -> src) submit cancel instr = do +markdownEditor rows (markdownBlockSource -> src) submit cancel instr = do editorUid <- randomLongUid term "a-editor" [uid_ editorUid, vBind "init-content" src, @@ -216,7 +216,7 @@ smallMarkdownEditor -> Text -- ^ Instruction (e.g. “press Enter to add”) -> Maybe Text -- ^ Placeholder -> HtmlT m () -smallMarkdownEditor rows (view mdSource -> src) submit mbCancel instr mbPlaceholder = do +smallMarkdownEditor rows (markdownInlineSource -> src) submit mbCancel instr mbPlaceholder = do editorUid <- randomLongUid term "a-editor-mini" ([uid_ editorUid, vBind "init-content" src, @@ -239,17 +239,17 @@ thisNode = do return (JS.selectParent (JS.selectUid uid')) itemNodeId :: Item -> Text -itemNodeId item = format "item-{}" (item^.uid) +itemNodeId item = format "item-{}" (itemUid item) categoryNodeId :: Category -> Text -categoryNodeId category = format "category-{}" (category^.uid) +categoryNodeId category = format "category-{}" (categoryUid category) -- TODO: another absolute link to get rid of [absolute-links] -categoryLink :: Category -> Url -categoryLink category = format "/haskell/{}" (categorySlug category) +mkCategoryLink :: Category -> Url +mkCategoryLink category = format "/haskell/{}" (categorySlug category) -itemLink :: Category -> Item -> Url -itemLink category item = +mkItemLink :: Category -> Item -> Url +mkItemLink category item = format "/haskell/{}#{}" (categorySlug category) (itemNodeId item) -- See Note [show-hide]; wheh changing these, also look at 'JS.switchSection'. diff --git a/back/tests/MarkdownSpec.hs b/back/tests/MarkdownSpec.hs index abfdcfd..116b5fb 100644 --- a/back/tests/MarkdownSpec.hs +++ b/back/tests/MarkdownSpec.hs @@ -25,7 +25,7 @@ import Guide.Markdown tests :: Spec tests = describe "Markdown" $ do allMarkdowns $ \convert -> do - it "has mdSource filled accurately" $ do + it "has the source filled accurately" $ do for_ mdBlockExamples $ \s -> s `shouldBe` fst (convert s) it "only has allowed tags" $ do @@ -110,7 +110,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") []] - (toMarkdownTree "i-" s ^. mdTree) `shouldBe` Document { + markdownTreeStructure (toMarkdownTree "i-" s) `shouldBe` Document { prefaceAnn = "

      x

      \n", preface = WithSource "x\n\n" [prefaceMD], sections = [ @@ -130,7 +130,7 @@ tests = describe "Markdown" $ do subForest = [] }]}]} it "has a correct TOC" $ do let s = "x\n\n# foo\n\n## foo\n\ny" - (toMarkdownTree "i-" s ^. mdTOC) `shouldBe` [ + markdownTreeTOC (toMarkdownTree "i-" s) `shouldBe` [ Node {rootLabel = Heading (toMarkdownInline "# foo\n\n") "i-foo", subForest = [ Node {rootLabel = Heading (toMarkdownInline "## foo\n\n") "i-foo_", @@ -145,15 +145,15 @@ htmlToText = toText . renderText . toHtml allMarkdowns :: ((Text -> (Text, Text)) -> Spec) -> Spec allMarkdowns f = do describe "inline MD" $ - f ((view mdSource &&& htmlToText) . toMarkdownInline) + f ((markdownInlineSource &&& htmlToText) . toMarkdownInline) blockMarkdowns f blockMarkdowns :: ((Text -> (Text, Text)) -> Spec) -> Spec blockMarkdowns f = do describe "block MD" $ - f ((view mdSource &&& htmlToText) . toMarkdownBlock) + f ((markdownBlockSource &&& htmlToText) . toMarkdownBlock) describe "block+toc MD" $ - f ((view mdSource &&& htmlToText) . toMarkdownTree "") + f ((markdownTreeSource &&& htmlToText) . toMarkdownTree "") mdInlineExamples :: [Text] mdInlineExamples = [ diff --git a/back/tests/WebSpec.hs b/back/tests/WebSpec.hs index e9422cb..019e106 100644 --- a/back/tests/WebSpec.hs +++ b/back/tests/WebSpec.hs @@ -507,13 +507,13 @@ run :: FilePath -> Spec -> IO () run logFile ts = do -- Config to run spock server. let config = def { - _baseUrl = "/", - _googleToken = "some-google-token", - _adminPassword = "123", - _discussLink = Just "http://discuss.link", - _cors = False, - _logToStderr = False, - _logToFile = Just logFile + baseUrl = "/", + googleToken = "some-google-token", + adminPassword = "123", + discussLink = Just "http://discuss.link", + cors = False, + logToStderr = False, + logToFile = Just logFile } -- Prepere resources. let prepare = do