mirror of
https://github.com/aelve/guide.git
synced 2024-12-23 21:02:13 +03:00
Merge branch 'develop' of https://github.com/aelve/guide into develop
This commit is contained in:
commit
d8af6068f9
12
.travis.yml
12
.travis.yml
@ -49,6 +49,18 @@ jobs:
|
||||
- docker push "quay.io/aelve/guide:$BRANCH--back"
|
||||
if: type = push
|
||||
|
||||
# Our goal is full documented code with ZERO undocumented functions.
|
||||
# The next guard warns if a commit increased undocumented limit out 251.
|
||||
- stage: "Assert test undocumented no more then 251"
|
||||
before_script:
|
||||
- curl -sSL https://get.haskellstack.org/ | sh
|
||||
script:
|
||||
- stack haddock --fast --no-haddock-deps --no-terminal --haddock-arguments='--no-warnings' 2> haddock.log
|
||||
- awk '/\(src\//' haddock.log | awk 'END { print NR }' > notHaddockedAfter
|
||||
- echo "notHaddockedBefore = 251"
|
||||
- awk '{ print "notHaddockedAfter " $1 }' notHaddockedAfter
|
||||
- bash -c 'if [[ 251 < `cat notHaddockedAfter` ]]; then >&2 echo "FAIL. The current limit is 251 undocumented top-level definitions, but $notHaddockedAfter were found and it is out of limit. Please, add comment to top-level undocumented definitions!"; exit 1; else echo "OK. 251 is more notHaddockedAfter. Yes, it is convenience to have documented code!"; fi'
|
||||
|
||||
- stage: "Test the backend"
|
||||
before_script:
|
||||
- curl -sSL https://get.haskellstack.org/ | sh
|
||||
|
@ -1 +0,0 @@
|
||||
:set -XOverloadedStrings
|
@ -41,7 +41,7 @@ executable guide
|
||||
main-is: Main.hs
|
||||
build-depends: base
|
||||
, guide
|
||||
ghc-options: -Wall -fno-warn-unused-do-bind
|
||||
ghc-options: -Wall -Wno-unused-do-bind -Wmissing-export-lists
|
||||
-threaded "-with-rtsopts=-T -N"
|
||||
hs-source-dirs: src/site
|
||||
default-language: Haskell2010
|
||||
@ -56,6 +56,10 @@ library
|
||||
Guide.Api.Error
|
||||
Guide.Api.Utils
|
||||
Guide.Api.Guider
|
||||
Guide.Logger
|
||||
Guide.Logger.Types
|
||||
Guide.Logger.Functions
|
||||
Guide.Logger.Run
|
||||
Guide.Main
|
||||
Guide.ServerStuff
|
||||
Guide.Session
|
||||
@ -110,6 +114,10 @@ library
|
||||
, deepseq >= 1.2.0.0
|
||||
, digestive-functors
|
||||
, directory >= 1.2
|
||||
, di
|
||||
, di-monad
|
||||
, di-core
|
||||
, df1
|
||||
, ekg
|
||||
, ekg-core
|
||||
, exceptions
|
||||
@ -172,7 +180,7 @@ library
|
||||
, xml-conduit
|
||||
, xml-types
|
||||
, xss-sanitize
|
||||
ghc-options: -Wall -fno-warn-unused-do-bind
|
||||
ghc-options: -Wall -Wno-unused-do-bind -Wmissing-export-lists
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
default-extensions: MultiWayIf
|
||||
@ -195,13 +203,19 @@ library
|
||||
|
||||
test-suite tests
|
||||
main-is: Main.hs
|
||||
other-modules: WebSpec
|
||||
MarkdownSpec
|
||||
MergeSpec
|
||||
Selenium
|
||||
other-modules:
|
||||
ApiSpec
|
||||
LogSpec
|
||||
MarkdownSpec
|
||||
MergeSpec
|
||||
Selenium
|
||||
WebSpec
|
||||
type: exitcode-stdio-1.0
|
||||
build-depends: QuickCheck < 3
|
||||
, aeson
|
||||
, async
|
||||
, base < 5
|
||||
, bytestring
|
||||
, base-prelude
|
||||
, cmark
|
||||
, cmark-sections
|
||||
@ -212,19 +226,25 @@ test-suite tests
|
||||
, hspec < 3
|
||||
, hspec-expectations
|
||||
, hspec-webdriver < 1.3
|
||||
, http-client
|
||||
, http-conduit
|
||||
, http-types
|
||||
, lucid < 3
|
||||
, microlens-platform < 0.4
|
||||
, monad-loops < 0.5
|
||||
, network-uri
|
||||
, quickcheck-text < 0.2
|
||||
, regex
|
||||
, slave-thread
|
||||
, tagsoup < 1
|
||||
, text
|
||||
, temporary
|
||||
, transformers
|
||||
, webdriver >= 0.8.4 && < 0.9
|
||||
, yaml
|
||||
hs-source-dirs: tests
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fno-warn-unused-do-bind
|
||||
ghc-options: -Wall -Wno-unused-do-bind -Wmissing-export-lists
|
||||
default-extensions: MultiWayIf
|
||||
, ViewPatterns
|
||||
, RecordWildCards
|
||||
|
@ -1,8 +1,10 @@
|
||||
module Guide.Api
|
||||
( module Guide.Api.Methods
|
||||
, module Guide.Api.Server
|
||||
, module Guide.Api.Types
|
||||
) where
|
||||
(
|
||||
module Guide.Api.Methods,
|
||||
module Guide.Api.Server,
|
||||
module Guide.Api.Types,
|
||||
)
|
||||
where
|
||||
|
||||
import Guide.Api.Methods
|
||||
import Guide.Api.Server
|
||||
|
@ -7,8 +7,10 @@
|
||||
|
||||
|
||||
module Guide.Api.Error
|
||||
( ErrorResponse
|
||||
) where
|
||||
(
|
||||
ErrorResponse,
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Imports
|
||||
|
@ -1,29 +1,45 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
{- | 'Guider' monad with 'Config' to replace servant's 'Handler'. -}
|
||||
-- | 'Guider' monad with 'Config' to replace servant's 'Handler'.
|
||||
module Guide.Api.Guider
|
||||
( Guider (..)
|
||||
, GuiderServer
|
||||
, Context (..)
|
||||
, guiderToHandler
|
||||
) where
|
||||
(
|
||||
Guider (..),
|
||||
Context (..),
|
||||
guiderToHandler,
|
||||
)
|
||||
where
|
||||
|
||||
import Imports
|
||||
|
||||
import Servant (Handler (..), ServantErr)
|
||||
import Servant.Server.Generic
|
||||
import Servant (Handler (..), ServantErr (..))
|
||||
|
||||
import Guide.Api.Utils (RequestDetails)
|
||||
import Guide.Config (Config)
|
||||
import Guide.Logger
|
||||
import Guide.State (DB)
|
||||
|
||||
import qualified Control.Monad.Catch as Exc
|
||||
|
||||
-- | A type for Guide handlers. Provides access to everything in 'Context'.
|
||||
|
||||
-- | A type for Guide handlers. Provides:
|
||||
--
|
||||
-- * Logging via 'LoggerT'
|
||||
-- * Access to 'Context'
|
||||
--
|
||||
-- Note that it's not simply a wrapper over 'Handler' -- we throws
|
||||
-- 'ServantErr's as synchronous exceptions and then catch them in
|
||||
-- 'guiderToHandler'. It makes our lives easier because now there is exactly
|
||||
-- one way to throw errors, instead of two.
|
||||
newtype Guider a = Guider
|
||||
{ runGuider :: ReaderT Context IO a
|
||||
} deriving (Functor, Applicative, Monad, MonadIO, MonadReader Context)
|
||||
-- NB: we don't want to move 'Logger' to the 'Context' because 'LoggerT'
|
||||
-- also contains some STM weirdness (even though it's still a reader
|
||||
-- monad).
|
||||
{ runGuider :: ReaderT Context (LoggerT IO) a
|
||||
} deriving (Functor, Applicative, Monad, MonadIO, MonadReader Context, HasLogger, Exc.MonadThrow)
|
||||
|
||||
-- | Context of Guider
|
||||
-- | Context available to each request.
|
||||
data Context = Context
|
||||
{ cConfig :: Config
|
||||
, cDB :: DB
|
||||
@ -31,16 +47,20 @@ data Context = Context
|
||||
}
|
||||
|
||||
instance MonadError ServantErr Guider where
|
||||
-- | Log an error and rethrow it.
|
||||
throwError :: ServantErr -> Guider a
|
||||
throwError = liftIO . throwIO
|
||||
throwError err = do
|
||||
let code = errHTTPCode err
|
||||
reason = errReasonPhrase err
|
||||
if | code >= 500 -> logError ("error: "+||err||+"")
|
||||
| otherwise -> logDebug ("response code "+|code|+": "+|reason|+"")
|
||||
Exc.throwM err
|
||||
|
||||
catchError :: Guider a -> (ServantErr -> Guider a) -> Guider a
|
||||
catchError (Guider m) f = Guider $ ReaderT $ \context ->
|
||||
runReaderT m context `catch` (\err -> runReaderT (runGuider (f err)) context)
|
||||
runReaderT m context `Exc.catch` (\err -> runReaderT (runGuider (f err)) context)
|
||||
|
||||
-- | The custom type won't be accepted by servant server without this conventor used with 'hoistServer'.
|
||||
guiderToHandler :: Context -> Guider a -> Handler a
|
||||
guiderToHandler context (Guider m) = Handler $ ExceptT $ try $ runReaderT m context
|
||||
|
||||
-- | 'GuiderServer' used to create 'Guider' api.
|
||||
type GuiderServer = AsServerT Guider
|
||||
-- | Run a 'Guider' to get the 'Handler' type that Servant expects.
|
||||
guiderToHandler :: Context -> Logger -> Guider a -> Handler a
|
||||
guiderToHandler context logger (Guider m) =
|
||||
Handler $ ExceptT $ try $ runLoggerT logger $ runReaderT m context
|
||||
|
@ -4,6 +4,8 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
|
||||
|
||||
module Guide.Api.Methods where
|
||||
|
||||
|
||||
@ -15,6 +17,7 @@ import Data.Aeson (encode)
|
||||
import Data.Text (Text)
|
||||
import Servant
|
||||
|
||||
import Guide.Logger
|
||||
import Guide.Api.Guider (Context (..), Guider)
|
||||
import Guide.Matomo (Matomo (..), postMatomo)
|
||||
import Guide.Api.Types
|
||||
@ -36,62 +39,74 @@ import qualified Guide.Search as Search
|
||||
|
||||
-- | Get a list of available categories.
|
||||
getCategories :: Guider [CCategoryInfo]
|
||||
getCategories = dbQuery GetCategories <&> map toCCategoryInfo
|
||||
getCategories =
|
||||
logHandler "getCategories" [] $ do
|
||||
dbQuery GetCategories <&> map toCCategoryInfo
|
||||
|
||||
-- | Get a single category and all of its items.
|
||||
getCategory :: Uid Category -> Guider CCategoryFull
|
||||
getCategory catId = toCCategoryFull <$> getCategoryOrFail catId
|
||||
getCategory catId =
|
||||
logHandler "getCategory" [attr "catId" catId] $ do
|
||||
toCCategoryFull <$> getCategoryOrFail catId
|
||||
|
||||
-- | Create a new category, given the title and the grandparent (aka group).
|
||||
--
|
||||
-- Returns the ID of the created category (or of the existing one if the
|
||||
-- category with this title exists already).
|
||||
createCategory :: Text -> Text -> Guider (Uid Category)
|
||||
createCategory title' group' = do
|
||||
when (T.null title') $ throwError err400{errBody = "Title not provided"}
|
||||
when (T.null group') $ throwError err400{errBody = "Group' not provided"}
|
||||
-- If the category exists already, don't create it
|
||||
cats <- view categories <$> dbQuery GetGlobalState
|
||||
let isDuplicate cat = T.toCaseFold (cat^.title) == T.toCaseFold title'
|
||||
&& T.toCaseFold (cat^.group_) == T.toCaseFold group'
|
||||
case find isDuplicate cats of
|
||||
Just c -> return (c^.uid)
|
||||
Nothing -> do
|
||||
catId <- randomShortUid
|
||||
time <- liftIO getCurrentTime
|
||||
addEdit . fst =<< dbUpdate (AddCategory catId title' group' time)
|
||||
return catId
|
||||
createCategory title' group' =
|
||||
logHandler "createCategory" [attr "title" title', attr "group" group'] $ do
|
||||
when (T.null title') $ throwError err400{errReasonPhrase = "Title not provided"}
|
||||
when (T.null group') $ throwError err400{errReasonPhrase = "Group not provided"}
|
||||
-- If the category exists already, don't create it
|
||||
cats <- view categories <$> dbQuery GetGlobalState
|
||||
let isDuplicate cat = T.toCaseFold (cat^.title) == T.toCaseFold title'
|
||||
&& T.toCaseFold (cat^.group_) == T.toCaseFold group'
|
||||
case find isDuplicate cats of
|
||||
Just c -> do
|
||||
logDebug $ format
|
||||
"Found a category with the same title and group (id {}), \
|
||||
\will not create a new one" (c^.uid)
|
||||
return (c^.uid)
|
||||
Nothing -> do
|
||||
catId <- randomShortUid
|
||||
time <- liftIO getCurrentTime
|
||||
addEdit . fst =<< dbUpdate (AddCategory catId title' group' time)
|
||||
return catId
|
||||
|
||||
-- | Edit categoty's note.
|
||||
-- | Edit category's note.
|
||||
setCategoryNotes :: Uid Category -> CTextEdit -> Guider NoContent
|
||||
setCategoryNotes catId CTextEdit{..} = do
|
||||
serverModified <- markdownBlockMdSource . _categoryNotes <$> getCategoryOrFail catId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetCategoryNotes catId $ unH cteModified)
|
||||
pure NoContent
|
||||
setCategoryNotes catId CTextEdit{..} =
|
||||
logHandler "setCategoryNotes" [attr "catId" catId] $ do
|
||||
serverModified <- markdownBlockMdSource . _categoryNotes <$> getCategoryOrFail catId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetCategoryNotes catId $ unH cteModified)
|
||||
pure NoContent
|
||||
|
||||
-- | Edit category's info (title, group, status, sections (pro/con, ecosystem, note)).
|
||||
setCategoryInfo :: Uid Category -> CCategoryInfoEdit -> Guider NoContent
|
||||
setCategoryInfo catId CCategoryInfoEdit{..} = do
|
||||
category <- getCategoryOrFail catId
|
||||
-- TODO diff and merge
|
||||
(editTitle, _) <- dbUpdate $ SetCategoryTitle catId $ unH ccieTitle
|
||||
(editGroup, _) <- dbUpdate $ SetCategoryGroup catId $ unH ccieGroup
|
||||
(editStatus, _) <- dbUpdate $ SetCategoryStatus catId ccieStatus
|
||||
let oldEnabledSections = category ^. enabledSections
|
||||
let newEnabledSections = unH ccieSections
|
||||
(editSection, _) <- dbUpdate $ ChangeCategoryEnabledSections catId
|
||||
(newEnabledSections S.\\ oldEnabledSections)
|
||||
(oldEnabledSections S.\\ newEnabledSections)
|
||||
mapM_ addEdit [editTitle, editGroup, editStatus, editSection]
|
||||
pure NoContent
|
||||
setCategoryInfo catId CCategoryInfoEdit{..} =
|
||||
logHandler "setCategoryInfo" [attr "catId" catId] $ do
|
||||
category <- getCategoryOrFail catId
|
||||
-- TODO diff and merge
|
||||
(editTitle, _) <- dbUpdate $ SetCategoryTitle catId $ unH ccieTitle
|
||||
(editGroup, _) <- dbUpdate $ SetCategoryGroup catId $ unH ccieGroup
|
||||
(editStatus, _) <- dbUpdate $ SetCategoryStatus catId ccieStatus
|
||||
let oldEnabledSections = category ^. enabledSections
|
||||
let newEnabledSections = unH ccieSections
|
||||
(editSection, _) <- dbUpdate $ ChangeCategoryEnabledSections catId
|
||||
(newEnabledSections S.\\ oldEnabledSections)
|
||||
(oldEnabledSections S.\\ newEnabledSections)
|
||||
mapM_ addEdit [editTitle, editGroup, editStatus, editSection]
|
||||
pure NoContent
|
||||
|
||||
-- | Delete a category.
|
||||
deleteCategory :: Uid Category -> Guider NoContent
|
||||
deleteCategory catId = do
|
||||
_ <- getCategoryOrFail catId
|
||||
dbUpdate (DeleteCategory catId) >>= mapM_ addEdit
|
||||
pure NoContent
|
||||
deleteCategory catId =
|
||||
logHandler "deleteCategory" [attr "catId" catId] $ do
|
||||
_ <- getCategoryOrFail catId
|
||||
dbUpdate (DeleteCategory catId) >>= mapM_ addEdit
|
||||
pure NoContent
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Items
|
||||
@ -99,114 +114,128 @@ deleteCategory catId = do
|
||||
|
||||
-- | Get item by item id
|
||||
getItem :: Uid Item -> Guider CItemFull
|
||||
getItem itemId = toCItemFull <$> getItemOrFail itemId
|
||||
getItem itemId =
|
||||
logHandler "getItem" [attr "itemId" itemId] $ do
|
||||
toCItemFull <$> getItemOrFail itemId
|
||||
|
||||
-- | Create a new item, given the name.
|
||||
--
|
||||
-- Returns the ID of the created item. Unlike 'createCategory', allows items
|
||||
-- with duplicated names.
|
||||
createItem :: Uid Category -> Text -> Guider (Uid Item)
|
||||
createItem catId name' = do
|
||||
_ <- getCategoryOrFail catId
|
||||
when (T.null name') $ throwError err400{errBody = "Name not provided"}
|
||||
itemId <- randomShortUid
|
||||
time <- liftIO getCurrentTime
|
||||
addEdit . fst =<< dbUpdate (AddItem catId itemId name' time)
|
||||
pure itemId
|
||||
|
||||
-- TODO: move an item
|
||||
createItem catId name' =
|
||||
logHandler "createItem" [attr "catId" catId, attr "name" name'] $ do
|
||||
_ <- getCategoryOrFail catId
|
||||
when (T.null name') $ throwError err400{errReasonPhrase = "Name not provided"}
|
||||
itemId <- randomShortUid
|
||||
time <- liftIO getCurrentTime
|
||||
addEdit . fst =<< dbUpdate (AddItem catId itemId name' time)
|
||||
pure itemId
|
||||
|
||||
-- | Modify item info. Fields that are not present ('Nothing') are not modified.
|
||||
setItemInfo :: Uid Item -> CItemInfoEdit -> Guider NoContent
|
||||
setItemInfo itemId CItemInfoEdit{..} = do
|
||||
_ <- getItemOrFail itemId
|
||||
-- TODO diff and merge
|
||||
whenJust (unH ciieName) $ \ciieName' ->
|
||||
addEdit . fst =<< dbUpdate (SetItemName itemId ciieName')
|
||||
whenJust (unH ciieGroup) $ \ciieGroup' ->
|
||||
addEdit . fst =<< dbUpdate (SetItemGroup itemId ciieGroup')
|
||||
whenJust (unH ciieHackage) $ \ciieHackage' ->
|
||||
addEdit . fst =<< dbUpdate (SetItemHackage itemId ciieHackage')
|
||||
whenJust (unH ciieLink) $ \ciieLink' -> do
|
||||
addEdit . fst =<< dbUpdate (SetItemLink itemId ciieLink')
|
||||
pure NoContent
|
||||
setItemInfo itemId CItemInfoEdit{..} =
|
||||
logHandler "setItemInfo" [attr "itemId" itemId] $ do
|
||||
void $ getItemOrFail itemId
|
||||
-- TODO diff and merge
|
||||
whenJust (unH ciieName) $ \ciieName' ->
|
||||
addEdit . fst =<< dbUpdate (SetItemName itemId ciieName')
|
||||
whenJust (unH ciieGroup) $ \ciieGroup' ->
|
||||
addEdit . fst =<< dbUpdate (SetItemGroup itemId ciieGroup')
|
||||
whenJust (unH ciieHackage) $ \ciieHackage' ->
|
||||
addEdit . fst =<< dbUpdate (SetItemHackage itemId ciieHackage')
|
||||
whenJust (unH ciieLink) $ \ciieLink' -> do
|
||||
addEdit . fst =<< dbUpdate (SetItemLink itemId ciieLink')
|
||||
pure NoContent
|
||||
|
||||
-- | Set item's summary.
|
||||
setItemSummary :: Uid Item -> CTextEdit -> Guider NoContent
|
||||
setItemSummary itemId CTextEdit{..} = do
|
||||
serverModified <- markdownBlockMdSource . _itemSummary <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemSummary itemId $ unH cteModified)
|
||||
pure NoContent
|
||||
setItemSummary itemId CTextEdit{..} =
|
||||
logHandler "setItemSummary" [attr "itemId" itemId] $ do
|
||||
serverModified <- markdownBlockMdSource . _itemSummary <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemSummary itemId $ unH cteModified)
|
||||
pure NoContent
|
||||
|
||||
-- | Set item's ecosystem.
|
||||
setItemEcosystem :: Uid Item -> CTextEdit -> Guider NoContent
|
||||
setItemEcosystem itemId CTextEdit{..} = do
|
||||
serverModified <- markdownBlockMdSource . _itemEcosystem <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemEcosystem itemId $ unH cteModified)
|
||||
pure NoContent
|
||||
setItemEcosystem itemId CTextEdit{..} =
|
||||
logHandler "setItemEcosystem" [attr "itemId" itemId] $ do
|
||||
serverModified <- markdownBlockMdSource . _itemEcosystem <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemEcosystem itemId $ unH cteModified)
|
||||
pure NoContent
|
||||
|
||||
-- | Set item's notes.
|
||||
setItemNotes :: Uid Item -> CTextEdit -> Guider NoContent
|
||||
setItemNotes itemId CTextEdit{..} = do
|
||||
serverModified <- markdownTreeMdSource . _itemNotes <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemNotes itemId $ unH cteModified)
|
||||
pure NoContent
|
||||
setItemNotes itemId CTextEdit{..} =
|
||||
logHandler "setItemNotes" [attr "itemId" itemId] $ do
|
||||
serverModified <- markdownTreeMdSource . _itemNotes <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemNotes itemId $ unH cteModified)
|
||||
pure NoContent
|
||||
|
||||
-- | Delete an item.
|
||||
deleteItem :: Uid Item -> Guider NoContent
|
||||
deleteItem itemId = do
|
||||
_ <- getItemOrFail itemId
|
||||
dbUpdate (DeleteItem itemId) >>= mapM_ addEdit
|
||||
pure NoContent
|
||||
deleteItem itemId =
|
||||
logHandler "deleteItem" [attr "itemId" itemId] $ do
|
||||
void $ getItemOrFail itemId
|
||||
dbUpdate (DeleteItem itemId) >>= mapM_ addEdit
|
||||
pure NoContent
|
||||
|
||||
-- | Move item up or down
|
||||
moveItem :: Uid Item -> CMove -> Guider NoContent
|
||||
moveItem itemId CMove{..} = do
|
||||
_ <- getItemOrFail itemId
|
||||
addEdit =<< dbUpdate (MoveItem itemId (cmDirection == DirectionUp))
|
||||
pure NoContent
|
||||
moveItem itemId CMove{..} =
|
||||
logHandler "moveItem" [attr "itemId" itemId] $ do
|
||||
void $ getItemOrFail itemId
|
||||
addEdit =<< dbUpdate (MoveItem itemId (cmDirection == DirectionUp))
|
||||
pure NoContent
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Traits
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
-- | Get a trait (pro/con)
|
||||
getTrait :: Uid Item -> Uid Trait -> Guider CTrait
|
||||
getTrait itemId traitId = toCTrait <$> getTraitOrFail itemId traitId
|
||||
getTrait itemId traitId =
|
||||
logHandler "getTrait" [attr "itemId" itemId, attr "traitId" traitId] $ do
|
||||
toCTrait <$> getTraitOrFail itemId traitId
|
||||
|
||||
-- | Create a trait (pro/con).
|
||||
createTrait :: Uid Item -> CCreateTrait -> Guider (Uid Trait)
|
||||
createTrait itemId CCreateTrait{..} = do
|
||||
when (T.null cctContent) $ throwError err400{errBody = "Trait text not provided"}
|
||||
traitId <- randomShortUid
|
||||
addEdit . fst =<< case cctType of
|
||||
Con -> dbUpdate (AddCon itemId traitId cctContent)
|
||||
Pro -> dbUpdate (AddPro itemId traitId cctContent)
|
||||
pure traitId
|
||||
createTrait itemId CCreateTrait{..} =
|
||||
logHandler "createTrait" [attr "itemId" itemId] $ do
|
||||
when (T.null cctContent) $ throwError err400{errReasonPhrase = "Trait text not provided"}
|
||||
traitId <- randomShortUid
|
||||
addEdit . fst =<< case cctType of
|
||||
Con -> dbUpdate (AddCon itemId traitId cctContent)
|
||||
Pro -> dbUpdate (AddPro itemId traitId cctContent)
|
||||
pure traitId
|
||||
|
||||
-- | Update the text of a trait (pro/con).
|
||||
setTrait :: Uid Item -> Uid Trait -> CTextEdit -> Guider NoContent
|
||||
setTrait itemId traitId CTextEdit{..} = do
|
||||
serverModified <- markdownInlineMdSource . _traitContent <$> getTraitOrFail itemId traitId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetTraitContent itemId traitId $ unH cteModified)
|
||||
pure NoContent
|
||||
setTrait itemId traitId CTextEdit{..} =
|
||||
logHandler "setTrait" [attr "itemId" itemId, attr "traitId" traitId] $ do
|
||||
serverModified <- markdownInlineMdSource . _traitContent <$> getTraitOrFail itemId traitId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetTraitContent itemId traitId $ unH cteModified)
|
||||
pure NoContent
|
||||
|
||||
-- | Delete a trait (pro/con).
|
||||
deleteTrait :: Uid Item -> Uid Trait -> Guider NoContent
|
||||
deleteTrait itemId traitId = do
|
||||
_ <- getTraitOrFail itemId traitId
|
||||
dbUpdate (DeleteTrait itemId traitId) >>= mapM_ addEdit
|
||||
pure NoContent
|
||||
deleteTrait itemId traitId =
|
||||
logHandler "deleteTrait" [attr "itemId" itemId, attr "traitId" traitId] $ do
|
||||
void $ getTraitOrFail itemId traitId
|
||||
dbUpdate (DeleteTrait itemId traitId) >>= mapM_ addEdit
|
||||
pure NoContent
|
||||
|
||||
-- | Move trait up or down
|
||||
moveTrait :: Uid Item -> Uid Trait -> CMove -> Guider NoContent
|
||||
moveTrait itemId traitId CMove{..} = do
|
||||
_ <- getTraitOrFail itemId traitId
|
||||
addEdit =<< dbUpdate (MoveTrait itemId traitId (cmDirection == DirectionUp))
|
||||
pure NoContent
|
||||
moveTrait itemId traitId CMove{..} =
|
||||
logHandler "moveTrait" [attr "itemId" itemId, attr "traitId" traitId] $ do
|
||||
void $ getTraitOrFail itemId traitId
|
||||
addEdit =<< dbUpdate (MoveTrait itemId traitId (cmDirection == DirectionUp))
|
||||
pure NoContent
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Search
|
||||
@ -216,51 +245,58 @@ moveTrait itemId traitId CMove{..} = do
|
||||
--
|
||||
-- Returns at most 100 results.
|
||||
search :: Text -> Guider [CSearchResult]
|
||||
search searchQuery = do
|
||||
gs <- dbQuery GetGlobalState
|
||||
pure $ map toCSearchResult $ take 100 $ Search.search searchQuery gs
|
||||
search searchQuery =
|
||||
logHandler "search" [attr "query" searchQuery] $ do
|
||||
gs <- dbQuery GetGlobalState
|
||||
pure $ map toCSearchResult $ take 100 $ Search.search searchQuery gs
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Utils
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
-- | Update something in the database.
|
||||
dbUpdate :: (EventState event ~ GlobalState, UpdateEvent event)
|
||||
dbUpdate :: (EventState event ~ GlobalState, UpdateEvent event, Show event)
|
||||
=> event -> Guider (EventResult event)
|
||||
dbUpdate x = do
|
||||
logDebug $ "dbUpdate: " +|| x ||+ ""
|
||||
Context{..} <- ask
|
||||
liftIO $ do
|
||||
Acid.update cDB SetDirty
|
||||
Acid.update cDB x
|
||||
|
||||
-- | Read something from the database.
|
||||
dbQuery :: (EventState event ~ GlobalState, QueryEvent event)
|
||||
dbQuery :: (EventState event ~ GlobalState, QueryEvent event, Show event)
|
||||
=> event -> Guider (EventResult event)
|
||||
dbQuery x = do
|
||||
logDebug $ "dbQuery: " +|| x ||+ ""
|
||||
Context{..} <- ask
|
||||
liftIO $ Acid.query cDB x
|
||||
|
||||
-- Call this whenever any user-made change is applied to the database.
|
||||
-- | Call this whenever any user-made change is applied to the database.
|
||||
addEdit :: Edit -> Guider ()
|
||||
addEdit edit = unless (isVacuousEdit edit) $ do
|
||||
time <- liftIO getCurrentTime
|
||||
Context Config{..} _ RequestDetails{..} <- ask
|
||||
dbUpdate $ RegisterEdit edit rdIp time
|
||||
dbUpdate $ RegisterAction (Action'Edit edit) rdIp time _baseUrl rdReferer rdUserAgent
|
||||
postMatomo $ Matomo rdIp rdUserAgent rdReferer edit
|
||||
addEdit edit = push "addEdit" $ attr "edit" edit $ do
|
||||
if isVacuousEdit edit
|
||||
then logDebug "Vacuous edit, ignoring"
|
||||
else do
|
||||
logDebug "Going to register the edit"
|
||||
time <- liftIO getCurrentTime
|
||||
Context Config{..} _ RequestDetails{..} <- ask
|
||||
dbUpdate $ RegisterEdit edit rdIp time
|
||||
dbUpdate $ RegisterAction (Action'Edit edit) rdIp time _baseUrl rdReferer rdUserAgent
|
||||
postMatomo $ Matomo rdIp rdUserAgent rdReferer edit
|
||||
|
||||
-- | Helper. Get a category from database and throw error 404 when it doesn't exist.
|
||||
getCategoryOrFail :: Uid Category -> Guider Category
|
||||
getCategoryOrFail catId = do
|
||||
dbQuery (GetCategoryMaybe catId) >>= \case
|
||||
Nothing -> throwError $ err404 {errBody = "Category not found"}
|
||||
Nothing -> throwError $ err404 {errReasonPhrase = "Category not found"}
|
||||
Just cat -> pure cat
|
||||
|
||||
-- | Helper. Get an item from database and throw error 404 when the item doesn't exist.
|
||||
getItemOrFail :: Uid Item -> Guider Item
|
||||
getItemOrFail itemId = do
|
||||
dbQuery (GetItemMaybe itemId) >>= \case
|
||||
Nothing -> throwError $ err404 {errBody = "Item not found"}
|
||||
Nothing -> throwError $ err404 {errReasonPhrase = "Item not found"}
|
||||
Just item -> pure item
|
||||
|
||||
-- | Helper. Get a trait from database and throw error 404 when
|
||||
@ -268,10 +304,10 @@ getItemOrFail itemId = do
|
||||
getTraitOrFail :: Uid Item -> Uid Trait -> Guider Trait
|
||||
getTraitOrFail itemId traitId = do
|
||||
dbQuery (GetItemMaybe itemId) >>= \case
|
||||
Nothing -> throwError $ err404 {errBody = "Item not found"}
|
||||
Nothing -> throwError $ err404 {errReasonPhrase = "Item not found"}
|
||||
Just _ -> do
|
||||
dbQuery (GetTraitMaybe itemId traitId) >>= \case
|
||||
Nothing -> throwError $ err404 {errBody = "Trait not found"}
|
||||
Nothing -> throwError $ err404 {errReasonPhrase = "Trait not found"}
|
||||
Just trait -> pure trait
|
||||
|
||||
-- | Checker. When states of database before and after editing is different, fail with a conflict data.
|
||||
@ -287,4 +323,22 @@ checkConflict CTextEdit{..} serverModified = do
|
||||
, cmcServerModified = H serverModified
|
||||
, cmcMerged = H merged
|
||||
}
|
||||
throwError $ err409 {errBody = encode conflict}
|
||||
throwError $ err409 {
|
||||
errReasonPhrase = "Merge conflict occurred",
|
||||
errBody = encode conflict
|
||||
}
|
||||
|
||||
-- | Log invocation of a handler.
|
||||
--
|
||||
-- This function exists because otherwise it's easy to log that the handler
|
||||
-- has been called (at the very beginning of the handler).
|
||||
--
|
||||
-- TODO: it would be nice to somehow automatically get this logging from
|
||||
-- Servant for all handlers.
|
||||
logHandler
|
||||
:: Text -- ^ Handler name
|
||||
-> [Guider a -> Guider a] -- ^ Handler arguments, usually created by @attr "key" value@
|
||||
-> Guider a
|
||||
-> Guider a
|
||||
logHandler hName args body =
|
||||
foldr ($) (logDebug "Handler called" >> body) (push hName : args)
|
||||
|
@ -3,100 +3,51 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Guide.Api.Server
|
||||
( runApiServer
|
||||
)
|
||||
where
|
||||
|
||||
(
|
||||
runApiServer,
|
||||
)
|
||||
where
|
||||
|
||||
import Imports
|
||||
|
||||
import Data.Swagger.Lens hiding (format)
|
||||
import Network.Wai (Middleware)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Network.Wai (Middleware, Request)
|
||||
import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, corsOrigins,
|
||||
simpleCorsResourcePolicy)
|
||||
import Servant
|
||||
import Servant.API.Generic
|
||||
import Servant.Server.Generic
|
||||
import Servant.Swagger
|
||||
import Servant.Swagger.UI
|
||||
|
||||
-- putStrLn that works well with concurrency
|
||||
import Say (say)
|
||||
|
||||
import Guide.Api.Guider (Context (..), GuiderServer, guiderToHandler)
|
||||
import Guide.Api.Guider
|
||||
import Guide.Api.Methods
|
||||
import Guide.Api.Types
|
||||
import Guide.Config (Config (..))
|
||||
import Guide.Logger
|
||||
import Guide.Config
|
||||
import Guide.State
|
||||
|
||||
import Data.Acid as Acid
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import qualified Data.Acid as Acid
|
||||
|
||||
guiderServer :: Site GuiderServer
|
||||
guiderServer = Site
|
||||
{ _categorySite = toServant (CategorySite
|
||||
{ _getCategories = getCategories
|
||||
, _getCategory = getCategory
|
||||
, _createCategory = createCategory
|
||||
, _setCategoryNotes = setCategoryNotes
|
||||
, _setCategoryInfo = setCategoryInfo
|
||||
, _deleteCategory = deleteCategory }
|
||||
:: CategorySite GuiderServer)
|
||||
|
||||
, _itemSite = toServant (ItemSite
|
||||
{ _getItem = getItem
|
||||
, _createItem = createItem
|
||||
, _setItemInfo = setItemInfo
|
||||
, _setItemSummary = setItemSummary
|
||||
, _setItemEcosystem = setItemEcosystem
|
||||
, _setItemNotes = setItemNotes
|
||||
, _deleteItem = deleteItem
|
||||
, _moveItem = moveItem }
|
||||
:: ItemSite GuiderServer)
|
||||
|
||||
, _traitSite = toServant (TraitSite
|
||||
{ _getTrait = getTrait
|
||||
, _createTrait = createTrait
|
||||
, _setTrait = setTrait
|
||||
, _deleteTrait = deleteTrait
|
||||
, _moveTrait = moveTrait }
|
||||
:: TraitSite GuiderServer)
|
||||
|
||||
, _searchSite = toServant (SearchSite
|
||||
{ _search = search }
|
||||
:: SearchSite GuiderServer)
|
||||
}
|
||||
|
||||
-- | The type that 'runApiServer' serves.
|
||||
type FullApi =
|
||||
Api :<|>
|
||||
SwaggerSchemaUI "api" "swagger.json"
|
||||
|
||||
fullServer :: DB -> Config -> Server FullApi
|
||||
fullServer db config =
|
||||
api db config :<|>
|
||||
swaggerSchemaUIServer doc
|
||||
where
|
||||
doc = toSwagger (Proxy @Api)
|
||||
& info.title .~ "Aelve Guide API"
|
||||
& info.version .~ "alpha"
|
||||
|
||||
-- | 'hoistServer' brings custom type server to 'Handler' type server. Custom types not consumed by servant.
|
||||
api :: DB -> Config -> Server Api
|
||||
api db config = do
|
||||
requestDetails <- ask
|
||||
hoistServer (Proxy @Api) (guiderToHandler (Context config db requestDetails))
|
||||
(const $ toServant guiderServer)
|
||||
|
||||
-- | Serve the API on port 4400.
|
||||
--
|
||||
-- You can test this API by doing @withDB mempty runApiServer@.
|
||||
runApiServer :: Config -> AcidState GlobalState -> IO ()
|
||||
runApiServer Config{..} db = do
|
||||
say $ format "API is running on port {}" _portApi
|
||||
run _portApi $ corsPolicy $ serve (Proxy @FullApi) (fullServer db Config{..})
|
||||
runApiServer :: Logger -> Config -> Acid.AcidState GlobalState -> IO ()
|
||||
runApiServer logger Config{..} db = do
|
||||
logDebugIO logger $ format "API is running on port {}" _portApi
|
||||
let guideSettings = Warp.defaultSettings
|
||||
& Warp.setOnException (logException logger)
|
||||
& Warp.setPort _portApi
|
||||
Warp.runSettings guideSettings $ corsPolicy $
|
||||
serve (Proxy @FullApi) (fullServer db logger Config{..})
|
||||
where
|
||||
corsPolicy :: Middleware
|
||||
corsPolicy =
|
||||
@ -111,3 +62,85 @@ runApiServer Config{..} db = do
|
||||
, BSC.pack $ format "http://localhost:{}" portApi -- The /api endpoint
|
||||
], True)
|
||||
}
|
||||
|
||||
-- | An override for the default Warp exception handler.
|
||||
--
|
||||
-- Logs exceptions to the given 'Logger'.
|
||||
logException :: Logger -> Maybe Request -> SomeException -> IO ()
|
||||
logException logger mbReq ex =
|
||||
when (Warp.defaultShouldDisplayException ex) $
|
||||
logErrorIO logger $
|
||||
format "uncaught exception: {}; request info = {}" (show ex) (show mbReq)
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Servant servers
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
-- Collect API and Swagger server to united 'FullApi'. First takes precedence in case of overlap.
|
||||
fullServer :: DB -> Logger -> Config -> Server FullApi
|
||||
fullServer db di config = apiServer db di config :<|> docServer
|
||||
|
||||
-- Collect api out of guiders and convert them to handlers. Type 'type Server api = ServerT api Handler' needed it.
|
||||
apiServer :: DB -> Logger -> Config -> Server Api
|
||||
apiServer db di config = do
|
||||
requestDetails <- ask
|
||||
hoistServer (Proxy @Api) (guiderToHandler (Context config db requestDetails) di)
|
||||
(const $ toServant site)
|
||||
|
||||
-- | A 'Server' for Swagger docs.
|
||||
docServer :: Server (SwaggerSchemaUI "api" "swagger.json")
|
||||
docServer = swaggerSchemaUIServer doc
|
||||
where
|
||||
doc = toSwagger (Proxy @Api)
|
||||
& info.title .~ "Aelve Guide API"
|
||||
& info.version .~ "alpha"
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- API handlers put together ('Site')
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
site :: Site (AsServerT Guider)
|
||||
site = Site
|
||||
{ _categorySite = toServant categorySite
|
||||
, _itemSite = toServant itemSite
|
||||
, _traitSite = toServant traitSite
|
||||
, _searchSite = toServant searchSite
|
||||
}
|
||||
|
||||
-- Individual branches
|
||||
|
||||
categorySite :: CategorySite (AsServerT Guider)
|
||||
categorySite = CategorySite
|
||||
{ _getCategories = getCategories
|
||||
, _getCategory = getCategory
|
||||
, _createCategory = createCategory
|
||||
, _setCategoryNotes = setCategoryNotes
|
||||
, _setCategoryInfo = setCategoryInfo
|
||||
, _deleteCategory = deleteCategory
|
||||
}
|
||||
|
||||
itemSite :: ItemSite (AsServerT Guider)
|
||||
itemSite = ItemSite
|
||||
{ _getItem = getItem
|
||||
, _createItem = createItem
|
||||
, _setItemInfo = setItemInfo
|
||||
, _setItemSummary = setItemSummary
|
||||
, _setItemEcosystem = setItemEcosystem
|
||||
, _setItemNotes = setItemNotes
|
||||
, _deleteItem = deleteItem
|
||||
, _moveItem = moveItem
|
||||
}
|
||||
|
||||
traitSite :: TraitSite (AsServerT Guider)
|
||||
traitSite = TraitSite
|
||||
{ _getTrait = getTrait
|
||||
, _createTrait = createTrait
|
||||
, _setTrait = setTrait
|
||||
, _deleteTrait = deleteTrait
|
||||
, _moveTrait = moveTrait
|
||||
}
|
||||
|
||||
searchSite :: SearchSite (AsServerT Guider)
|
||||
searchSite = SearchSite
|
||||
{ _search = search
|
||||
}
|
||||
|
@ -388,6 +388,9 @@ data CCategoryInfo = CCategoryInfo
|
||||
instance A.ToJSON CCategoryInfo where
|
||||
toJSON = A.genericToJSON jsonOptions
|
||||
|
||||
instance A.FromJSON CCategoryInfo where
|
||||
parseJSON = A.genericParseJSON jsonOptions
|
||||
|
||||
instance ToSchema CCategoryInfo where
|
||||
declareNamedSchema = genericDeclareNamedSchema schemaOptions
|
||||
|
||||
@ -416,6 +419,9 @@ data CCategoryFull = CCategoryFull
|
||||
instance A.ToJSON CCategoryFull where
|
||||
toJSON = A.genericToJSON jsonOptions
|
||||
|
||||
instance A.FromJSON CCategoryFull where
|
||||
parseJSON = A.genericParseJSON jsonOptions
|
||||
|
||||
instance ToSchema CCategoryFull where
|
||||
declareNamedSchema = genericDeclareNamedSchema schemaOptions
|
||||
|
||||
@ -522,6 +528,9 @@ data CItemFull = CItemFull
|
||||
instance A.ToJSON CItemFull where
|
||||
toJSON = A.genericToJSON jsonOptions
|
||||
|
||||
instance A.FromJSON CItemFull where
|
||||
parseJSON = A.genericParseJSON jsonOptions
|
||||
|
||||
instance ToSchema CItemFull where
|
||||
declareNamedSchema = genericDeclareNamedSchema schemaOptions
|
||||
|
||||
@ -564,6 +573,9 @@ data CTrait = CTrait
|
||||
instance A.ToJSON CTrait where
|
||||
toJSON = A.genericToJSON jsonOptions
|
||||
|
||||
instance A.FromJSON CTrait where
|
||||
parseJSON = A.genericParseJSON jsonOptions
|
||||
|
||||
instance ToSchema CTrait where
|
||||
declareNamedSchema = genericDeclareNamedSchema schemaOptions
|
||||
|
||||
@ -583,6 +595,9 @@ data CMarkdown = CMarkdown
|
||||
instance A.ToJSON CMarkdown where
|
||||
toJSON = A.genericToJSON jsonOptions
|
||||
|
||||
instance A.FromJSON CMarkdown where
|
||||
parseJSON = A.genericParseJSON jsonOptions
|
||||
|
||||
instance ToSchema CMarkdown where
|
||||
declareNamedSchema = genericDeclareNamedSchema schemaOptions
|
||||
|
||||
@ -615,6 +630,9 @@ data CHeading = CHeading
|
||||
instance A.ToJSON CHeading where
|
||||
toJSON = A.genericToJSON jsonOptions
|
||||
|
||||
instance A.FromJSON CHeading where
|
||||
parseJSON = A.genericParseJSON jsonOptions
|
||||
|
||||
instance ToSchema CHeading where
|
||||
declareNamedSchema = genericDeclareNamedSchema schemaOptions
|
||||
|
||||
|
@ -13,14 +13,16 @@
|
||||
|
||||
|
||||
module Guide.Api.Utils
|
||||
( jsonOptions
|
||||
, schemaOptions
|
||||
, type (?)(..)
|
||||
, unH
|
||||
, Primitive
|
||||
, BranchTag
|
||||
, RequestDetails(..)
|
||||
) where
|
||||
(
|
||||
jsonOptions,
|
||||
schemaOptions,
|
||||
type (?)(..),
|
||||
unH,
|
||||
Primitive,
|
||||
BranchTag,
|
||||
RequestDetails(..),
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Imports
|
||||
|
@ -1,10 +1,9 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{- |
|
||||
App module defines types used by the Spock framework.
|
||||
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
|
||||
|
||||
-}
|
||||
-- | App module defines types used by the Spock framework.
|
||||
module Guide.App
|
||||
where
|
||||
|
||||
|
@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{- |
|
||||
Server config. For instance, the admin password is stored here, as well as
|
||||
the base url (for correct link generation in feeds).
|
||||
-}
|
||||
-- | Server config. For instance, the admin password is stored here, as well
|
||||
-- as the base url (for correct link generation in feeds).
|
||||
module Guide.Config
|
||||
(
|
||||
Config(..),
|
||||
@ -31,22 +29,48 @@ import qualified Data.ByteString.Lazy as BSL
|
||||
|
||||
-- | Site config. Stored in @config.json@.
|
||||
data Config = Config {
|
||||
_baseUrl :: Url, -- ^ URL where the site is deployed. Used
|
||||
-- for generating feeds (which require
|
||||
-- absolute URLs)
|
||||
_googleToken :: Text, -- ^ Google site verification token. Will
|
||||
-- be inserted into all pages
|
||||
_adminPassword :: Text, -- ^ Password for the admin user
|
||||
_discussLink :: Maybe Url, -- ^ Link to a place to discuss the site.
|
||||
-- Will be placed in the header
|
||||
_matomoLink :: Maybe Url, -- ^ Link of Matomo to send statistic
|
||||
-- of user's action. Format of link shoud be
|
||||
-- like <http://localhost:8081/piwik.php>
|
||||
_portMain :: Int, -- ^ Port for the main site.
|
||||
_portApi :: Int, -- ^ Port for the API.
|
||||
_portEkg :: Int, -- ^ Port for EKG stats.
|
||||
_cors :: Bool, -- ^ CORS switch on/off
|
||||
_ekg :: Bool -- ^ EKG switch on/off
|
||||
-- | URL where the site is deployed. Used for generating feeds (which
|
||||
-- require absolute URLs).
|
||||
_baseUrl :: Url,
|
||||
|
||||
-- | Google site verification token. Will be inserted into all pages.
|
||||
_googleToken :: Text,
|
||||
|
||||
-- | Password for the admin user.
|
||||
_adminPassword :: Text,
|
||||
|
||||
-- | Link to a place to discuss the site. Will be placed in the header
|
||||
_discussLink :: Maybe Url,
|
||||
|
||||
-- | Link to Matomo to gather analytics about user actions. Format of the
|
||||
-- link shoud be like <http://localhost:8081/piwik.php>.
|
||||
_matomoLink :: Maybe Url,
|
||||
|
||||
-- | Port for serving the main site (old backend and frontend).
|
||||
_portMain :: Int,
|
||||
|
||||
-- | Port for serving the API.
|
||||
_portApi :: Int,
|
||||
|
||||
-- | Port for serving EKG stats.
|
||||
_portEkg :: Int,
|
||||
|
||||
-- | CORS switch on/off.
|
||||
_cors :: Bool,
|
||||
|
||||
-- | EKG switch on/off.
|
||||
_ekg :: Bool,
|
||||
|
||||
-- | Whether to log to @stderr@.
|
||||
_logToStderr :: Bool,
|
||||
|
||||
-- | Whether to log to a file. Can be turned on together with
|
||||
-- '_logToStderr'.
|
||||
_logToFile :: Maybe FilePath,
|
||||
|
||||
-- | A formatting string for log timestamps. For the description of
|
||||
-- available formatters, see 'formatTime'.
|
||||
_logTimeFormat :: String
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@ -63,35 +87,45 @@ instance Default Config where
|
||||
_portApi = 4400,
|
||||
_portEkg = 5050,
|
||||
_cors = False,
|
||||
_ekg = 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
|
||||
_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 ]
|
||||
"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
|
||||
-- doesn't exist).
|
||||
|
@ -1,8 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
{- | Diff- and merge-related things.
|
||||
-}
|
||||
-- | Diff- and merge-related things.
|
||||
module Guide.Diff
|
||||
(
|
||||
-- * Diffing
|
||||
|
@ -1,6 +1,5 @@
|
||||
{- | An algorithm for merging users' edits. Specifically, there's just one
|
||||
function – 'merge' – and it simply does a three-way diff.
|
||||
-}
|
||||
-- | An algorithm for merging users' edits. Specifically, there's just one
|
||||
-- function – 'merge' – and it simply does a three-way diff.
|
||||
module Guide.Diff.Merge
|
||||
(
|
||||
merge,
|
||||
|
@ -3,9 +3,7 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{- |
|
||||
All rest API handlers.
|
||||
-}
|
||||
-- | All rest API handlers.
|
||||
module Guide.Handlers
|
||||
(
|
||||
methods,
|
||||
|
@ -4,14 +4,14 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
|
||||
|
||||
-- TODO: try to make it more type-safe somehow?
|
||||
|
||||
{- |
|
||||
Javascript methods used for the site.
|
||||
|
||||
Some Javascript can also be found in .widget files. Hopefully, in the future
|
||||
this whole module would be removed.
|
||||
-}
|
||||
-- | Javascript methods used for the site.
|
||||
--
|
||||
-- Some Javascript can also be found in .widget files. Hopefully, in the
|
||||
-- future this whole module would be removed.
|
||||
module Guide.JS where
|
||||
|
||||
|
||||
@ -97,21 +97,19 @@ instance (ToJS a,ToJS b,ToJS c,ToJS d,ToJS e) => JSParams (a,b,c,d,e) where
|
||||
instance (ToJS a,ToJS b,ToJS c,ToJS d,ToJS e,ToJS f) => JSParams (a,b,c,d,e,f) where
|
||||
jsParams (a,b,c,d,e,f) = [toJS a, toJS b, toJS c, toJS d, toJS e, toJS f]
|
||||
|
||||
{- |
|
||||
This hacky class lets you construct and use Javascript functions; you give
|
||||
'makeJSFunction' function name, function parameters, and function body, and
|
||||
you get a polymorphic value of type @JSFunction a => a@, which you can use
|
||||
either as a complete function definition (if you set @a@ to be @JS@), or as a
|
||||
function that you can give some parameters and it would return a Javascript
|
||||
call:
|
||||
|
||||
> plus = makeJSFunction "plus" ["a", "b"] "return a+b;"
|
||||
|
||||
>>> plus :: JS
|
||||
JS "function plus(a,b) {\nreturn a+b;}\n"
|
||||
>>> plus (3, 5) :: JS
|
||||
JS "plus(3,5);"
|
||||
-}
|
||||
-- | This hacky class lets you construct and use Javascript functions; you
|
||||
-- give 'makeJSFunction' function name, function parameters, and function
|
||||
-- body, and you get a polymorphic value of type @JSFunction a => a@, which
|
||||
-- you can use either as a complete function definition (if you set @a@ to
|
||||
-- be @JS@), or as a function that you can give some parameters and it would
|
||||
-- return a Javascript call:
|
||||
--
|
||||
-- > plus = makeJSFunction "plus" ["a", "b"] "return a+b;"
|
||||
--
|
||||
-- >>> plus :: JS
|
||||
-- JS "function plus(a,b) {\nreturn a+b;}\n"
|
||||
-- >>> plus (3, 5) :: JS
|
||||
-- JS "plus(3,5);"
|
||||
class JSFunction a where
|
||||
makeJSFunction
|
||||
:: Text -- ^ Name
|
||||
@ -119,7 +117,7 @@ class JSFunction a where
|
||||
-> Text -- ^ Definition
|
||||
-> a
|
||||
|
||||
-- This generates function definition
|
||||
-- | Generates a function definition
|
||||
instance JSFunction JS where
|
||||
makeJSFunction fName fParams fDef =
|
||||
let paramList = T.intercalate "," fParams
|
||||
@ -127,23 +125,23 @@ instance JSFunction JS where
|
||||
+|indentF 2 (build fDef)|+
|
||||
"}\n"
|
||||
|
||||
-- This generates a function that takes arguments and produces a Javascript
|
||||
-- | Generates a function that takes arguments and produces a Javascript
|
||||
-- function call
|
||||
instance JSParams a => JSFunction (a -> JS) where
|
||||
makeJSFunction fName _fParams _fDef = \args ->
|
||||
let paramList = T.intercalate "," (map fromJS (jsParams args))
|
||||
in JS $ format "{}({});" fName paramList
|
||||
|
||||
-- This also produces a Javascript function call, but prefixes the function
|
||||
-- with "this."; this is needed for event handlers in Vue for some reason
|
||||
-- | Also produces a Javascript function call, but prefixes the function
|
||||
-- with @this.@; this is needed for event handlers in Vue for some reason
|
||||
newtype WithThis a = WithThis { withThis :: a }
|
||||
|
||||
instance JSFunction a => JSFunction (WithThis a) where
|
||||
makeJSFunction fName fParams fDef = WithThis $
|
||||
makeJSFunction ("this." <> fName) fParams fDef
|
||||
|
||||
-- This isn't a standalone function and so it doesn't have to be listed in
|
||||
-- 'allJSFunctions'.
|
||||
-- | NB: this isn't a standalone function and so it doesn't have to be
|
||||
-- listed in 'allJSFunctions'.
|
||||
assign :: ToJS x => JS -> x -> JS
|
||||
assign v x = JS $ format "{} = {};" v (toJS x)
|
||||
|
||||
|
30
back/src/Guide/Logger.hs
Normal file
30
back/src/Guide/Logger.hs
Normal file
@ -0,0 +1,30 @@
|
||||
-- | A small logging framework for Guide, implemented as a wrapper over the
|
||||
-- "di" package.
|
||||
--
|
||||
-- Used mostly in "Guide.Main" and "Guide.Api.Methods".
|
||||
--
|
||||
-- Some internals are exposed in modules under @Guider.Logger.*@, but you
|
||||
-- shouldn't need them. If you do, consider exporting them from this module.
|
||||
module Guide.Logger
|
||||
(
|
||||
-- * Creating loggers
|
||||
withLogger,
|
||||
|
||||
-- * Logging with 'LoggerT'
|
||||
HasLogger,
|
||||
LoggerT, runLoggerT,
|
||||
logDebug, logInfo, logWarning, logError,
|
||||
-- ** Building log paths
|
||||
push, attr,
|
||||
|
||||
-- * Logging without a monad transformer
|
||||
Logger,
|
||||
logDebugIO, logInfoIO, logWarningIO, logErrorIO,
|
||||
-- ** Building log paths
|
||||
pushLogger, attrLogger,
|
||||
)
|
||||
where
|
||||
|
||||
import Guide.Logger.Types
|
||||
import Guide.Logger.Functions
|
||||
import Guide.Logger.Run
|
57
back/src/Guide/Logger/Functions.hs
Normal file
57
back/src/Guide/Logger/Functions.hs
Normal file
@ -0,0 +1,57 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Guide.Logger.Functions
|
||||
(
|
||||
-- * Loggers in 'MonadDi'
|
||||
logDebug, logInfo, logWarning, logError,
|
||||
push, attr,
|
||||
|
||||
-- * Raw loggers
|
||||
logDebugIO, logInfoIO, logWarningIO, logErrorIO,
|
||||
pushLogger, attrLogger,
|
||||
)
|
||||
where
|
||||
|
||||
import Imports
|
||||
|
||||
import qualified Df1
|
||||
import qualified Di.Core
|
||||
import qualified Di
|
||||
|
||||
import Guide.Logger.Types
|
||||
|
||||
-- NB: 'Df1' provides more severity types, but they are too finely-grained
|
||||
-- for us
|
||||
|
||||
logDebug, logInfo, logWarning, logError :: HasLogger m => Text -> m ()
|
||||
logDebug = Di.debug . Df1.message
|
||||
logInfo = Di.info . Df1.message
|
||||
logWarning = Di.warning . Df1.message
|
||||
logError = Di.error . Df1.message
|
||||
|
||||
logDebugIO, logInfoIO, logWarningIO, logErrorIO :: Logger -> Text -> IO ()
|
||||
logDebugIO di = Di.Core.log di Debug . Df1.message
|
||||
logInfoIO di = Di.Core.log di Info . Df1.message
|
||||
logWarningIO di = Di.Core.log di Warning . Df1.message
|
||||
logErrorIO di = Di.Core.log di Error . Df1.message
|
||||
|
||||
-- | Push context (method name, component name, etc) to the log path:
|
||||
--
|
||||
-- >>> push "getCategory" $ do ...
|
||||
push :: HasLogger m => Text -> m a -> m a
|
||||
push key = Di.push (Di.segment key)
|
||||
|
||||
-- | Push an attribute to the log path. Useful for giving context:
|
||||
--
|
||||
-- >>> push "getCategory" $ attr "catId" catId $ do ...
|
||||
attr :: (HasLogger m, Show val) => Text -> val -> m a -> m a
|
||||
attr key = Di.attr (Di.key key) . Di.value . show
|
||||
|
||||
-- | Like 'push', but operates on a 'Logger'.
|
||||
pushLogger :: Text -> Logger -> Logger
|
||||
pushLogger key = Di.Core.push (Df1.Push (Di.segment key))
|
||||
|
||||
-- | Like 'attr', but operates on a 'Logger'.
|
||||
attrLogger :: Show val => Text -> val -> Logger -> Logger
|
||||
attrLogger key val = Di.Core.push (Df1.Attr (Di.key key) (Di.value (show val)))
|
93
back/src/Guide/Logger/Run.hs
Normal file
93
back/src/Guide/Logger/Run.hs
Normal file
@ -0,0 +1,93 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Guide.Logger.Run
|
||||
(
|
||||
withLogger,
|
||||
)
|
||||
where
|
||||
|
||||
import Imports
|
||||
import Say (sayErr, hSay)
|
||||
import Control.Monad.Extra
|
||||
import Data.Time.Format ()
|
||||
import Data.Time.Clock.System
|
||||
import System.IO
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Df1
|
||||
import qualified Di.Core
|
||||
|
||||
import Guide.Config
|
||||
import Guide.Logger.Types
|
||||
import Guide.Logger.Functions
|
||||
|
||||
-- | Create a 'Logger' for the given 'Config' and run an action with that
|
||||
-- logger. Depending on the 'Config', we might log to @stderr@, to a file,
|
||||
-- or both.
|
||||
--
|
||||
-- Log level is customizable by setting the @LOG_LEVEL@ environment
|
||||
-- variable.
|
||||
--
|
||||
-- /Exception handling:/
|
||||
--
|
||||
-- Uncaught exceptions are caught and logged. Since Servant exceptions don't
|
||||
-- escape Servant, they are logged where they are thrown (see @instance
|
||||
-- MonadError Guider@). Uncaught Servant exceptions are caught and logged in
|
||||
-- Warp.
|
||||
withLogger :: Config -> (Logger -> IO ()) -> IO ()
|
||||
withLogger Config{..} act = do
|
||||
logLvlEnv <- lookupEnv "LOG_LEVEL"
|
||||
let logLvl = fromMaybe Debug (readMaybe =<< logLvlEnv)
|
||||
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
|
||||
whenJust logFileHandle $ \h -> hSay h formattedLogLine
|
||||
Di.Core.new logHandler $ \logger ->
|
||||
act logger `catch` \(e :: SomeException) ->
|
||||
logErrorIO logger ("uncaught exception: "+||e||+"")
|
||||
|
||||
-- | Pretty-print a log line.
|
||||
showLogLine
|
||||
:: String -- ^ Time format
|
||||
-> LogLine
|
||||
-> Text
|
||||
showLogLine timeFormat (Di.Core.Log time lvl path msg) =
|
||||
format "[{}] {}: {} | {}" time' (show lvl) path' msg'
|
||||
where
|
||||
time' = formatTime defaultTimeLocale timeFormat (systemToUTCTime time)
|
||||
path' = case showPath path of "" -> "<root>"; s -> s
|
||||
msg' = T.replace "\n" ";" (toText (Df1.unMessage msg))
|
||||
|
||||
-- | Pretty-print a log path.
|
||||
--
|
||||
-- >>> showPath [Push "api", Push "createItem", Attr "catId" "wseresd", Attr "name" "Foo"]
|
||||
-- "api > getCategory catId=\"wseresd\" name=\"Foo\""
|
||||
showPath :: Foldable t => t Path -> Text
|
||||
showPath path = go (toList path)
|
||||
where
|
||||
go :: [Path] -> Text
|
||||
go (a : b : xs) = showPiece a <> separator a b <> go (b : xs)
|
||||
go [a] = showPiece a
|
||||
go [] = ""
|
||||
|
||||
showPiece :: Path -> Text
|
||||
showPiece = \case
|
||||
Df1.Push a -> toText (Df1.unSegment a)
|
||||
Df1.Attr k v -> toText $ mconcat [Df1.unKey k, "=", Df1.unValue v]
|
||||
|
||||
separator :: Path -> Path -> Text
|
||||
separator _ (Push _) = " > "
|
||||
separator _ _ = " "
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Utilities
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
-- | Like 'withFile', but on @Maybe FilePath@.
|
||||
mbWithFile :: Maybe FilePath -> IOMode -> (Maybe Handle -> IO r) -> IO r
|
||||
mbWithFile Nothing _ act = act Nothing
|
||||
mbWithFile (Just fp) mode act = withFile fp mode (act . Just)
|
51
back/src/Guide/Logger/Types.hs
Normal file
51
back/src/Guide/Logger/Types.hs
Normal file
@ -0,0 +1,51 @@
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for "instance Read Df1.Level"
|
||||
|
||||
-- | The logger monad and associated types.
|
||||
module Guide.Logger.Types
|
||||
(
|
||||
-- * Main types
|
||||
HasLogger,
|
||||
LoggerT, runLoggerT,
|
||||
Logger,
|
||||
|
||||
-- * Internals
|
||||
-- ** Log pieces
|
||||
LogLine,
|
||||
Df1.Level(..),
|
||||
Df1.Path(..),
|
||||
Df1.Message,
|
||||
)
|
||||
where
|
||||
|
||||
import Imports
|
||||
|
||||
import Di.Core
|
||||
import Di.Monad
|
||||
|
||||
import qualified Df1
|
||||
|
||||
-- | Monads where logging is possible.
|
||||
--
|
||||
-- This is a type synonym, but you can still write @deriving HasLogger@.
|
||||
type HasLogger = MonadDi Df1.Level Df1.Path Df1.Message
|
||||
|
||||
-- | Monad transformer that allows logging with functions in "Guide.Logger".
|
||||
type LoggerT = DiT Df1.Level Df1.Path Df1.Message
|
||||
|
||||
-- | Execute a 'LoggerT' given an existing logger.
|
||||
runLoggerT :: MonadIO m => Logger -> LoggerT m a -> m a
|
||||
runLoggerT = runDiT
|
||||
|
||||
-- | A structure that allows logging without a 'LoggerT'.
|
||||
type Logger = Di Df1.Level Df1.Path Df1.Message
|
||||
|
||||
-- | A single log message together with all attributes.
|
||||
type LogLine = Log Df1.Level Df1.Path Df1.Message
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Orphans
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
deriving instance Read Df1.Level
|
@ -6,14 +6,12 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{- |
|
||||
Description : The main module that starts the server.
|
||||
|
||||
This module provides two functions that are of interest:
|
||||
|
||||
* Run 'main' to actually start the server.
|
||||
* Run 'mainWith' to run it with a custom config.
|
||||
-}
|
||||
-- | Description : The main module that starts the server.
|
||||
--
|
||||
-- This module provides two functions that are of interest:
|
||||
--
|
||||
-- * Run 'main' to actually start the server.
|
||||
-- * Run 'mainWith' to run it with a custom config.
|
||||
module Guide.Main
|
||||
(
|
||||
main,
|
||||
@ -48,8 +46,7 @@ import Data.Serialize.Get as Cereal
|
||||
import System.IO
|
||||
-- Catching Ctrl-C and termination
|
||||
import System.Signal
|
||||
-- putStrLn that works well with concurrency
|
||||
import Say (say)
|
||||
|
||||
-- HVect
|
||||
import Data.HVect hiding (length)
|
||||
|
||||
@ -57,6 +54,7 @@ import Guide.Api (runApiServer)
|
||||
import Guide.App
|
||||
import Guide.Config
|
||||
import Guide.Handlers
|
||||
import Guide.Logger
|
||||
import Guide.JS (JS (..), allJSFunctions)
|
||||
import Guide.Routes (authRoute, haskellRoute)
|
||||
import Guide.ServerStuff
|
||||
@ -90,9 +88,6 @@ acid-state. Acid-state works as follows:
|
||||
'dbUpdate'/'dbQuery' and types (GetItem, SetItemName, etc) from the
|
||||
Types.hs module.
|
||||
|
||||
* When doing a 'dbUpdate', don't forget to 'invalidateCache'! Though in
|
||||
most cases you'll likely want to use 'uncache' instead.
|
||||
|
||||
* The data is kept in-memory, but all changes are logged to the disk (which
|
||||
lets us recover the state in case of a crash by reapplying the changes)
|
||||
and you can't access the state directly. When the application exits, it
|
||||
@ -134,36 +129,32 @@ lucidWithConfig x = do
|
||||
|
||||
-- | Start the site.
|
||||
main :: IO ()
|
||||
main = do
|
||||
config <- readConfig
|
||||
mainWith config
|
||||
main = mainWith =<< readConfig
|
||||
|
||||
-- | Start the site with a specific 'Config'.
|
||||
mainWith :: Config -> IO ()
|
||||
mainWith config@Config{..} = do
|
||||
-- 'main' can be started many times and if the cache isn't cleared changes
|
||||
-- won't be visible
|
||||
do args <- getArgs
|
||||
let option = headDef "" args
|
||||
when (option == "--dry-run") $ do
|
||||
db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
|
||||
say "loaded the database successfully"
|
||||
closeAcidState db
|
||||
exitSuccess
|
||||
-- USAGE: --load-public <filename>
|
||||
-- loads PublicDB from <filename>, converts it to GlobalState, saves & exits
|
||||
when (option == "--load-public") $ do
|
||||
let path = fromMaybe
|
||||
(error "you haven't provided public DB file name")
|
||||
(args ^? ix 1)
|
||||
(Cereal.runGet SafeCopy.safeGet <$> BS.readFile path) >>= \case
|
||||
Left err -> error err
|
||||
Right publicDB -> do
|
||||
db <- openLocalStateFrom "state/" emptyState
|
||||
Acid.update db (ImportPublicDB publicDB)
|
||||
createCheckpointAndClose' db
|
||||
say "PublicDB imported to GlobalState"
|
||||
exitSuccess
|
||||
mainWith config@Config{..} = withLogger config $ \logger -> do
|
||||
args <- getArgs
|
||||
let option = headDef "" args
|
||||
when (option == "--dry-run") $ do
|
||||
db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
|
||||
logDebugIO logger "loaded the database successfully"
|
||||
closeAcidState db
|
||||
exitSuccess
|
||||
-- USAGE: --load-public <filename>
|
||||
-- loads PublicDB from <filename>, converts it to GlobalState, saves & exits
|
||||
when (option == "--load-public") $ do
|
||||
let path = fromMaybe
|
||||
(error "you haven't provided public DB file name")
|
||||
(args ^? ix 1)
|
||||
(Cereal.runGet SafeCopy.safeGet <$> BS.readFile path) >>= \case
|
||||
Left err -> error err
|
||||
Right publicDB -> do
|
||||
db <- openLocalStateFrom "state/" emptyState
|
||||
Acid.update db (ImportPublicDB publicDB)
|
||||
createCheckpointAndClose' db
|
||||
logDebugIO logger "PublicDB imported to GlobalState"
|
||||
exitSuccess
|
||||
-- When we run in GHCi and we exit the main thread, the EKG thread (that
|
||||
-- runs the localhost:5050 server which provides statistics) may keep
|
||||
-- running. This makes running this in GHCi annoying, because you have to
|
||||
@ -174,7 +165,7 @@ mainWith config@Config{..} = do
|
||||
when _ekg $ do
|
||||
-- Killing EKG has to be done last, because of
|
||||
-- <https://github.com/tibbe/ekg/issues/62>
|
||||
say "Killing EKG"
|
||||
logDebugIO logger "Killing EKG"
|
||||
mapM_ killThread =<< readIORef ekgId
|
||||
putMVar workFinished ()
|
||||
installTerminationCatcher =<< myThreadId
|
||||
@ -189,7 +180,7 @@ mainWith config@Config{..} = do
|
||||
mWaiMetrics <- if _ekg
|
||||
then do
|
||||
ekg <- do
|
||||
say $ format "EKG is running on port {}" _portEkg
|
||||
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)
|
||||
@ -205,7 +196,7 @@ mainWith config@Config{..} = do
|
||||
pure (Just waiMetrics)
|
||||
else pure Nothing
|
||||
-- Run the API
|
||||
_ <- Slave.fork $ runApiServer config db
|
||||
_ <- Slave.fork $ runApiServer (pushLogger "api" logger) config db
|
||||
-- Run the server
|
||||
let serverState = ServerState {
|
||||
_config = config,
|
||||
@ -227,7 +218,7 @@ mainWith config@Config{..} = do
|
||||
spc_maxRequestSize = Just (1024*1024),
|
||||
spc_csrfProtection = True,
|
||||
spc_sessionCfg = sessionCfg }
|
||||
say $ format "Spock is running on port {}" _portMain
|
||||
logDebugIO logger $ format "Spock is running on port {}" _portMain
|
||||
runSpockNoBanner _portMain $ spock spockConfig $ guideApp mWaiMetrics
|
||||
forever (threadDelay (1000000 * 60))
|
||||
`finally` (killThread workThread >> takeMVar workFinished)
|
||||
@ -415,10 +406,9 @@ data Quit = CtrlC | ServiceStop
|
||||
|
||||
instance Exception Quit
|
||||
|
||||
{- | Set up a handler that would catch SIGINT (i.e. Ctrl-C) and SIGTERM (i.e.
|
||||
service stop) and throw an exception instead of the signal. This lets us
|
||||
create a checkpoint and close connections on exit.
|
||||
-}
|
||||
-- | Set up a handler that would catch SIGINT (i.e. Ctrl-C) and SIGTERM
|
||||
-- (i.e. service stop) and throw an exception instead of the signal. This
|
||||
-- lets us create a checkpoint and close connections on exit.
|
||||
installTerminationCatcher
|
||||
:: ThreadId -- ^ Thread to kill when the signal comes
|
||||
-> IO ()
|
||||
|
@ -5,11 +5,9 @@
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
|
||||
{- |
|
||||
Everything concerning rendering and processing Markdown.
|
||||
|
||||
Currently we use the @cmark@ package as the Markdown parser.
|
||||
-}
|
||||
-- | Everything concerning rendering and processing Markdown.
|
||||
--
|
||||
-- Currently we use the @cmark@ package as the Markdown parser.
|
||||
module Guide.Markdown
|
||||
(
|
||||
-- * Types
|
||||
|
@ -1,13 +1,16 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
{- | Functions for interacting with Matomo (<https://matomo.org/>, our web analytics).
|
||||
Matomo docs: <https://developer.matomo.org/api-reference/tracking-api>.
|
||||
-}
|
||||
-- | Functions for interacting with Matomo (<https://matomo.org/>, our web
|
||||
-- analytics).
|
||||
--
|
||||
-- Matomo docs: <https://developer.matomo.org/api-reference/tracking-api>.
|
||||
module Guide.Matomo
|
||||
( Matomo(..)
|
||||
, postMatomo
|
||||
) where
|
||||
(
|
||||
Matomo(..),
|
||||
postMatomo,
|
||||
)
|
||||
where
|
||||
|
||||
import Imports
|
||||
|
||||
@ -21,6 +24,7 @@ import Guide.Api.Guider (Context (..), Guider)
|
||||
import Guide.Config (Config (..))
|
||||
import Guide.Types.Edit (Edit (..))
|
||||
import Guide.Utils (Url)
|
||||
import Guide.Logger
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
@ -35,7 +39,7 @@ data Matomo = Matomo
|
||||
|
||||
-- | Notify Matomo that an edit has been made.
|
||||
postMatomo :: Matomo -> Guider ()
|
||||
postMatomo Matomo{..} = do
|
||||
postMatomo Matomo{..} = push "postMatomo" $ do
|
||||
Context Config{..} _ _ <- ask
|
||||
whenJust _matomoLink $ \matomo -> liftIO $ do
|
||||
async $ do
|
||||
@ -62,4 +66,3 @@ postMatomo Matomo{..} = do
|
||||
. show
|
||||
piwik :: Url -> String
|
||||
piwik matomo = format "POST {}" matomo
|
||||
|
||||
|
@ -27,13 +27,12 @@ data SearchResult
|
||||
| SRItemEcosystem Category Item
|
||||
deriving (Show, Generic)
|
||||
|
||||
{- | Find things matching a simple text query, and return results ranked by
|
||||
importance. Categories are considered more important than items.
|
||||
|
||||
Currently 'search' doesn't do any fuzzy search whatsoever – only direct word
|
||||
matches are considered. See 'match' for the description of the matching
|
||||
algorithm.
|
||||
-}
|
||||
-- | Find things matching a simple text query, and return results ranked by
|
||||
-- importance. Categories are considered more important than items.
|
||||
--
|
||||
-- Currently 'search' doesn't do any fuzzy search whatsoever – only direct
|
||||
-- word matches are considered. See 'match' for the description of the
|
||||
-- matching algorithm.
|
||||
search :: Text -> GlobalState -> [SearchResult]
|
||||
search query gs =
|
||||
-- category titles
|
||||
@ -57,11 +56,10 @@ search query gs =
|
||||
sortByRank :: [(a, Int)] -> [a]
|
||||
sortByRank = map fst . sortOn (Down . snd)
|
||||
|
||||
{- | How many words in two strings match?
|
||||
|
||||
Words are defined as sequences of letters, digits and characters like “-”;
|
||||
separators are everything else. Comparisons are case-insensitive.
|
||||
-}
|
||||
-- | How many words in two strings match?
|
||||
--
|
||||
-- Words are defined as sequences of letters, digits and characters like
|
||||
-- “-”; separators are everything else. Comparisons are case-insensitive.
|
||||
match :: Text -> Text -> Int
|
||||
match a b = common (getWords a) (getWords b)
|
||||
where
|
||||
|
@ -4,15 +4,13 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
{- |
|
||||
Spock state, functions for manipulating it, handler helpers, and so on.
|
||||
|
||||
TODO: this is not the best name for a module. Really.
|
||||
-}
|
||||
-- | Spock state, functions for manipulating it, handler helpers, and so on.
|
||||
--
|
||||
-- TODO: this is not the best name for a module. Really.
|
||||
module Guide.ServerStuff
|
||||
(
|
||||
ServerState(..),
|
||||
getConfig,
|
||||
getConfig,
|
||||
dbUpdate,
|
||||
dbQuery,
|
||||
|
||||
@ -56,8 +54,7 @@ getConfig :: (Monad m, HasSpock m, SpockState m ~ ServerState)
|
||||
=> m Config
|
||||
getConfig = _config <$> Spock.getState
|
||||
|
||||
-- | Update something in the database. Don't forget to 'invalidateCache' or
|
||||
-- use 'uncache' when you update something that is cached.
|
||||
-- | Update something in the database.
|
||||
--
|
||||
-- Example: @dbUpdate (DeleteCategory catId)@
|
||||
--
|
||||
@ -99,14 +96,7 @@ addEdit ed = do
|
||||
dbUpdate (RegisterAction (Action'Edit ed)
|
||||
mbIP time baseUrl mbReferrer mbUA)
|
||||
|
||||
-- | Do an action that would undo an edit.
|
||||
--
|
||||
-- 'Left' signifies failure.
|
||||
--
|
||||
-- This doesn't do cache invalidation (you have to do it at the call site
|
||||
-- using 'invalidateCacheForEdit').
|
||||
--
|
||||
-- TODO: make this do cache invalidation.
|
||||
-- | Do an action that would undo an edit. 'Left' signifies failure.
|
||||
--
|
||||
-- TODO: many of these don't work when the changed category, item, etc has
|
||||
-- been deleted; this should change.
|
||||
|
@ -3,14 +3,12 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# LANGUAGE StandaloneDeriving#-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
|
||||
{- |
|
||||
Site's database, and methods for manipulating it.
|
||||
-}
|
||||
-- | Site's database, and methods for manipulating it.
|
||||
module Guide.State
|
||||
(
|
||||
DB,
|
||||
@ -153,15 +151,6 @@ Types.hs
|
||||
field, move it to the “* Overloaded things” heading).
|
||||
|
||||
|
||||
Cache.hs
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
1. If the field is non-trivial (e.g. “notes”) and it makes sense to cache
|
||||
it, add it to 'CacheKey'.
|
||||
|
||||
2. Update 'cacheDepends'.
|
||||
|
||||
|
||||
JS.hs
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
@ -182,11 +171,9 @@ View.hs
|
||||
Guide.hs
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
1. Add a case to 'invalidateCacheForEdit'.
|
||||
1. Add a case to 'undoEdit'.
|
||||
|
||||
2. Add a case to 'undoEdit'.
|
||||
|
||||
3. If the field is user-editable, add a method for changing it to
|
||||
2. If the field is user-editable, add a method for changing it to
|
||||
'setMethods'.
|
||||
|
||||
-}
|
||||
@ -930,6 +917,41 @@ makeAcidic ''GlobalState [
|
||||
'exportPublicDB
|
||||
]
|
||||
|
||||
-- global state
|
||||
deriving instance Show GetGlobalState
|
||||
-- category
|
||||
deriving instance Show GetCategories
|
||||
deriving instance Show GetCategoryMaybe
|
||||
deriving instance Show AddCategory
|
||||
deriving instance Show DeleteCategory
|
||||
deriving instance Show SetCategoryGroup
|
||||
deriving instance Show SetCategoryTitle
|
||||
deriving instance Show SetCategoryNotes
|
||||
deriving instance Show SetCategoryStatus
|
||||
deriving instance Show ChangeCategoryEnabledSections
|
||||
-- items
|
||||
deriving instance Show GetItemMaybe
|
||||
deriving instance Show MoveItem
|
||||
deriving instance Show DeleteItem
|
||||
deriving instance Show AddItem
|
||||
deriving instance Show SetItemName
|
||||
deriving instance Show SetItemNotes
|
||||
deriving instance Show SetItemLink
|
||||
deriving instance Show SetItemGroup
|
||||
deriving instance Show SetItemEcosystem
|
||||
deriving instance Show SetItemHackage
|
||||
deriving instance Show SetItemSummary
|
||||
-- trait
|
||||
deriving instance Show MoveTrait
|
||||
deriving instance Show DeleteTrait
|
||||
deriving instance Show GetTraitMaybe
|
||||
deriving instance Show SetTraitContent
|
||||
deriving instance Show AddPro
|
||||
deriving instance Show AddCon
|
||||
-- action
|
||||
deriving instance Show RegisterAction
|
||||
deriving instance Show RegisterEdit
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- DB helpers (have to be at the end of the file)
|
||||
----------------------------------------------------------------------------
|
||||
|
@ -1,7 +1,5 @@
|
||||
{- |
|
||||
An umbrella module reexporting most types from the codebase (excluding
|
||||
specialized ones, like ones from "Guide.Markdown"
|
||||
-}
|
||||
-- | An umbrella module reexporting most types from the codebase (excluding
|
||||
-- specialized ones, like ones from "Guide.Markdown").
|
||||
module Guide.Types
|
||||
(
|
||||
module Guide.Types.Hue,
|
||||
|
@ -1,18 +1,16 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
{- |
|
||||
Types for analytics.
|
||||
|
||||
* We collect information about 'Action's that users perform. An action can
|
||||
be a page visit, a search, or an edit.
|
||||
|
||||
* Some actions have referrers. For instance, when a user goes from Reddit
|
||||
to our site, Reddit is the referrer.
|
||||
|
||||
* We also collect additional information about users performing actions,
|
||||
such as date and time when the action was performed.
|
||||
-}
|
||||
-- | Types for analytics.
|
||||
--
|
||||
-- * We collect information about 'Action's that users perform. An action
|
||||
-- can be a page visit, a search, or an edit.
|
||||
--
|
||||
-- * Some actions have referrers. For instance, when a user goes from
|
||||
-- Reddit to our site, Reddit is the referrer.
|
||||
--
|
||||
-- * We also collect additional information about users performing actions,
|
||||
-- such as date and time when the action was performed.
|
||||
module Guide.Types.Action
|
||||
(
|
||||
Action(..),
|
||||
|
@ -7,17 +7,15 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
{- |
|
||||
Core types for content.
|
||||
|
||||
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.
|
||||
-}
|
||||
-- | Core types for content.
|
||||
--
|
||||
-- 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(..),
|
||||
|
@ -1,13 +1,11 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
{- |
|
||||
Types for edits.
|
||||
|
||||
Every content edit is associated with an 'Edit', which is stored in the
|
||||
database and can be undone. In addition, each edit has a corresponding
|
||||
'EditDetails' (which stores IP, date, and ID of an edit).
|
||||
-}
|
||||
-- | Types for edits.
|
||||
--
|
||||
-- Every content edit is associated with an 'Edit', which is stored in the
|
||||
-- database and can be undone. In addition, each edit has a corresponding
|
||||
-- 'EditDetails' (which stores IP, date, and ID of an edit).
|
||||
module Guide.Types.Edit
|
||||
(
|
||||
Edit(..),
|
||||
|
@ -4,10 +4,8 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
{- |
|
||||
Items can have different colors; this module provides type 'Hue' and a
|
||||
palette for turning hues into actual colors.
|
||||
-}
|
||||
-- | Items can have different colors; this module provides type 'Hue' and a
|
||||
-- palette for turning hues into actual colors.
|
||||
module Guide.Types.Hue
|
||||
(
|
||||
Hue(..),
|
||||
|
@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{- |
|
||||
A type for users. Currently unused.
|
||||
-}
|
||||
-- | A type for users. Currently unused.
|
||||
module Guide.Types.User
|
||||
(
|
||||
User,
|
||||
|
@ -11,9 +11,7 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
|
||||
{- |
|
||||
All utility functions and types go here.
|
||||
-}
|
||||
-- | All utility functions and types go here.
|
||||
module Guide.Utils
|
||||
(
|
||||
-- * Lists
|
||||
@ -194,20 +192,18 @@ makeSlug =
|
||||
T.toLower .
|
||||
T.map (\x -> if x == '_' || x == '/' then '-' else x)
|
||||
|
||||
{- |
|
||||
Add a path element to an URL:
|
||||
|
||||
>>> "https://guide.aelve.com" // "haskell"
|
||||
"https://guide.aelve.com/haskell"
|
||||
|
||||
If slashes are already present, it strips them:
|
||||
|
||||
>>> "https://guide.aelve.com/" // "/haskell"
|
||||
"https://guide.aelve.com/haskell"
|
||||
|
||||
Note that ('</>') from "System.FilePath" shouldn't be used, as on Windows it
|
||||
appends backslashes (@\@) and not slashes (@/@).
|
||||
-}
|
||||
-- | Add a path element to an URL:
|
||||
--
|
||||
-- >>> "https://guide.aelve.com" // "haskell"
|
||||
-- "https://guide.aelve.com/haskell"
|
||||
--
|
||||
-- If slashes are already present, it strips them:
|
||||
--
|
||||
-- >>> "https://guide.aelve.com/" // "/haskell"
|
||||
-- "https://guide.aelve.com/haskell"
|
||||
--
|
||||
-- Note that ('</>') from "System.FilePath" shouldn't be used, as on Windows
|
||||
-- it appends backslashes (@\@) and not slashes (@/@).
|
||||
(//) :: Url -> Text -> Url
|
||||
(//) x y = fromMaybe x (T.stripSuffix "/" x) <> "/" <>
|
||||
fromMaybe y (T.stripPrefix "/" y)
|
||||
@ -308,10 +304,13 @@ sockAddrToIP _ = Nothing
|
||||
|
||||
-- | Unique id, used for many things – categories, items, and anchor ids.
|
||||
newtype Uid a = Uid {uidToText :: Text}
|
||||
deriving (Generic, Eq, Ord, Show, Data,
|
||||
deriving (Generic, Eq, Ord, Data,
|
||||
ToHttpApiData, FromHttpApiData,
|
||||
Buildable, Hashable)
|
||||
|
||||
instance Show (Uid a) where
|
||||
show (Uid a) = show a
|
||||
|
||||
instance A.ToJSON (Uid a) where
|
||||
toJSON = A.toJSON . uidToText
|
||||
|
||||
|
@ -6,12 +6,14 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
||||
{- |
|
||||
All views and all rendering logic.
|
||||
-}
|
||||
-- | All views and all rendering logic.
|
||||
module Guide.Views
|
||||
(
|
||||
module X,
|
||||
-- * Reexports
|
||||
module Guide.Views.Auth,
|
||||
module Guide.Views.Category,
|
||||
module Guide.Views.Item,
|
||||
module Guide.Views.Page,
|
||||
|
||||
-- * Pages
|
||||
renderRoot,
|
||||
@ -29,12 +31,6 @@ module Guide.Views
|
||||
where
|
||||
|
||||
|
||||
-- Reexporting children modules
|
||||
import Guide.Views.Auth as X
|
||||
import Guide.Views.Category as X
|
||||
import Guide.Views.Item as X
|
||||
import Guide.Views.Page as X
|
||||
|
||||
import Imports
|
||||
|
||||
import NeatInterpolation
|
||||
@ -67,6 +63,12 @@ import qualified Data.Aeson as A
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
|
||||
-- Children modules
|
||||
import Guide.Views.Auth
|
||||
import Guide.Views.Category
|
||||
import Guide.Views.Item
|
||||
import Guide.Views.Page
|
||||
|
||||
import qualified Guide.Diff as Diff
|
||||
import qualified Guide.JS as JS
|
||||
|
||||
@ -688,11 +690,6 @@ renderSearch mbSearchQuery =
|
||||
|
||||
-- | Render list of categories on the main page (the one with category groups
|
||||
-- and categories in it).
|
||||
--
|
||||
-- If the presentation of the category list ever changes (e.g. to include
|
||||
-- lists of items in categories, or their counts, or something), you might
|
||||
-- have to start invalidating 'CacheCategoryList' in more things in
|
||||
-- 'Cache.invalidateCache'.
|
||||
renderCategoryList :: forall m. MonadIO m => [Category] -> HtmlT m ()
|
||||
renderCategoryList allCats =
|
||||
div_ [id_ "categories"] $
|
||||
@ -782,6 +779,8 @@ rerendered whenever prosConsEnabled/ecosystemEnabled is changed. So, instead
|
||||
we do a somewhat inelegant thing: we wrap traits/ecosystem/notes into yet
|
||||
another <div>, and set “display:none” on it. 'JS.submitCategoryInfo' operates
|
||||
on those <div>s.
|
||||
|
||||
Also note: we don't do caching anymore.
|
||||
-}
|
||||
|
||||
-- TODO: warn when a library isn't on Hackage but is supposed to be
|
||||
|
@ -1,11 +1,10 @@
|
||||
{- |
|
||||
An umbrella module for views concerning users and authorisation.
|
||||
-}
|
||||
-- | An umbrella module for views concerning users and authorisation.
|
||||
module Guide.Views.Auth
|
||||
(
|
||||
module X,
|
||||
module Guide.Views.Auth.Login,
|
||||
module Guide.Views.Auth.Register,
|
||||
)
|
||||
where
|
||||
|
||||
import Guide.Views.Auth.Login as X
|
||||
import Guide.Views.Auth.Register as X
|
||||
import Guide.Views.Auth.Login
|
||||
import Guide.Views.Auth.Register
|
||||
|
@ -2,10 +2,9 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
|
||||
|
||||
{- |
|
||||
Views for login.
|
||||
-}
|
||||
-- | Views for login.
|
||||
module Guide.Views.Auth.Login where
|
||||
|
||||
import Imports
|
||||
|
@ -1,11 +1,11 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
{- |
|
||||
Views for user registration.
|
||||
-}
|
||||
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
||||
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
|
||||
|
||||
-- | Views for user registration.
|
||||
module Guide.Views.Auth.Register where
|
||||
|
||||
import Imports
|
||||
|
@ -2,11 +2,9 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
{- |
|
||||
Category rendering.
|
||||
|
||||
The main function this module provides is 'renderCategory'.
|
||||
-}
|
||||
-- | Category rendering.
|
||||
--
|
||||
-- The main function this module provides is 'renderCategory'.
|
||||
module Guide.Views.Category
|
||||
(
|
||||
-- * Main functions
|
||||
|
@ -1,12 +1,10 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
{- |
|
||||
Item rendering.
|
||||
|
||||
The main functions this module provides are 'renderItem' and
|
||||
'renderItemForFeed'.
|
||||
-}
|
||||
-- | Item rendering.
|
||||
--
|
||||
-- The main functions this module provides are 'renderItem' and
|
||||
-- 'renderItemForFeed'.
|
||||
module Guide.Views.Item
|
||||
(
|
||||
-- * Main functions
|
||||
|
@ -4,12 +4,10 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
|
||||
{- |
|
||||
Page rendering.
|
||||
|
||||
This module is used for wrapping content into actual pages that can be served
|
||||
to the user. (With header, footer, etc.)
|
||||
-}
|
||||
-- | Page rendering.
|
||||
--
|
||||
-- This module is used for wrapping content into actual pages that can be
|
||||
-- served to the user. (With header, footer, etc.)
|
||||
module Guide.Views.Page
|
||||
(
|
||||
Page (..),
|
||||
@ -41,7 +39,6 @@ import Guide.Views.Utils
|
||||
-- import Guide.State
|
||||
-- import Guide.Types
|
||||
-- import Guide.Markdown
|
||||
-- import Guide.Cache
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{- |
|
||||
Various HTML utils, Mustache utils, etc.
|
||||
-}
|
||||
-- | Various HTML utils, Mustache utils, etc.
|
||||
module Guide.Views.Utils
|
||||
(
|
||||
-- * Script utils
|
||||
@ -89,7 +87,6 @@ import Guide.Types
|
||||
import Guide.Utils
|
||||
-- import Guide.Config
|
||||
-- import Guide.State
|
||||
-- import Guide.Cache
|
||||
|
||||
import Guide.Views.Utils.Input
|
||||
|
||||
|
@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
{- |
|
||||
Lucid rendering for inputs and form fields.
|
||||
-}
|
||||
-- | Lucid rendering for inputs and form fields.
|
||||
module Guide.Views.Utils.Input
|
||||
(
|
||||
inputText,
|
||||
@ -25,8 +23,6 @@ where
|
||||
|
||||
import Imports hiding (for_)
|
||||
|
||||
import Control.Monad (forM_, when)
|
||||
import Data.Text (Text, pack)
|
||||
import Lucid
|
||||
import Text.Digestive.View
|
||||
|
||||
@ -58,9 +54,9 @@ inputTextArea r c ref view = textarea_
|
||||
toHtmlRaw $ fieldInputText ref view
|
||||
where
|
||||
ref' = absoluteRef ref view
|
||||
rows' (Just x) = [rows_ $ pack $ show x]
|
||||
rows' (Just x) = [rows_ $ toText $ show x]
|
||||
rows' _ = []
|
||||
cols' (Just x) = [cols_ $ pack $ show x]
|
||||
cols' (Just x) = [cols_ $ toText $ show x]
|
||||
cols' _ = []
|
||||
|
||||
|
||||
@ -156,7 +152,7 @@ form
|
||||
=> View (HtmlT m ()) -> Text -> [Attribute] -> HtmlT m () -> HtmlT m ()
|
||||
form view action attributes = form_ $
|
||||
[ method_ "POST"
|
||||
, enctype_ (pack $ show $ viewEncType view)
|
||||
, enctype_ (toText $ show $ viewEncType view)
|
||||
, action_ action
|
||||
]
|
||||
++ attributes
|
||||
|
@ -1,10 +1,8 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
|
||||
{- |
|
||||
Imports used in the whole codebase. (All modules import this one instead of
|
||||
the "Prelude".)
|
||||
-}
|
||||
-- | Imports used in the whole codebase. (All modules import this one
|
||||
-- instead of the "Prelude".)
|
||||
module Imports
|
||||
(
|
||||
module X,
|
||||
|
@ -2,14 +2,15 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
|
||||
module To
|
||||
( toText
|
||||
, toLText
|
||||
, toByteString
|
||||
, toLByteString
|
||||
, toString
|
||||
, toBuilder
|
||||
) where
|
||||
module To (
|
||||
toText,
|
||||
toLText,
|
||||
toByteString,
|
||||
toLByteString,
|
||||
toString,
|
||||
toBuilder,
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Prelude
|
||||
|
@ -1,4 +1,4 @@
|
||||
module Main where
|
||||
module Main (main) where
|
||||
|
||||
import Prelude (IO)
|
||||
|
||||
|
307
back/tests/ApiSpec.hs
Normal file
307
back/tests/ApiSpec.hs
Normal file
@ -0,0 +1,307 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
-- | Integration tests for new API methods.
|
||||
module ApiSpec (tests) where
|
||||
|
||||
import BasePrelude hiding (Category)
|
||||
import Data.Aeson
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.Yaml as Yaml
|
||||
import Network.HTTP.Simple
|
||||
import Control.Monad.Catch
|
||||
import Network.HTTP.Types.Status
|
||||
|
||||
import Guide.Api.Types
|
||||
import Guide.Types.Core
|
||||
import Guide.Utils (Uid (..))
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
|
||||
tests :: Spec
|
||||
tests = describe "api" $ do
|
||||
it "fail request" $ do
|
||||
request <- makeRequest
|
||||
(Path "fail")
|
||||
(Method "GET")
|
||||
Status 404 "Not Found" <- runFailRequest request
|
||||
pure ()
|
||||
describe "Categories" $ do
|
||||
it "get categories request" $ void $ getCategoriesRequest
|
||||
it "createCategory" $ void $ createCategory
|
||||
|
||||
it "get category by id" $ do
|
||||
-- get id of category from DB
|
||||
categoryInfo <- head <$> getCategoriesRequest
|
||||
let Uid categoryId = cciId categoryInfo
|
||||
request <- makeRequest
|
||||
(Path $ "category/" <> T.unpack categoryId)
|
||||
(Method "GET")
|
||||
(Status 200 "OK", _ :: CCategoryFull) <- runRequest request
|
||||
pure ()
|
||||
|
||||
it "delete category by id" $ do
|
||||
categoryInfo <- head <$> getCategoriesRequest
|
||||
Just True <- deleteCategory (cciId categoryInfo)
|
||||
Just False <- deleteCategory (cciId categoryInfo)
|
||||
pure ()
|
||||
|
||||
it "modify notes of category" $ do
|
||||
req <- withCategory $ \categoryId -> do
|
||||
let Uid tCategoryId = categoryId
|
||||
request <- makeRequest
|
||||
(Path $ "category/" <> T.unpack tCategoryId <> "/notes")
|
||||
(Method "PUT")
|
||||
let req = setRequestBodyJSON (makeEditObject "" "string") request
|
||||
Status 200 "OK" <- runRequestNoBody req
|
||||
Status 409 "Merge conflict occurred" <- runRequestNoBody req
|
||||
pure req
|
||||
Status 404 "Category not found" <- runRequestNoBody req
|
||||
pure ()
|
||||
|
||||
it "modify info of category" $ do
|
||||
req <- withCategory $ \categoryId -> do
|
||||
let Uid tCategoryId = categoryId
|
||||
request <- makeRequest
|
||||
(Path $ "category/" <> T.unpack tCategoryId <> "/info")
|
||||
(Method "PUT")
|
||||
let req = setRequestBodyJSON editCategoryInfo request
|
||||
Status 200 "OK" <- runRequestNoBody req
|
||||
pure req
|
||||
Status 404 "Category not found" <- runRequestNoBody req
|
||||
pure ()
|
||||
|
||||
describe "Items" $ do
|
||||
it "create & delete item" $
|
||||
withCategory $ \categoryId -> do
|
||||
itemId <- createItem categoryId
|
||||
Just True <- deleteItem itemId
|
||||
Just False <- deleteItem itemId
|
||||
pure ()
|
||||
|
||||
it "get item by id" $ do
|
||||
req <- withItem $ \(Uid itemId) -> do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId)
|
||||
(Method "GET")
|
||||
(Status 200 "OK", _ :: CItemFull) <- runRequest request
|
||||
pure request
|
||||
Status 404 "Item not found" <- runFailRequest req
|
||||
pure ()
|
||||
|
||||
it "set item info" $ do
|
||||
req <- withItem $ \(Uid itemId) -> do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId <> "/info")
|
||||
(Method "PUT")
|
||||
let req = setRequestBodyJSON itemInfo request
|
||||
Status 200 "OK" <- runRequestNoBody req
|
||||
pure req
|
||||
Status 404 "Item not found" <- runFailRequest req
|
||||
pure ()
|
||||
forM_ ["summary", "ecosystem", "notes"] $ \dataType -> do
|
||||
it ("set " <> dataType <> " to item") $ setMergebleDataToItem dataType
|
||||
describe "Trait" $ do
|
||||
it "create & delete trait" $
|
||||
withItem $ \itemId -> do
|
||||
traitId <- createTrait itemId
|
||||
Just True <- deleteTrait itemId traitId
|
||||
Just False <- deleteTrait itemId traitId
|
||||
pure ()
|
||||
it "get trait by id" $ do
|
||||
req <- withTrait $ \(Uid itemId) (Uid traitId) -> do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId <> "/trait/" <> T.unpack traitId)
|
||||
(Method "GET")
|
||||
(Status 200 "OK", _ :: CTrait) <- runRequest request
|
||||
pure request
|
||||
Status 404 "Item not found" <- runFailRequest req
|
||||
pure ()
|
||||
|
||||
it "update trait" $ do
|
||||
req <- withTrait $ \(Uid itemId) (Uid traitId) -> do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId <> "/trait/" <> T.unpack traitId)
|
||||
(Method "PUT")
|
||||
let req = setRequestBodyJSON (makeEditObject "oldText" "newText") request
|
||||
Status 200 "OK" <- runRequestNoBody req
|
||||
Status 409 "Merge conflict occurred" <- runRequestNoBody req
|
||||
pure req
|
||||
Status 404 "Item not found" <- runFailRequest req
|
||||
pure ()
|
||||
it "move trait" $ do
|
||||
req <- withTrait $ \(Uid itemId) (Uid traitId) -> do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId <> "/trait/" <> T.unpack traitId <> "/move")
|
||||
(Method "POST")
|
||||
let req = setRequestBodyJSON (object ["direction" .= ("up" :: String)]) request
|
||||
Status 200 "OK" <- runRequestNoBody req
|
||||
pure req
|
||||
Status 404 "Item not found" <- runFailRequest req
|
||||
pure ()
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Category
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
withCategory :: (Uid Category -> IO a) -> IO a
|
||||
withCategory f = do
|
||||
categoryId <- createCategory
|
||||
res <- f categoryId
|
||||
void $ deleteCategory categoryId
|
||||
pure res
|
||||
|
||||
createCategory :: IO (Uid Category)
|
||||
createCategory = do
|
||||
request <- makeRequest
|
||||
(Path "category?title=NewCategory&group=Model")
|
||||
(Method "POST")
|
||||
snd <$> runRequest request
|
||||
|
||||
deleteCategory :: Uid Category -> IO (Maybe Bool)
|
||||
deleteCategory (Uid categoryId) = do
|
||||
request <- makeRequest
|
||||
(Path $ "category/" <> T.unpack categoryId)
|
||||
(Method "DELETE")
|
||||
res <- runRequestNoBody request
|
||||
pure $ case res of
|
||||
Status 200 "OK" -> Just True
|
||||
Status 404 "Category not found" -> Just False
|
||||
_ -> Nothing
|
||||
|
||||
editCategoryInfo :: Value
|
||||
editCategoryInfo = object
|
||||
[ "title" .= ("oldText" :: String)
|
||||
, "group" .= ("Model" :: String)
|
||||
, "status" .= ("CategoryStub" :: String)
|
||||
, "sections" .= [("ItemProsConsSection" :: String)]
|
||||
]
|
||||
|
||||
getCategoriesRequest :: IO [CCategoryInfo]
|
||||
getCategoriesRequest = do
|
||||
request <- makeRequest
|
||||
(Path "categories")
|
||||
(Method "GET")
|
||||
snd <$> runRequest request
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Item
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
setMergebleDataToItem :: String -> IO ()
|
||||
setMergebleDataToItem dataType = do
|
||||
req <- withItem $ \(Uid itemId) -> do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId <> "/" <> dataType)
|
||||
(Method "PUT")
|
||||
let req = setRequestBodyJSON (makeEditObject "" "text") request
|
||||
Status 200 "OK" <- runRequestNoBody req
|
||||
Status 409 "Merge conflict occurred" <- runRequestNoBody req
|
||||
pure req
|
||||
Status 404 "Item not found" <- runFailRequest req
|
||||
pure ()
|
||||
|
||||
withItem :: (Uid Item -> IO a) -> IO a
|
||||
withItem f = withCategory $ \categoryId -> do
|
||||
itemId <- createItem categoryId
|
||||
res <- f itemId
|
||||
void $ deleteItem itemId
|
||||
pure res
|
||||
|
||||
createItem :: Uid Category -> IO (Uid Item)
|
||||
createItem (Uid categoryId) = do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack categoryId <> "?name=testName")
|
||||
(Method "POST")
|
||||
snd <$> runRequest request
|
||||
|
||||
deleteItem :: Uid Item -> IO (Maybe Bool)
|
||||
deleteItem (Uid itemId) = do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId)
|
||||
(Method "DELETE")
|
||||
res <- runRequestNoBody request
|
||||
pure $ case res of
|
||||
Status 200 "OK" -> Just True
|
||||
Status 404 "Item not found" -> Just False
|
||||
_ -> Nothing
|
||||
|
||||
itemInfo :: Value
|
||||
itemInfo = object
|
||||
[ "name" .= ("exampleName" :: String)
|
||||
, "group" .= ("exampleGroup" :: String)
|
||||
, "hackage" .= ("string" :: String)
|
||||
, "link" .= ("http:/link.exp" :: String)
|
||||
]
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Trait
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
createTrait :: Uid Item -> IO (Uid Trait)
|
||||
createTrait (Uid itemId) = do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId <> "/trait")
|
||||
(Method "POST")
|
||||
snd <$> (runRequest $ setRequestBodyJSON traitBody request)
|
||||
|
||||
deleteTrait :: Uid Item -> Uid Trait -> IO (Maybe Bool)
|
||||
deleteTrait (Uid itemId) (Uid traitId) = do
|
||||
request <- makeRequest
|
||||
(Path $ "item/" <> T.unpack itemId <> "/trait/" <> T.unpack traitId)
|
||||
(Method "DELETE")
|
||||
res <- runRequestNoBody request
|
||||
pure $ case res of
|
||||
Status 200 "OK" -> Just True
|
||||
Status 404 "Item not found" -> Just False
|
||||
Status 404 "Trait not found" -> Just False
|
||||
_ -> Nothing
|
||||
|
||||
withTrait :: (Uid Item -> Uid Trait -> IO a) -> IO a
|
||||
withTrait f = withItem $ \itemId -> do
|
||||
traitId <- createTrait itemId
|
||||
res <- f itemId traitId
|
||||
void $ deleteTrait itemId traitId
|
||||
pure res
|
||||
|
||||
traitBody :: Value
|
||||
traitBody = object
|
||||
[ "type" .= ("Pro" :: String)
|
||||
, "content" .= ("oldText" :: String)
|
||||
]
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Common
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
makeEditObject :: String -> String -> Value
|
||||
makeEditObject oldText newText = object
|
||||
[ "original" .= oldText
|
||||
, "modified" .= newText
|
||||
]
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- Utilities for requests
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
runRequestNoBody, runFailRequest :: Request -> IO Status
|
||||
runRequestNoBody request = getResponseStatus <$> httpNoBody request
|
||||
runFailRequest = runRequestNoBody
|
||||
|
||||
runRequest :: Yaml.FromJSON a => Request -> IO (Status, a)
|
||||
runRequest request = do
|
||||
response <- httpJSON request
|
||||
pure (getResponseStatus response, getResponseBody response)
|
||||
|
||||
newtype Path = Path String
|
||||
newtype Method = Method S8.ByteString
|
||||
|
||||
makeRequest :: MonadThrow m => Path -> Method -> m Request
|
||||
makeRequest (Path path) (Method method) = do
|
||||
initReq <- parseRequest $ "http://localhost/" ++ path
|
||||
pure $
|
||||
setRequestPort 4400 $
|
||||
setRequestMethod method initReq
|
50
back/tests/LogSpec.hs
Normal file
50
back/tests/LogSpec.hs
Normal file
@ -0,0 +1,50 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
-- | Tests for logging of errors.
|
||||
module LogSpec (tests) where
|
||||
|
||||
import BasePrelude
|
||||
import System.IO
|
||||
import Text.RE.TDFA.String
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
|
||||
getLines :: Handle -> IO String
|
||||
getLines h = loop' []
|
||||
where
|
||||
loop' :: [String] -> IO String
|
||||
loop' xs = do
|
||||
eLine <- try $ hGetLine h
|
||||
case eLine of
|
||||
Left (_ :: SomeException) -> pure $ concat $ reverse xs
|
||||
Right line -> loop' (line:xs)
|
||||
|
||||
tests :: FilePath -> Spec
|
||||
tests logFile = describe "test of logger" $ do
|
||||
logs <- runIO $ do
|
||||
logFileHandle <- openFile logFile ReadWriteMode
|
||||
logs <- getLines logFileHandle
|
||||
hClose logFileHandle
|
||||
pure logs
|
||||
|
||||
describe "Logging of init" $ do
|
||||
it "Spock init message is present" $ [re|Spock is running on port|] `isIn` logs
|
||||
it "Api init message is present" $ [re|API is running on port|] `isIn` logs
|
||||
describe "Logging of api" $ do
|
||||
describe "Categories" $ do
|
||||
it "modify notes to category request" $ [re|setCategoryNotes|] `isIn` logs
|
||||
describe "Item" $ do
|
||||
it "set item info" $ [re|setItemInfo|] `isIn` logs
|
||||
describe "Trait" $ do
|
||||
it "move trait" $ [re|moveTrait|] `isIn` logs
|
||||
|
||||
describe "Errors (exceptions)" $ do
|
||||
it "Category not found" $
|
||||
[re|response code 404: Category not found|] `isIn` logs
|
||||
|
||||
isIn :: HasCallStack => RE -> String -> Expectation
|
||||
isIn reg text = case matchedText $ text ?=~ reg of
|
||||
Just _ -> pure ()
|
||||
Nothing -> expectationFailure text
|
@ -18,14 +18,17 @@ main = do
|
||||
hspec $ do
|
||||
MarkdownSpec.tests
|
||||
MergeSpec.tests
|
||||
-- TODO: it'd be nice if we could us WebSpec.tests in hspec as well,
|
||||
-- but I don't know how to achieve the following:
|
||||
-- * before WebSpec tests, the server is started
|
||||
-- * after those tests, the server is killed
|
||||
-- * if you Ctrl-C during the tests, the server is killed as well
|
||||
WebSpec.tests
|
||||
|
||||
{- TODO
|
||||
-- TODO: it'd be nice if we could do server-starting tests in hspec as well,
|
||||
-- but I don't know how to achieve the following flow:
|
||||
--
|
||||
-- * before the tests, the server is started
|
||||
-- * after the tests, the server is killed
|
||||
-- * if you Ctrl-C during the tests, the server is killed as well
|
||||
|
||||
{- Tests left to write:
|
||||
~~~~~~~~~~~~~~
|
||||
* noscript tests
|
||||
* test on mobile
|
||||
* test that there are no repetitive searches on the admin page
|
||||
@ -34,8 +37,6 @@ main = do
|
||||
execution of tests
|
||||
* changes to item description must not persist when doing Cancel and
|
||||
then Edit again
|
||||
* test that pages are indeed cached
|
||||
* test that changing some pages doesn't invalidate the entire cache
|
||||
* Markdown tests (e.g. Markdown doesn't work in category names)
|
||||
* test that nothing is messed up by things starting and ending with newlines
|
||||
(the %js bug, see description of 'mustache')
|
||||
|
@ -7,29 +7,29 @@
|
||||
|
||||
module WebSpec (tests) where
|
||||
|
||||
|
||||
import BasePrelude hiding (catch, bracket)
|
||||
import BasePrelude hiding (catch, try)
|
||||
-- Monads
|
||||
import Control.Monad.Loops
|
||||
-- Concurrency
|
||||
import qualified SlaveThread as Slave
|
||||
import Control.Concurrent.Async (withAsync)
|
||||
-- Text
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
-- Files
|
||||
import System.Directory
|
||||
import System.IO.Temp
|
||||
-- URLs
|
||||
import Network.URI
|
||||
-- Exceptions
|
||||
import Control.Monad.Catch
|
||||
|
||||
-- Testing
|
||||
import Selenium
|
||||
import qualified ApiSpec
|
||||
import qualified LogSpec
|
||||
import qualified Test.WebDriver.Common.Keys as Key
|
||||
|
||||
-- Site
|
||||
import qualified Guide.Main
|
||||
import Guide.Config (Config(..))
|
||||
import Guide.Config (def, Config(..))
|
||||
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
@ -37,11 +37,19 @@ import Guide.Config (Config(..))
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
tests :: IO ()
|
||||
tests = run $ do
|
||||
mainPageTests
|
||||
categoryTests
|
||||
itemTests
|
||||
markdownTests
|
||||
tests = withSystemTempFile "test_guide.log" $ \logFile logFileHandle -> do
|
||||
-- Close the log file because otherwise 'run' won't be able to open it
|
||||
hClose logFileHandle
|
||||
run logFile $ do
|
||||
mainPageTests
|
||||
categoryTests
|
||||
itemTests
|
||||
markdownTests
|
||||
ApiSpec.tests
|
||||
hspec $
|
||||
LogSpec.tests logFile
|
||||
-- TODO: ApiSpec, LogSpec, and WebSpec should be independent of each
|
||||
-- other. Currently it's a mess.
|
||||
|
||||
mainPageTests :: Spec
|
||||
mainPageTests = session "main page" $ using [chromeCaps] $ do
|
||||
@ -60,21 +68,6 @@ mainPageTests = session "main page" $ using [chromeCaps] $ do
|
||||
-- fs <- fontSize sub; fs `shouldBeInRange` (15,17)
|
||||
-- wd "has a discuss link" $ do
|
||||
-- checkPresent ".subtitle a[href='http://discuss.link']"
|
||||
describe "footer" $ do
|
||||
wd "is present" $ do
|
||||
checkPresent "#footer"
|
||||
wd "isn't overflowing" $ do
|
||||
setWindowSize (900, 500) -- the footer is about 800px wide
|
||||
footer <- select "#footer"
|
||||
(width, height) <- elemSize footer
|
||||
width `shouldBeInRange` (750, 850)
|
||||
height `shouldBeInRange` (30, 70)
|
||||
wd "overflows when shrunk" $ do
|
||||
-- and now it shall be overflowing
|
||||
setWindowSize (400, 500)
|
||||
footer <- select "#footer"
|
||||
(_, height) <- elemSize footer
|
||||
height `shouldBeInRange` (71, 140)
|
||||
|
||||
categoryTests :: Spec
|
||||
categoryTests = session "categories" $ using [chromeCaps] $ do
|
||||
@ -401,14 +394,14 @@ itemTests = session "items" $ using [chromeCaps] $ do
|
||||
itemName itemB `shouldHaveText` "Blah"
|
||||
describe "moving items" $ do
|
||||
let getId :: CanSelect a => a -> WD Text
|
||||
getId x = attr x "id" >>= \case
|
||||
getId x = Selenium.attr x "id" >>= \case
|
||||
Nothing -> expectationFailure $
|
||||
printf "expected %s to have an id" (show x)
|
||||
Just i -> return i
|
||||
wd "up" $ do
|
||||
ids <- mapM getId =<< selectAll ".item"
|
||||
click (ById (ids !! 1) :// ".move-item-up")
|
||||
waitWhile 0.05 (return ()) `onTimeout` return ()
|
||||
waitWhile 0.10 (return ()) `onTimeout` return ()
|
||||
ids2 <- mapM getId =<< selectAll ".item"
|
||||
ids2 `shouldBe` (ids !! 1 : ids !! 0 : drop 2 ids)
|
||||
-- TODO: select should only select visible elements
|
||||
@ -589,42 +582,39 @@ getCurrentRelativeURL = do
|
||||
maybe "" uriRegName (uriAuthority u) `shouldBe` "localhost"
|
||||
return u
|
||||
|
||||
run :: Spec -> IO ()
|
||||
run ts = do
|
||||
-- 'Run' prepares directories and config to launch site server for spec tests
|
||||
-- and closes them all after test finished.
|
||||
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
|
||||
}
|
||||
-- Prepere resources.
|
||||
let prepare = do
|
||||
exold <- doesDirectoryExist "state-old"
|
||||
when exold $ error "state-old exists"
|
||||
ex <- doesDirectoryExist "state"
|
||||
when ex $ renameDirectory "state" "state-old"
|
||||
-- Start the server
|
||||
--
|
||||
-- Using 'Slave.fork' in 'Guide.mainWith' ensures that threads started
|
||||
-- inside of 'mainWith' will be killed too when the thread dies.
|
||||
tid <- Slave.fork $ Guide.Main.mainWith Config {
|
||||
_baseUrl = "/",
|
||||
_googleToken = "some-google-token",
|
||||
_adminPassword = "123",
|
||||
_discussLink = Just "http://discuss.link",
|
||||
_portMain = 8080,
|
||||
_portApi = 4400,
|
||||
_portEkg = 5050,
|
||||
_cors = False,
|
||||
_ekg = False }
|
||||
-- Using a delay so that “Spock is running on port 8080” would be
|
||||
-- printed before the first test.
|
||||
threadDelay 100000
|
||||
return tid
|
||||
let finalise tid = do
|
||||
killThread tid
|
||||
ex <- doesDirectoryExist "state"
|
||||
when ex $ removeDirectoryRecursive "state"
|
||||
exold <- doesDirectoryExist "state-old"
|
||||
when exold $ renameDirectory "state-old" "state"
|
||||
bracket prepare finalise $ \_ -> do
|
||||
hspec ts
|
||||
|
||||
-- Release resources.
|
||||
let finish _ = do
|
||||
ex' <- doesDirectoryExist "state"
|
||||
when ex' $ removeDirectoryRecursive "state"
|
||||
exold' <- doesDirectoryExist "state-old"
|
||||
when exold' $ renameDirectory "state-old" "state"
|
||||
|
||||
bracket prepare finish $ \_ -> do
|
||||
withAsync (Guide.Main.mainWith config) $ \_ -> hspec ts
|
||||
|
||||
_site :: IO ()
|
||||
_site = run $ do
|
||||
_site = run "" $ do
|
||||
session "_" $ using [chromeCaps] $ do
|
||||
wd "_" $ do
|
||||
openGuidePage "/"
|
||||
|
@ -1,17 +1,17 @@
|
||||
{
|
||||
"presets": [
|
||||
["env", {
|
||||
["@babel/env", {
|
||||
"targets": {
|
||||
"browsers": ["last 3 versions", "> 2%", "ie >= 10", "Firefox >= 30", "Chrome >= 30"]
|
||||
},
|
||||
"modules": false,
|
||||
"loose": true,
|
||||
"useBuiltIns": true
|
||||
}],
|
||||
"stage-2"
|
||||
"useBuiltIns": "entry"
|
||||
}]
|
||||
],
|
||||
"plugins": [
|
||||
"transform-runtime"
|
||||
"@babel/plugin-transform-runtime",
|
||||
"@babel/plugin-syntax-dynamic-import"
|
||||
],
|
||||
"env": {
|
||||
"test": {
|
||||
|
@ -2,7 +2,7 @@
|
||||
<v-app>
|
||||
<toolbar />
|
||||
<v-content>
|
||||
<router-view></router-view>
|
||||
<router-view />
|
||||
</v-content>
|
||||
<a-footer />
|
||||
</v-app>
|
||||
@ -11,9 +11,13 @@
|
||||
<script lang="ts">
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Watch } from 'vue-property-decorator'
|
||||
import AFooter from 'client/components/AFooter.vue'
|
||||
import Toolbar from 'client/components/Toolbar.vue'
|
||||
import * as nprogress from 'nprogress'
|
||||
import 'nprogress/nprogress.css'
|
||||
|
||||
import Toolbar from './components/Toolbar.vue'
|
||||
nprogress.configure({ showSpinner: false })
|
||||
|
||||
@Component({
|
||||
components: {
|
||||
@ -27,6 +31,15 @@ export default class RootComponent extends Vue {
|
||||
// it is used in MarkdownEditor.vue and to make it work faster in that component we preload it here
|
||||
import('easymde')
|
||||
}
|
||||
|
||||
get isPageLoading () {
|
||||
return this.$store.state.isPageLoading
|
||||
}
|
||||
|
||||
@Watch('isPageLoading')
|
||||
toogleLoading (isPageLoading: boolean) {
|
||||
isPageLoading ? nprogress.start() : nprogress.done()
|
||||
}
|
||||
}
|
||||
</script>
|
||||
|
||||
@ -39,12 +52,24 @@ export default class RootComponent extends Vue {
|
||||
p {
|
||||
margin: 0;
|
||||
}
|
||||
code {
|
||||
color: #000;
|
||||
font-weight: 500;
|
||||
box-shadow: none;
|
||||
}
|
||||
pre code {
|
||||
background-color: #f5f5f5;
|
||||
color: #bd4147;
|
||||
font-weight: 900;
|
||||
box-shadow: 0px 2px 1px -1px rgba(0, 0, 0, 0.2),
|
||||
0px 1px 1px 0px rgba(0, 0, 0, 0.14), 0px 1px 3px 0px rgba(0, 0, 0, 0.12);
|
||||
}
|
||||
code.sourceCode {
|
||||
min-width: 100%;
|
||||
padding: 8px;
|
||||
}
|
||||
.sourceCode:not(:last-child) code.sourceCode {
|
||||
margin: 0 0 15px;
|
||||
margin: 0 0 5px;
|
||||
}
|
||||
a {
|
||||
text-decoration-line: none;
|
||||
|
@ -10,7 +10,9 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Prop, Component, Vue } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop } from 'vue-property-decorator'
|
||||
|
||||
@Component
|
||||
export default class ALink extends Vue {
|
||||
|
@ -56,7 +56,9 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop, Watch } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop, Watch } from 'vue-property-decorator'
|
||||
import { CategoryService } from 'client/service/Category'
|
||||
|
||||
@Component
|
||||
@ -89,8 +91,7 @@ export default class AddCategoryDialog extends Vue {
|
||||
title: this.categoryName,
|
||||
group: this.groupNameInternal
|
||||
})
|
||||
window.open(`http://aelve.com:4801/haskell/${createdId}`, '_blank')
|
||||
this.close()
|
||||
this.$router.push(`haskell/${createdId}`)
|
||||
}
|
||||
}
|
||||
</script>
|
||||
|
@ -2,6 +2,7 @@
|
||||
<v-dialog
|
||||
:value="value"
|
||||
@input="close"
|
||||
@keyup.esc.native="close"
|
||||
max-width="500px"
|
||||
>
|
||||
<slot slot="activator" />
|
||||
@ -49,7 +50,9 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop, Watch } from 'vue-property-decorator';
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop, Watch } from 'vue-property-decorator'
|
||||
|
||||
@Component
|
||||
export default class AddItemDialog extends Vue {
|
||||
@ -58,7 +61,7 @@ export default class AddItemDialog extends Vue {
|
||||
|
||||
itemName: string = ''
|
||||
|
||||
itemValidationRules: Function[] = [
|
||||
itemValidationRules: Array<(x: string) => boolean | string> = [
|
||||
(x: string) => !!x || 'Item name can not be empty'
|
||||
]
|
||||
|
||||
@ -74,11 +77,16 @@ export default class AddItemDialog extends Vue {
|
||||
}
|
||||
|
||||
async submit () {
|
||||
await this.$store.dispatch('categoryItem/createItem', {
|
||||
const createdId = await this.$store.dispatch('categoryItem/createItem', {
|
||||
category: this.categoryId,
|
||||
name: this.itemName
|
||||
})
|
||||
await this.$store.dispatch('category/reloadCategory')
|
||||
this.close()
|
||||
// nextTick to wait for item rendered in dom so router can find it and scroll to it
|
||||
this.$nextTick(() => {
|
||||
this.$router.push({ hash: `item-${createdId}` })
|
||||
})
|
||||
}
|
||||
}
|
||||
</script>
|
||||
|
@ -111,7 +111,7 @@ export default class Categories extends Vue {
|
||||
addCategoryGroupName: string = ''
|
||||
isAddGroupDialogOpen: boolean = false
|
||||
|
||||
async asyncData () {
|
||||
async serverPrefetch () {
|
||||
return this.$store.dispatch('category/loadCategoryList')
|
||||
}
|
||||
get categories () {
|
||||
|
@ -24,8 +24,20 @@
|
||||
<v-icon size="14" class="mr-1" left>$vuetify.icons.plus</v-icon>
|
||||
Add new item
|
||||
</v-btn>
|
||||
<v-btn
|
||||
icon
|
||||
flat
|
||||
class="ma-0 pa-0"
|
||||
color="grey"
|
||||
title="Delete category"
|
||||
@click="deleteCategory"
|
||||
>
|
||||
<v-icon size="14">$vuetify.icons.trash-alt</v-icon>
|
||||
</v-btn>
|
||||
</div>
|
||||
|
||||
<category-description />
|
||||
|
||||
<template v-if="category">
|
||||
<category-item
|
||||
v-for="value in category.items"
|
||||
@ -44,6 +56,7 @@
|
||||
:kind="value.kind"
|
||||
/>
|
||||
</template>
|
||||
|
||||
<v-btn
|
||||
flat
|
||||
class="ml-2"
|
||||
@ -53,7 +66,7 @@
|
||||
<v-icon size="14" class="mr-1" left>$vuetify.icons.plus</v-icon>
|
||||
Add new item
|
||||
</v-btn>
|
||||
<add-item-dialog
|
||||
<add-item-dialog
|
||||
v-model="isDialogOpen"
|
||||
:categoryId="categoryId"
|
||||
/>
|
||||
@ -64,11 +77,14 @@
|
||||
<script lang="ts">
|
||||
import _toKebabCase from 'lodash/kebabCase'
|
||||
import _get from 'lodash/get'
|
||||
import { Vue, Component, Prop } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop } from 'vue-property-decorator'
|
||||
import CategoryItem from 'client/components/CategoryItem.vue'
|
||||
import AddItemDialog from 'client/components/AddItemDialog.vue'
|
||||
import CategoryDescription from 'client/components/CategoryDescription.vue'
|
||||
import category from 'client/store/modules/category'
|
||||
import Confirm from 'client/helpers/ConfirmDecorator'
|
||||
|
||||
@Component({
|
||||
components: {
|
||||
@ -82,17 +98,6 @@ export default class Category extends Vue {
|
||||
|
||||
isDialogOpen: boolean = false
|
||||
|
||||
async asyncData () {
|
||||
if (!this.categoryId) {
|
||||
return
|
||||
}
|
||||
await this.$store.dispatch('category/loadCategory', this.categoryId)
|
||||
}
|
||||
|
||||
beforeDestroy () {
|
||||
this.$store.commit('category/setCategory', {})
|
||||
}
|
||||
|
||||
get category () {
|
||||
return this.$store.state.category.category
|
||||
}
|
||||
@ -101,9 +106,31 @@ export default class Category extends Vue {
|
||||
return this.category && `${_toKebabCase(this.category.title)}-${this.category.id}`
|
||||
}
|
||||
|
||||
// TODO handle case when category was deleted. Go back in that case
|
||||
async serverPrefetch () {
|
||||
if (!this.categoryId) {
|
||||
return
|
||||
}
|
||||
await this.$store.dispatch('category/loadCategory', this.categoryId)
|
||||
}
|
||||
|
||||
beforeDestroy () {
|
||||
this.$store.commit('category/setCategory', null)
|
||||
}
|
||||
|
||||
openAddItemDialog () {
|
||||
this.isDialogOpen = true
|
||||
}
|
||||
|
||||
@Confirm({ text: 'delete this category' })
|
||||
async deleteCategory () {
|
||||
if (!this.category) {
|
||||
return
|
||||
}
|
||||
|
||||
await this.$store.dispatch('category/deleteCategory', this.categoryId)
|
||||
this.$router.back()
|
||||
}
|
||||
}
|
||||
</script>
|
||||
|
||||
|
@ -11,7 +11,7 @@
|
||||
toolbar
|
||||
:value="categoryDscMarkdown"
|
||||
@cancel="toggleEditDescription"
|
||||
@save="saveDescription"
|
||||
@save="updateDescription({original: originalDescription, modified: $event})"
|
||||
/>
|
||||
|
||||
<v-btn
|
||||
@ -25,27 +25,23 @@
|
||||
<v-icon size="14" class="mr-1" left>{{descriptionBtnIcon}}</v-icon>
|
||||
{{descriptionBtnText}}
|
||||
</v-btn>
|
||||
<conflict-dialog
|
||||
v-model="isDescriptionConflict"
|
||||
:serverModified="serverModified"
|
||||
:modified="modified"
|
||||
:merged="merged"
|
||||
@saveDescription="saveConflictDescription"
|
||||
/>
|
||||
</div>
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop } from 'vue-property-decorator'
|
||||
import _get from 'lodash/get'
|
||||
import MarkdownEditor from 'client/components/MarkdownEditor.vue'
|
||||
import ConflictDialog from 'client/components/ConflictDialog.vue'
|
||||
import conflictDialogMixin from 'client/mixins/conflictDialogMixin'
|
||||
import CatchConflictDecorator from 'client/helpers/CatchConflictDecorator'
|
||||
|
||||
@Component({
|
||||
components: {
|
||||
MarkdownEditor,
|
||||
ConflictDialog
|
||||
}
|
||||
MarkdownEditor
|
||||
},
|
||||
mixins: [conflictDialogMixin]
|
||||
})
|
||||
export default class CategoryDescriptiom extends Vue {
|
||||
editDescriptionShown: boolean = false
|
||||
@ -78,40 +74,20 @@ export default class CategoryDescriptiom extends Vue {
|
||||
const description = _get(this, '$store.state.category.category.description.html')
|
||||
return description ? this.descriptionButtonText = 'edit description' : this.descriptionButtonText = 'add description'
|
||||
}
|
||||
|
||||
|
||||
toggleEditDescription () {
|
||||
this.editDescriptionShown = !this.editDescriptionShown
|
||||
}
|
||||
|
||||
async updateCategoryDescription (original, modified) {
|
||||
try {
|
||||
await this.$store.dispatch('categoryItem/updateCategoryDescription', {
|
||||
id: this.categoryId,
|
||||
original: original,
|
||||
modified: modified
|
||||
})
|
||||
this.originalDescription = modified
|
||||
} catch (err) {
|
||||
if (err.response.status === 409) {
|
||||
this.serverModified = err.response.data.server_modified
|
||||
this.modified = err.response.data.modified
|
||||
this.merged = err.response.data.merged
|
||||
this.isDescriptionConflict = true
|
||||
} else {
|
||||
throw err
|
||||
}
|
||||
}
|
||||
|
||||
this.toggleEditDescription();
|
||||
}
|
||||
|
||||
saveDescription(newValue: string) {
|
||||
this.updateCategoryDescription(this.originalDescription, newValue)
|
||||
}
|
||||
|
||||
saveConflictDescription (modified) {
|
||||
this.updateCategoryDescription(this.serverModified, modified)
|
||||
@CatchConflictDecorator
|
||||
async updateDescription ({ original, modified }) {
|
||||
await this.$store.dispatch('categoryItem/updateCategoryDescription', {
|
||||
id: this.categoryId,
|
||||
original,
|
||||
modified
|
||||
})
|
||||
this.originalDescription = modified
|
||||
this.toggleEditDescription()
|
||||
}
|
||||
}
|
||||
</script>
|
||||
@ -126,7 +102,7 @@ export default class CategoryDescriptiom extends Vue {
|
||||
}
|
||||
|
||||
.category-description >>> h1 {
|
||||
margin: 20px 0 5px;
|
||||
margin-top: 10px;
|
||||
}
|
||||
|
||||
.description-content {
|
||||
|
@ -1,5 +1,8 @@
|
||||
<template>
|
||||
<div class="category-item">
|
||||
<div
|
||||
class="category-item"
|
||||
:id="`item-${itemUid}`"
|
||||
>
|
||||
|
||||
<category-item-toolbar
|
||||
:itemUid="itemUid"
|
||||
@ -14,7 +17,7 @@
|
||||
<category-item-section
|
||||
title="Summary"
|
||||
:editText="summary.text"
|
||||
@save="updateSummary"
|
||||
@save="updateSummary({original: summary.text, modified: $event})"
|
||||
>
|
||||
<div
|
||||
class="mb-2 category-item-summary"
|
||||
@ -24,12 +27,12 @@
|
||||
|
||||
<div class="category-item-traits">
|
||||
<category-item-traits
|
||||
type="pro"
|
||||
type="Pro"
|
||||
:itemId="itemUid"
|
||||
:traits="pros"
|
||||
/>
|
||||
<category-item-traits
|
||||
type="con"
|
||||
type="Con"
|
||||
:itemId="itemUid"
|
||||
:traits="cons"
|
||||
/>
|
||||
@ -38,7 +41,7 @@
|
||||
<category-item-section
|
||||
title="Ecosystem"
|
||||
:editText="ecosystem.text"
|
||||
@save="updateEcosystem"
|
||||
@save="updateEcosystem({original: ecosystem.text, modified: $event})"
|
||||
>
|
||||
<div v-html="ecosystem.html" />
|
||||
</category-item-section>
|
||||
@ -46,7 +49,7 @@
|
||||
<category-item-section
|
||||
title="Notes"
|
||||
:editText="notes.text"
|
||||
@save="updateNotes"
|
||||
@save="updateNotes({original: notes.text, modified: $event})"
|
||||
>
|
||||
<v-btn
|
||||
small
|
||||
@ -93,18 +96,23 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop } from 'vue-property-decorator'
|
||||
import { ICategoryItem } from 'client/service/CategoryItem.ts'
|
||||
import CategoryItemToolbar from 'client/components/CategoryItemToolbar.vue'
|
||||
import CategoryItemSection from 'client/components/CategoryItemSection.vue'
|
||||
import CategoryItemTraits from 'client/components/CategoryItemTraits.vue'
|
||||
import conflictDialogMixin from 'client/mixins/conflictDialogMixin'
|
||||
import CatchConflictDecorator from 'client/helpers/CatchConflictDecorator'
|
||||
|
||||
@Component({
|
||||
components: {
|
||||
CategoryItemToolbar,
|
||||
CategoryItemSection,
|
||||
CategoryItemTraits
|
||||
}
|
||||
},
|
||||
mixins: [conflictDialogMixin]
|
||||
})
|
||||
export default class CategoryItem extends Vue {
|
||||
// TODO get rid of so many props and pass the item fully
|
||||
@ -131,29 +139,32 @@ export default class CategoryItem extends Vue {
|
||||
this.isNoteExpanded = false
|
||||
}
|
||||
|
||||
async updateSummary (newValue: string): Promise<void> {
|
||||
@CatchConflictDecorator
|
||||
async updateSummary ({ original, modified }): Promise<void> {
|
||||
await this.$store.dispatch('categoryItem/updateItemSummary', {
|
||||
id: this.itemUid,
|
||||
original: this.summary.text,
|
||||
modified: newValue
|
||||
original,
|
||||
modified
|
||||
})
|
||||
await this.$store.dispatch('category/reloadCategory')
|
||||
}
|
||||
|
||||
async updateEcosystem (newValue: string): Promise<void> {
|
||||
@CatchConflictDecorator
|
||||
async updateEcosystem ({ original, modified }): Promise<void> {
|
||||
await this.$store.dispatch('categoryItem/updateItemEcosystem', {
|
||||
id: this.itemUid,
|
||||
original: this.ecosystem.text,
|
||||
modified: newValue
|
||||
original,
|
||||
modified
|
||||
})
|
||||
await this.$store.dispatch('category/reloadCategory')
|
||||
}
|
||||
|
||||
async updateNotes (newValue: string): Promise<void> {
|
||||
@CatchConflictDecorator
|
||||
async updateNotes ({ original, modified }): Promise<void> {
|
||||
await this.$store.dispatch('categoryItem/updateItemNotes', {
|
||||
id: this.itemUid,
|
||||
original: this.notes.text,
|
||||
modified: newValue
|
||||
original,
|
||||
modified
|
||||
})
|
||||
await this.$store.dispatch('category/reloadCategory')
|
||||
}
|
||||
|
@ -16,7 +16,9 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop } from 'vue-property-decorator'
|
||||
import _omit from 'lodash/omit'
|
||||
|
||||
@Component
|
||||
|
@ -25,7 +25,9 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop } from 'vue-property-decorator'
|
||||
import MarkdownEditor from 'client/components/MarkdownEditor.vue'
|
||||
import CategoryItemBtn from 'client/components/CategoryItemBtn.vue'
|
||||
|
||||
|
@ -13,13 +13,18 @@
|
||||
@click.stop=""
|
||||
>
|
||||
<v-toolbar-title class="headline">
|
||||
<!-- TODO change markup formatting after resolving issue with extra spaces
|
||||
(if closing tag on another line vue-template-compiler adds extra space) -->
|
||||
<router-link
|
||||
:to="{hash:`item-${itemUid}`}"
|
||||
class="category-item-anchor"
|
||||
>#</router-link>
|
||||
<a-link
|
||||
v-if="itemLink"
|
||||
:url="itemLink"
|
||||
openInNewTab
|
||||
>
|
||||
{{ itemName }}
|
||||
</a-link>
|
||||
{{ itemName }}</a-link>
|
||||
<span v-else> {{ itemName }} </span>
|
||||
</v-toolbar-title>
|
||||
<v-spacer></v-spacer>
|
||||
@ -82,7 +87,9 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop, Watch } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop, Watch } from 'vue-property-decorator'
|
||||
import normalizeUrl from 'normalize-url'
|
||||
import Confirm from 'client/helpers/ConfirmDecorator'
|
||||
import CategoryItemBtn from 'client/components/CategoryItemBtn.vue'
|
||||
@ -162,6 +169,9 @@ export default class CategoryItemToolbar extends Vue {
|
||||
</script>
|
||||
|
||||
<style scoped>
|
||||
.category-item-anchor {
|
||||
color: rgb(151, 151, 151);
|
||||
}
|
||||
.edit-item-info-changed-icon {
|
||||
position: absolute;
|
||||
bottom: 0;
|
||||
|
@ -76,7 +76,7 @@
|
||||
:value="trait.content.text"
|
||||
:height="100"
|
||||
@cancel="trait.isEdit = false"
|
||||
@save="saveEdit(trait, $event)"
|
||||
@save="saveEdit({trait, original: trait.content.text, modified: $event})"
|
||||
/>
|
||||
</li>
|
||||
</ul>
|
||||
@ -92,19 +92,25 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop, Watch } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop, Watch } from 'vue-property-decorator'
|
||||
import _cloneDeep from 'lodash/cloneDeep'
|
||||
import Confirm from 'client/helpers/ConfirmDecorator'
|
||||
import CategoryItemSection from 'client/components/CategoryItemSection.vue'
|
||||
import CategoryItemBtn from 'client/components/CategoryItemBtn.vue'
|
||||
import MarkdownEditor from 'client/components/MarkdownEditor.vue'
|
||||
import conflictDialogMixin from 'client/mixins/conflictDialogMixin'
|
||||
import CatchConflictDecorator from 'client/helpers/CatchConflictDecorator'
|
||||
|
||||
@Component({
|
||||
components: {
|
||||
CategoryItemSection,
|
||||
CategoryItemBtn,
|
||||
MarkdownEditor
|
||||
}
|
||||
},
|
||||
mixins: [conflictDialogMixin]
|
||||
|
||||
})
|
||||
export default class CategoryItemTraits extends Vue {
|
||||
// TODO change [any] type
|
||||
@ -114,16 +120,16 @@ export default class CategoryItemTraits extends Vue {
|
||||
|
||||
isEdit: boolean = false
|
||||
isAddTrait: boolean = false
|
||||
traitsModel: any[] = []
|
||||
traitsModel = []
|
||||
|
||||
get title () {
|
||||
return this.type === 'pro' ? 'Pros' : 'Cons'
|
||||
return this.type + 's'
|
||||
}
|
||||
|
||||
@Watch('traits', {
|
||||
immediate: true
|
||||
})
|
||||
setTraitsModel (traits: any[]) {
|
||||
setTraitsModel (traits) {
|
||||
this.traitsModel = _cloneDeep(traits)
|
||||
this.traitsModel.forEach(x => this.$set(x, 'isEdit', false))
|
||||
}
|
||||
@ -132,12 +138,13 @@ export default class CategoryItemTraits extends Vue {
|
||||
this.isEdit = !this.isEdit
|
||||
}
|
||||
|
||||
async saveEdit (trait: any, modifiedText: string) {
|
||||
@CatchConflictDecorator
|
||||
async saveEdit ({ trait, original, modified }) {
|
||||
await this.$store.dispatch('categoryItem/updateItemTrait', {
|
||||
itemId: this.itemId,
|
||||
traitId: trait.id,
|
||||
original: trait.content.text,
|
||||
modified: modifiedText
|
||||
original,
|
||||
modified
|
||||
})
|
||||
trait.isEdit = false
|
||||
await this.$store.dispatch('category/reloadCategory')
|
||||
@ -160,7 +167,7 @@ export default class CategoryItemTraits extends Vue {
|
||||
await this.$store.dispatch('categoryItem/createItemTrait', {
|
||||
itemId: this.itemId,
|
||||
type: this.type,
|
||||
text: traitText
|
||||
content: traitText
|
||||
})
|
||||
this.toggleAddTrait()
|
||||
await this.$store.dispatch('category/reloadCategory')
|
||||
@ -191,6 +198,8 @@ export default class CategoryItemTraits extends Vue {
|
||||
}
|
||||
.category-item-trait {
|
||||
padding-right: 24px;
|
||||
}
|
||||
.category-item-trait:not(:last-child) {
|
||||
margin-bottom: 2px;
|
||||
}
|
||||
.category-item-edit-trait-menu {
|
||||
|
@ -35,7 +35,9 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop } from 'vue-property-decorator'
|
||||
|
||||
@Component
|
||||
export default class ConfirmDialog extends Vue {
|
||||
|
@ -1,7 +1,7 @@
|
||||
<template>
|
||||
<v-dialog
|
||||
:value="value"
|
||||
@input="close"
|
||||
persistent
|
||||
max-width="99vw"
|
||||
>
|
||||
<slot slot="activator" />
|
||||
@ -18,7 +18,7 @@
|
||||
<v-btn
|
||||
depressed
|
||||
small
|
||||
@click="saveUserVersion"
|
||||
@click="save(modified)"
|
||||
>
|
||||
Submit this version, disregard changes on server
|
||||
</v-btn>
|
||||
@ -34,7 +34,7 @@
|
||||
<v-btn
|
||||
depressed
|
||||
small
|
||||
@click="saveServerVersion"
|
||||
@click="save(serverModified)"
|
||||
>
|
||||
Accept this version, disregard my changes
|
||||
</v-btn>
|
||||
@ -45,8 +45,7 @@
|
||||
class="mb-2"
|
||||
toolbar
|
||||
:value="merged"
|
||||
@save="saveMerged"
|
||||
@cancel="close"
|
||||
@save="save"
|
||||
/>
|
||||
</div>
|
||||
</div>
|
||||
@ -68,67 +67,53 @@ export default class ConflictDialog extends Vue {
|
||||
@Prop(String) modified!: string
|
||||
@Prop(String) merged!: string
|
||||
|
||||
saveUserVersion () {
|
||||
this.$emit('saveDescription', this.modified )
|
||||
this.close()
|
||||
save (newValue: string) {
|
||||
this.$emit('save', newValue)
|
||||
}
|
||||
|
||||
saveServerVersion () {
|
||||
this.$emit('saveDescription', this.serverModified)
|
||||
this.close()
|
||||
}
|
||||
|
||||
saveMerged (newVal: string) {
|
||||
this.$emit('saveDescription', this.serverModified)
|
||||
this.close()
|
||||
}
|
||||
|
||||
close ():void {
|
||||
this.$emit('input', false)
|
||||
}
|
||||
}
|
||||
</script>
|
||||
|
||||
<style scoped>
|
||||
.conflict-box {
|
||||
display: flex;
|
||||
background: #fff;
|
||||
padding: 20px;
|
||||
justify-content: space-between;
|
||||
}
|
||||
.conflict-content {
|
||||
flex: 1;
|
||||
margin-bottom: 16px;
|
||||
white-space: pre-wrap;
|
||||
}
|
||||
.conflict-item {
|
||||
width: 32%;
|
||||
display: flex;
|
||||
flex-flow: column;
|
||||
}
|
||||
|
||||
@media screen and (max-width: 1200px) {
|
||||
.conflict-box {
|
||||
display: flex;
|
||||
background: #fff;
|
||||
padding: 20px;
|
||||
justify-content: space-between;
|
||||
}
|
||||
.conflict-content {
|
||||
flex: 1;
|
||||
margin-bottom: 16px;
|
||||
white-space: pre-wrap;
|
||||
flex-wrap: wrap;
|
||||
}
|
||||
|
||||
.conflict-item {
|
||||
width: 32%;
|
||||
display: flex;
|
||||
width: 49%;
|
||||
}
|
||||
|
||||
.conflict-item:nth-last-child(1) {
|
||||
width: 98%;
|
||||
}
|
||||
}
|
||||
|
||||
@media screen and (max-width: 768px) {
|
||||
.conflict-box {
|
||||
flex-flow: column;
|
||||
}
|
||||
|
||||
@media screen and (max-width: 1200px) {
|
||||
.conflict-box {
|
||||
flex-wrap: wrap;
|
||||
}
|
||||
|
||||
.conflict-item {
|
||||
width: 49%;
|
||||
}
|
||||
|
||||
.conflict-item:nth-last-child(1) {
|
||||
width: 98%;
|
||||
}
|
||||
}
|
||||
|
||||
@media screen and (max-width: 768px) {
|
||||
.conflict-box {
|
||||
flex-flow: column;
|
||||
}
|
||||
|
||||
.conflict-item {
|
||||
width: 100%;
|
||||
}
|
||||
.conflict-item {
|
||||
width: 100%;
|
||||
}
|
||||
}
|
||||
</style>
|
||||
|
||||
|
@ -8,7 +8,8 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
|
||||
@Component
|
||||
export default class Logo extends Vue {}
|
||||
|
@ -42,7 +42,9 @@
|
||||
|
||||
<script lang="ts">
|
||||
import 'easymde/dist/easymde.min.css'
|
||||
import { Vue, Component, Prop, Watch } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop, Watch } from 'vue-property-decorator'
|
||||
|
||||
@Component
|
||||
export default class MarkdownEditor extends Vue {
|
||||
|
@ -1,6 +1,5 @@
|
||||
import Vue from 'vue'
|
||||
import 'reflect-metadata'
|
||||
import 'babel-polyfill'
|
||||
import '@babel/polyfill'
|
||||
import _get from 'lodash/get'
|
||||
|
||||
import { createApp } from './app'
|
||||
@ -19,24 +18,44 @@ router.onReady(() => {
|
||||
})
|
||||
|
||||
function registerBeforeResolve () {
|
||||
router.afterEach(async (to, from) => {
|
||||
Vue.nextTick(() => {
|
||||
for (const matchedRoute of to.matched) {
|
||||
const componentsInstances = Object.values(matchedRoute.instances)
|
||||
.filter(Boolean)
|
||||
const matchedComponentsAndChildren = componentsInstances
|
||||
.reduce((acc, matchedComponent) => {
|
||||
const componentAndItsChildren = getComponentAndItsChildren(matchedComponent)
|
||||
acc = acc.concat(componentAndItsChildren)
|
||||
return acc
|
||||
}, [])
|
||||
matchedComponentsAndChildren.map(component => {
|
||||
if (typeof component.asyncData === 'function') {
|
||||
return component.$nextTick(() => component.asyncData())
|
||||
}
|
||||
router.beforeEach(async (to, from, next) => {
|
||||
// This case handles navigation to anchors on same page
|
||||
if (to.path === from.path) {
|
||||
next()
|
||||
return
|
||||
}
|
||||
|
||||
store.commit('tooglePageLoading')
|
||||
if (!to.matched.length) {
|
||||
store.commit('tooglePageLoading')
|
||||
next()
|
||||
return
|
||||
}
|
||||
const propsOption = to.matched[0].props.default
|
||||
const props = propsOption
|
||||
? typeof propsOption === 'function'
|
||||
? propsOption(to)
|
||||
: typeof propsOption === 'object'
|
||||
? propsOption
|
||||
: to.params
|
||||
: {}
|
||||
const routeComponent = to.matched[0].components.default
|
||||
const matchedRootComponent = routeComponent.cid // Check if component already imported
|
||||
? routeComponent
|
||||
: (await routeComponent()).default
|
||||
const matchedComponentsAndChildren = getComponentAndItsChildren(matchedRootComponent)
|
||||
await Promise.all(matchedComponentsAndChildren.map(component => {
|
||||
const serverPrefetch = component.options.serverPrefetch && component.options.serverPrefetch[0]
|
||||
if (typeof serverPrefetch === 'function') {
|
||||
return serverPrefetch.call({
|
||||
$store: store,
|
||||
$router: router,
|
||||
...props
|
||||
})
|
||||
}
|
||||
})
|
||||
}))
|
||||
store.commit('tooglePageLoading')
|
||||
next()
|
||||
})
|
||||
}
|
||||
|
||||
@ -47,7 +66,7 @@ function getComponentAndItsChildren (component, result?) {
|
||||
if (!result.includes(component)) {
|
||||
result.push(component)
|
||||
}
|
||||
const children = Object.values(component.$children)
|
||||
const children = Object.values(component.options.components)
|
||||
// Parent component is also presents in components object
|
||||
.filter(x => x !== component)
|
||||
children.forEach(x => getComponentAndItsChildren(x, result))
|
||||
|
33
front/client/helpers/CatchConflictDecorator.ts
Normal file
33
front/client/helpers/CatchConflictDecorator.ts
Normal file
@ -0,0 +1,33 @@
|
||||
/**
|
||||
* Decorator is used for functions that update string values such as category description, category item summary/ecosystem/trait, etc.
|
||||
* Functions must have one object argument with at least two properties: 'original' and 'modified'.
|
||||
* This properties are used in every API request that can have conflicts.
|
||||
* Also, decorator needs 'openConflictDialog' function to be defined in component. For this you can add conflictDialogMixin or define your own function to resolve conflict.
|
||||
*/
|
||||
export default function (target: any, propertyKey: string, descriptor: PropertyDescriptor) {
|
||||
const originalFunction = descriptor.value
|
||||
|
||||
async function catchConflict (argsObject: object) {
|
||||
try {
|
||||
await originalFunction.call(this, argsObject)
|
||||
} catch (err) {
|
||||
if (err.response && err.response.status === 409) {
|
||||
const serverModified = err.response.data.server_modified
|
||||
const modified = err.response.data.modified
|
||||
const merged = err.response.data.merged
|
||||
const resolvedConflict = await this.openConflictDialog({ serverModified, modified, merged })
|
||||
|
||||
// We use this function again in case of new conflict occurs after resolving this one
|
||||
catchConflict.call(this, {
|
||||
...argsObject,
|
||||
original: serverModified,
|
||||
modified: resolvedConflict
|
||||
})
|
||||
} else {
|
||||
throw err
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
descriptor.value = catchConflict
|
||||
}
|
35
front/client/mixins/conflictDialogMixin.ts
Normal file
35
front/client/mixins/conflictDialogMixin.ts
Normal file
@ -0,0 +1,35 @@
|
||||
import Vue from 'vue'
|
||||
import { Mixin } from 'vue-mixin-decorator'
|
||||
import ConflictDialog from 'client/components/ConflictDialog.vue'
|
||||
import DeferredPromise from 'client/helpers/DeferredPromise'
|
||||
|
||||
const ComponentClass = Vue.extend(ConflictDialog)
|
||||
|
||||
interface IConflictDialogProps {
|
||||
serverModified: string,
|
||||
modified: string,
|
||||
merged: string
|
||||
}
|
||||
|
||||
@Mixin
|
||||
export default class ConflictDialogMixin extends Vue {
|
||||
async openConflictDialog ({ serverModified, modified, merged }: IConflictDialogProps): Promise<string> {
|
||||
const instance = new ComponentClass({
|
||||
propsData: {
|
||||
value: true,
|
||||
serverModified,
|
||||
modified,
|
||||
merged
|
||||
}
|
||||
})
|
||||
instance.$mount()
|
||||
const deferredPromise = new DeferredPromise()
|
||||
this.$el.appendChild(instance.$el)
|
||||
instance.$on('save', (newVal) => {
|
||||
instance.$destroy()
|
||||
deferredPromise.resolve(newVal)
|
||||
})
|
||||
|
||||
return deferredPromise
|
||||
}
|
||||
}
|
@ -66,7 +66,9 @@
|
||||
</template>
|
||||
|
||||
<script lang="ts">
|
||||
import { Vue, Component, Prop, Watch } from 'vue-property-decorator'
|
||||
import Vue from 'vue'
|
||||
import Component from 'vue-class-component'
|
||||
import { Prop, Watch } from 'vue-property-decorator'
|
||||
import ALink from 'client/components/ALink.vue'
|
||||
|
||||
@Component({
|
||||
@ -81,7 +83,7 @@ export default class SearchResults extends Vue {
|
||||
this.$store.commit('wiki/setSearchInput', this.query)
|
||||
}
|
||||
|
||||
async asyncData () {
|
||||
async serverPrefetch () {
|
||||
await this.$store.dispatch('wiki/search', this.query)
|
||||
}
|
||||
|
||||
|
@ -4,10 +4,15 @@ function createRouter () {
|
||||
return new Router({
|
||||
mode: 'history',
|
||||
fallback: false,
|
||||
scrollBehavior: (to) => {
|
||||
// ads an ability for a scroll to anchor
|
||||
if (to.hash) {
|
||||
return { selector: to.hash }
|
||||
// TODO update vue-router when scroll issue will be fixed
|
||||
// https://github.com/vuejs/vue-router/issues/2095
|
||||
// Router doesnt support navigation to same anchor yet
|
||||
// https://github.com/vuejs/vue-router/issues/1668
|
||||
scrollBehavior (to, from, savedPosition) {
|
||||
if (savedPosition) {
|
||||
return savedPosition
|
||||
} else if (to.hash) {
|
||||
return { selector: to.hash, offset: { y: 96, x: 0 } }
|
||||
} else {
|
||||
return { x: 0, y: 0 }
|
||||
}
|
||||
|
@ -23,6 +23,10 @@ class CategoryService {
|
||||
})
|
||||
return data
|
||||
}
|
||||
|
||||
async deleteCategory (id: ICategoryInfo['id']): Promise<void> {
|
||||
await axios.delete(`api/category/${id}`)
|
||||
}
|
||||
}
|
||||
|
||||
export enum CategoryStatus {
|
||||
|
@ -81,12 +81,11 @@ class CategoryItemService {
|
||||
async createItemTrait (
|
||||
itemId: ICategoryItem['id'],
|
||||
type: string,
|
||||
text: string,
|
||||
content: string,
|
||||
): Promise<void> {
|
||||
await axios.post(`api/item/${itemId}/trait/${type}`, JSON.stringify(text), {
|
||||
headers: {
|
||||
'Content-Type': 'application/json;charset=utf-8'
|
||||
}
|
||||
await axios.post(`api/item/${itemId}/trait/`, {
|
||||
type,
|
||||
content
|
||||
})
|
||||
}
|
||||
// add here category description add/edit
|
||||
|
@ -6,9 +6,15 @@ import wiki from 'client/store/modules/wiki'
|
||||
function createStore () {
|
||||
// TODO loggins mutations in dev
|
||||
return new Vuex.Store({
|
||||
state: {},
|
||||
state: {
|
||||
isPageLoading: false
|
||||
},
|
||||
actions: {},
|
||||
mutations: {},
|
||||
mutations: {
|
||||
tooglePageLoading (state) {
|
||||
state.isPageLoading = !state.isPageLoading
|
||||
}
|
||||
},
|
||||
modules: {
|
||||
category,
|
||||
categoryItem,
|
||||
|
@ -19,7 +19,7 @@ const actions: ActionTree<ICategoryState, any> = {
|
||||
if (!category) {
|
||||
return
|
||||
}
|
||||
dispatch('loadCategory', category.id)
|
||||
await dispatch('loadCategory', category.id)
|
||||
},
|
||||
async loadCategory (
|
||||
{ commit }: ActionContext<ICategoryState, any>,
|
||||
@ -43,6 +43,12 @@ const actions: ActionTree<ICategoryState, any> = {
|
||||
})
|
||||
dispatch('loadCategoryList')
|
||||
return createdId
|
||||
},
|
||||
async deleteCategory (
|
||||
{ dispatch }: ActionContext<ICategoryState, any>,
|
||||
id: ICategoryInfo['id']
|
||||
): Promise<void> {
|
||||
await CategoryService.deleteCategory(id)
|
||||
}
|
||||
}
|
||||
|
||||
|
@ -26,7 +26,6 @@ const actions: ActionTree<ICategoryItemState, any> = {
|
||||
category,
|
||||
name
|
||||
})
|
||||
dispatch('category/reloadCategory', null, { root: true })
|
||||
return createdId
|
||||
},
|
||||
async deleteItemById (context, id: ICategoryItem['id']) {
|
||||
@ -108,14 +107,14 @@ const actions: ActionTree<ICategoryItemState, any> = {
|
||||
context: ActionContext<ICategoryItemState, any>,
|
||||
{ itemId,
|
||||
type,
|
||||
text
|
||||
content
|
||||
}: {
|
||||
itemId: ICategoryItem['id'],
|
||||
type: string,
|
||||
text: string,
|
||||
content: string,
|
||||
}
|
||||
): Promise<void> {
|
||||
await CategoryItemService.createItemTrait(itemId, type, text)
|
||||
await CategoryItemService.createItemTrait(itemId, type, content)
|
||||
},
|
||||
async updateCategoryDescription (
|
||||
{ dispatch }: ActionContext<ICategoryItemState, any>,
|
||||
|
3290
front/package-lock.json
generated
3290
front/package-lock.json
generated
File diff suppressed because it is too large
Load Diff
@ -16,7 +16,6 @@
|
||||
"dependencies": {
|
||||
"@junyiz/koa-proxy-pass": "^1.2.1",
|
||||
"axios": "^0.18.0",
|
||||
"babel-polyfill": "^6.26.0",
|
||||
"easymde": "^2.4.2",
|
||||
"koa": "^2.5.0",
|
||||
"koa-bodyparser": "^4.2.0",
|
||||
@ -28,24 +27,30 @@
|
||||
"lodash": "^4.17.10",
|
||||
"moment": "^2.22.1",
|
||||
"normalize-url": "^4.1.0",
|
||||
"nprogress": "^0.2.0",
|
||||
"reflect-metadata": "^0.1.12",
|
||||
"vue": "^2.5.21",
|
||||
"vue-class-component": "^6.2.0",
|
||||
"vue": "^2.6.6",
|
||||
"vue-class-component": "^7.0.1",
|
||||
"vue-mixin-decorator": "^1.0.0",
|
||||
"vue-property-decorator": "^7.0.0",
|
||||
"vue-router": "^3.0.1",
|
||||
"vue-server-renderer": "https://github.com/aelve/vue-server-renderer#ead33010fb5cb064981f4f3fb632f65cf190d694",
|
||||
"vue-server-renderer": "^2.6.6",
|
||||
"vuetify": "^1.4.0",
|
||||
"vuex": "^3.0.1",
|
||||
"vuex-router-sync": "^5.0.0"
|
||||
},
|
||||
"devDependencies": {
|
||||
"@babel/core": "^7.2.2",
|
||||
"@babel/plugin-syntax-dynamic-import": "^7.2.0",
|
||||
"@babel/plugin-transform-runtime": "^7.2.0",
|
||||
"@babel/polyfill": "^7.2.5",
|
||||
"@babel/preset-env": "^7.3.1",
|
||||
"@fortawesome/fontawesome-free": "^5.3.1",
|
||||
"@fortawesome/fontawesome-svg-core": "^1.2.12",
|
||||
"@fortawesome/free-solid-svg-icons": "^5.6.3",
|
||||
"@fortawesome/vue-fontawesome": "^0.1.4",
|
||||
"@types/lodash": "^4.14.116",
|
||||
"babel-loader": "^7.1.4",
|
||||
"babel-loader": "^8.0.5",
|
||||
"babel-plugin-transform-runtime": "^6.23.0",
|
||||
"babel-preset-env": "^1.7.0",
|
||||
"babel-preset-stage-2": "^6.24.1",
|
||||
@ -63,17 +68,17 @@
|
||||
"postcss-loader": "^2.1.5",
|
||||
"stylus": "^0.54.5",
|
||||
"stylus-loader": "^3.0.2",
|
||||
"testcafe": "^0.22.0",
|
||||
"testcafe": "^1.0.1",
|
||||
"testcafe-vue-selectors": "^3.0.0",
|
||||
"ts-loader": "^4.4.2",
|
||||
"tslint": "^5.11.0",
|
||||
"tslint-webpack-plugin": "^1.2.2",
|
||||
"typescript": "^2.9.2",
|
||||
"url-loader": "^1.0.1",
|
||||
"vue-loader": "^15.2.4",
|
||||
"vue-style-loader": "^4.1.0",
|
||||
"vue-template-compiler": "^2.5.21",
|
||||
"webpack": "^4.6.0",
|
||||
"vue-loader": "^15.6.2",
|
||||
"vue-style-loader": "^4.1.2",
|
||||
"vue-template-compiler": "^2.6.6",
|
||||
"webpack": "^4.29.3",
|
||||
"webpack-cli": "^3.2.1",
|
||||
"webpack-dev-server": "^3.1.14",
|
||||
"webpack-merge": "^4.1.2",
|
||||
|
@ -1,3 +0,0 @@
|
||||
{
|
||||
"apiUrl": "http://localhost:4400"
|
||||
}
|
@ -22,6 +22,7 @@ extra-deps:
|
||||
- servant-swagger-ui-core-0.3.1
|
||||
- swagger2-2.3
|
||||
- lzma-clib-5.2.2
|
||||
- regex-1.0.1.5
|
||||
|
||||
# We pin the precise versions of 'highlighting-kate' and 'cmark-highlight'
|
||||
# because the frontend has copied a stylesheet from 'highlighting-kate'. If
|
||||
@ -30,6 +31,13 @@ extra-deps:
|
||||
- highlighting-kate-0.6.4
|
||||
- cmark-highlight-0.2.0.0
|
||||
|
||||
# The new version of 'di' has different 'throw' semantics; we don't use it
|
||||
# yet but let's not create technical debt for ourselves.
|
||||
- di-1.2
|
||||
- di-monad-1.3
|
||||
- di-core-1.0.3
|
||||
- df1-0.3
|
||||
|
||||
- git: https://github.com/aelve/stache-plus
|
||||
commit: c8097fb33df6ba738fc7b7c8d09aaebdb02a9782
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user