aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-11-23 12:15:06 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'develop' of https://github.com/aelve/guide into develop

Browse Source
This commit is contained in:
Giyos 2019-02-27 16:35:30 +05:00
commit d8af6068f9
80 changed files with 3902 additions and 1959 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.travis.yml
View File

@ -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
back/.ghci
View File

@ -1 +0,0 @@
:set -XOverloadedStrings

34
back/guide.cabal
View File

@ -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

10
back/src/Guide/Api.hs
View File

@ -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

6
back/src/Guide/Api/Error.hs
View File

@ -7,8 +7,10 @@
module Guide.Api.Error
( ErrorResponse
) where
(
ErrorResponse,
)
where
import Imports

60
back/src/Guide/Api/Guider.hs
View File

@ -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

298
back/src/Guide/Api/Methods.hs
View File

@ -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)

173
back/src/Guide/Api/Server.hs
View File

@ -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
}

18
back/src/Guide/Api/Types.hs
View File

@ -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

18
back/src/Guide/Api/Utils.hs
View File

@ -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

5
back/src/Guide/App.hs
View File

@ -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

118
back/src/Guide/Config.hs
View File

@ -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).

3
back/src/Guide/Diff.hs
View File

@ -1,8 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{- | Diff- and merge-related things.
-}
-- | Diff- and merge-related things.
module Guide.Diff
(
-- * Diffing

5
back/src/Guide/Diff/Merge.hs
View File

@ -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,

4
back/src/Guide/Handlers.hs
View File

@ -3,9 +3,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{- |
All rest API handlers.
-}
-- | All rest API handlers.
module Guide.Handlers
(
methods,

52
back/src/Guide/JS.hs
View File

@ -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
View 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
View 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
View 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
View 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

86
back/src/Guide/Main.hs
View File

@ -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 ()

8
back/src/Guide/Markdown.hs
View File

@ -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

19
back/src/Guide/Matomo.hs
View File

@ -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

22
back/src/Guide/Search.hs
View File

@ -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

22
back/src/Guide/ServerStuff.hs
View File

@ -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.

56
back/src/Guide/State.hs
View File

@ -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)
----------------------------------------------------------------------------

6
back/src/Guide/Types.hs
View 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,

22
back/src/Guide/Types/Action.hs
View File

@ -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(..),

20
back/src/Guide/Types/Core.hs
View File

@ -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(..),

12
back/src/Guide/Types/Edit.hs
View File

@ -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(..),

6
back/src/Guide/Types/Hue.hs
View File

@ -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(..),

4
back/src/Guide/Types/User.hs
View File

@ -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,

35
back/src/Guide/Utils.hs
View File

@ -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

29
back/src/Guide/Views.hs
View File

@ -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

11
back/src/Guide/Views/Auth.hs
View File

@ -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

5
back/src/Guide/Views/Auth/Login.hs
View File

@ -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

8
back/src/Guide/Views/Auth/Register.hs
View File

@ -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

8
back/src/Guide/Views/Category.hs
View File

@ -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

10
back/src/Guide/Views/Item.hs
View File

@ -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

11
back/src/Guide/Views/Page.hs
View File

@ -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

5
back/src/Guide/Views/Utils.hs
View File

@ -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

12
back/src/Guide/Views/Utils/Input.hs
View File

@ -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

6
back/src/Imports.hs
View File

@ -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,

17
back/src/To.hs
View File

@ -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

2
back/src/site/Main.hs
View File

@ -1,4 +1,4 @@
module Main where
module Main (main) where
import Prelude (IO)

307
back/tests/ApiSpec.hs Normal file
View 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
View 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

17
back/tests/Main.hs
View File

@ -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')

104
back/tests/WebSpec.hs
View File

@ -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 "/"

10
front/.babelrc
View File

@ -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": {

31
front/client/App.vue
View File

@ -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;

4
front/client/components/ALink.vue
View File

@ -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 {

7
front/client/components/AddCategoryDialog.vue
View File

@ -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>

14
front/client/components/AddItemDialog.vue
View File

@ -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>

2
front/client/components/Categories.vue
View File

@ -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 () {

53
front/client/components/Category.vue
View File

@ -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>

62
front/client/components/CategoryDescription.vue
View File

@ -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 {

45
front/client/components/CategoryItem.vue
View File

@ -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')
}

4
front/client/components/CategoryItemBtn.vue
View File

@ -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

4
front/client/components/CategoryItemSection.vue
View File

@ -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'

16
front/client/components/CategoryItemToolbar.vue
View File

@ -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;

29
front/client/components/CategoryItemTraits.vue
View File

@ -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 {

4
front/client/components/ConfirmDialog.vue
View File

@ -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 {

93
front/client/components/ConflictDialog.vue
View File

@ -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>

3
front/client/components/Logo.vue
View File

@ -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 {}

4
front/client/components/MarkdownEditor.vue
View File

@ -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 {

57
front/client/entry.client.ts
View File

@ -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
View 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
View 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
}
}

6
front/client/page/SearchResults.vue
View File

@ -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)
}

13
front/client/router/index.ts
View File

@ -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 }
}

4
front/client/service/Category.ts
View File

@ -23,6 +23,10 @@ class CategoryService {
})
return data
}
async deleteCategory (id: ICategoryInfo['id']): Promise<void> {
await axios.delete(`api/category/${id}`)
}
}
export enum CategoryStatus {

9
front/client/service/CategoryItem.ts
View File

@ -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

10
front/client/store/index.ts
View File

@ -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,

8
front/client/store/modules/category.ts
View File

@ -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)
}
}

7
front/client/store/modules/categoryItem.ts
View File

@ -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
View File

File diff suppressed because it is too large Load Diff

25
front/package.json
View File

@ -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",

3
front/server/config.json
View File

@ -1,3 +0,0 @@
{
"apiUrl": "http://localhost:4400"
}

8
stack.yaml
View File

@ -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