aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-12-25 05:43:32 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master'

Browse Source 
into sectore/bridge-uid-more-type-safety
This commit is contained in:
Jens Krause 2017-10-08 17:58:58 +02:00
commit 9f4d6469f7
No known key found for this signature in database
GPG Key ID: 3B2FAFBCEFA5906D
11 changed files with 59 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Guide/Api/Types.hs
View File

@ -32,7 +32,7 @@ import Guide.Types.Core (Category(..), CategoryStatus(..), Item(..), ItemKind
, Trait, content, uid
)
import Guide.Utils (Uid(..), Url)
import Guide.Markdown (MarkdownBlock, MarkdownInline, MarkdownTree, mdHtml, mdText)
import Guide.Markdown (MarkdownBlock, MarkdownInline, MarkdownTree, mdHtml, mdSource)
----------------------------------------------------------------------------
-- Routes
@ -190,19 +190,19 @@ class ToCMardown md where toCMarkdown :: md -> CMarkdown
instance ToCMardown MarkdownInline where
toCMarkdown md = CMarkdown
{ text = md^.mdText
{ text = md^.mdSource
, html = T.decodeUtf8 $ md^.mdHtml
}
instance ToCMardown MarkdownBlock where
toCMarkdown md = CMarkdown
{ text = md^.mdText
{ text = md^.mdSource
, html = T.decodeUtf8 $ md^.mdHtml
}
instance ToCMardown MarkdownTree where
toCMarkdown md = CMarkdown
{ text = md^.mdText
{ text = md^.mdSource
, html = T.toStrict . renderText $ toHtml md
}

10
src/Guide/Handlers.hs
View File

@ -133,7 +133,7 @@ setMethods = do
Spock.post (setRoute <//> categoryVar <//> "notes") $ \catId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (notes.mdText) <$> dbQuery (GetCategory catId)
modified <- view (notes.mdSource) <$> dbQuery (GetCategory catId)
if modified == original
then do
category <- uncache (CacheCategoryNotes catId) $ do
@ -196,7 +196,7 @@ setMethods = do
Spock.post (setRoute <//> itemVar <//> "description") $ \itemId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (description.mdText) <$> dbQuery (GetItem itemId)
modified <- view (description.mdSource) <$> dbQuery (GetItem itemId)
if modified == original
then do
item <- uncache (CacheItemDescription itemId) $ do
@ -213,7 +213,7 @@ setMethods = do
Spock.post (setRoute <//> itemVar <//> "ecosystem") $ \itemId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId)
modified <- view (ecosystem.mdSource) <$> dbQuery (GetItem itemId)
if modified == original
then do
item <- uncache (CacheItemEcosystem itemId) $ do
@ -230,7 +230,7 @@ setMethods = do
Spock.post (setRoute <//> itemVar <//> "notes") $ \itemId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (notes.mdText) <$> dbQuery (GetItem itemId)
modified <- view (notes.mdSource) <$> dbQuery (GetItem itemId)
if modified == original
then do
item <- uncache (CacheItemNotes itemId) $ do
@ -248,7 +248,7 @@ setMethods = do
Spock.post (setRoute <//> itemVar <//> traitVar) $ \itemId traitId -> do
original <- param' "original"
content' <- param' "content"
modified <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId)
modified <- view (content.mdSource) <$> dbQuery (GetTrait itemId traitId)
if modified == original
then do
trait <- uncache (CacheItemTraits itemId) $ do

40
src/Guide/Markdown.hs
View File

@ -19,7 +19,7 @@ module Guide.Markdown
-- * Lenses
mdHtml,
mdText,
mdSource,
mdMarkdown,
mdIdPrefix,
mdTree,
@ -70,19 +70,19 @@ import Guide.Utils
data MarkdownInline = MarkdownInline {
markdownInlineMdText :: Text,
markdownInlineMdSource :: Text,
markdownInlineMdHtml :: ByteString,
markdownInlineMdMarkdown :: ![MD.Node] }
deriving (Generic, Data)
data MarkdownBlock = MarkdownBlock {
markdownBlockMdText :: Text,
markdownBlockMdSource :: Text,
markdownBlockMdHtml :: ByteString,
markdownBlockMdMarkdown :: ![MD.Node] }
deriving (Generic, Data)
data MarkdownTree = MarkdownTree {
markdownTreeMdText :: Text,
markdownTreeMdSource :: Text,
markdownTreeMdTree :: !(Document Text ByteString),
markdownTreeMdIdPrefix :: Text,
markdownTreeMdTOC :: Forest ([MD.Node], Text) }
@ -147,14 +147,14 @@ stringify = T.concat . map go
-- | Extract everything before the first heading.
--
-- Note that if you render 'mdText' of the produced Markdown block, it won't
-- Note that if you render 'mdSource' of the produced Markdown block, it won't
-- necessarily parse into 'mdHtml' from the same block. It's because rendered
-- Markdown might depend on links that are defined further in the tree.
extractPreface :: MarkdownTree -> MarkdownBlock
extractPreface = mkBlock . preface . view mdTree
where
mkBlock x = MarkdownBlock {
markdownBlockMdText = getSource x,
markdownBlockMdSource = getSource x,
markdownBlockMdHtml = renderMD (stripSource x),
markdownBlockMdMarkdown = stripSource x }
@ -239,7 +239,7 @@ parseLink = either (Left . show) Right . parse p ""
toMarkdownInline :: Text -> MarkdownInline
toMarkdownInline s = MarkdownInline {
markdownInlineMdText = s,
markdownInlineMdSource = s,
markdownInlineMdHtml = html,
markdownInlineMdMarkdown = inlines }
where
@ -248,7 +248,7 @@ toMarkdownInline s = MarkdownInline {
toMarkdownBlock :: Text -> MarkdownBlock
toMarkdownBlock s = MarkdownBlock {
markdownBlockMdText = s,
markdownBlockMdSource = s,
markdownBlockMdHtml = html,
markdownBlockMdMarkdown = doc }
where
@ -257,7 +257,7 @@ toMarkdownBlock s = MarkdownBlock {
toMarkdownTree :: Text -> Text -> MarkdownTree
toMarkdownTree idPrefix s = MarkdownTree {
markdownTreeMdText = s,
markdownTreeMdSource = s,
markdownTreeMdIdPrefix = idPrefix,
markdownTreeMdTree = tree,
markdownTreeMdTOC = toc }
@ -297,23 +297,23 @@ slugifyDocument slugify doc = doc {
return sec{headingAnn = slug}
instance Show MarkdownInline where
show = show . view mdText
show = show . view mdSource
instance Show MarkdownBlock where
show = show . view mdText
show = show . view mdSource
instance Show MarkdownTree where
show = show . view mdText
show = show . view mdSource
instance A.ToJSON MarkdownInline where
toJSON md = A.object [
"text" A..= (md^.mdText),
"text" A..= (md^.mdSource),
"html" A..= T.toStrict (md^.mdHtml) ]
instance A.ToJSON MarkdownBlock where
toJSON md = A.object [
"text" A..= (md^.mdText),
"text" A..= (md^.mdSource),
"html" A..= T.toStrict (md^.mdHtml) ]
instance A.ToJSON MarkdownTree where
toJSON md = A.object [
"text" A..= (md^.mdText) ]
"text" A..= (md^.mdSource) ]
instance ToHtml MarkdownInline where
toHtmlRaw = toHtml
@ -342,22 +342,22 @@ instance ToHtml MarkdownTree where
instance SafeCopy MarkdownInline where
version = 0
kind = base
putCopy = contain . safePut . view mdText
putCopy = contain . safePut . view mdSource
getCopy = contain $ toMarkdownInline <$> safeGet
instance SafeCopy MarkdownBlock where
version = 0
kind = base
putCopy = contain . safePut . view mdText
putCopy = contain . safePut . view mdSource
getCopy = contain $ toMarkdownBlock <$> safeGet
instance SafeCopy MarkdownTree where
version = 0
kind = base
putCopy md = contain $ do
safePut (md ^. mdIdPrefix)
safePut (md ^. mdText)
safePut (md ^. mdSource)
getCopy = contain $
toMarkdownTree <$> safeGet <*> safeGet
-- | Is a piece of Markdown empty?
markdownNull :: HasMdText a Text => a -> Bool
markdownNull = T.null . view mdText
markdownNull :: HasMdSource a Text => a -> Bool
markdownNull = T.null . view mdSource

2
src/Guide/Search.hs
View File

@ -53,7 +53,7 @@ search query gs =
sortByRank [(SRItemEcosystem cat item, rank)
| cat <- gs^.categories
, item <- cat^.items
, let rank = match query (item^.ecosystem.mdText)
, let rank = match query (item^.ecosystem.mdSource)
, rank > 0 ]
where
sortByRank :: [(a, Int)] -> [a]

12
src/Guide/ServerStuff.hs
View File

@ -24,7 +24,7 @@ module Guide.ServerStuff
addEdit,
undoEdit,
invalidateCacheForEdit,
-- * Handler helpers
itemVar,
categoryVar,
@ -182,7 +182,7 @@ undoEdit (Edit'ChangeCategoryEnabledSections catId toEnable toDisable) = do
then return (Left "enabled-sections has been changed further")
else Right () <$ dbUpdate (ChangeCategoryEnabledSections catId toDisable toEnable)
undoEdit (Edit'SetCategoryNotes catId old new) = do
now <- view (notes.mdText) <$> dbQuery (GetCategory catId)
now <- view (notes.mdSource) <$> dbQuery (GetCategory catId)
if now /= new
then return (Left "notes have been changed further")
else Right () <$ dbUpdate (SetCategoryNotes catId old)
@ -207,22 +207,22 @@ undoEdit (Edit'SetItemKind itemId old new) = do
then return (Left "kind has been changed further")
else Right () <$ dbUpdate (SetItemKind itemId old)
undoEdit (Edit'SetItemDescription itemId old new) = do
now <- view (description.mdText) <$> dbQuery (GetItem itemId)
now <- view (description.mdSource) <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "description has been changed further")
else Right () <$ dbUpdate (SetItemDescription itemId old)
undoEdit (Edit'SetItemNotes itemId old new) = do
now <- view (notes.mdText) <$> dbQuery (GetItem itemId)
now <- view (notes.mdSource) <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "notes have been changed further")
else Right () <$ dbUpdate (SetItemNotes itemId old)
undoEdit (Edit'SetItemEcosystem itemId old new) = do
now <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId)
now <- view (ecosystem.mdSource) <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "ecosystem has been changed further")
else Right () <$ dbUpdate (SetItemEcosystem itemId old)
undoEdit (Edit'SetTraitContent itemId traitId old new) = do
now <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId)
now <- view (content.mdSource) <$> dbQuery (GetTrait itemId traitId)
if now /= new
then return (Left "trait has been changed further")
else Right () <$ dbUpdate (SetTraitContent itemId traitId old)

24
src/Guide/State.hs
View File

@ -82,7 +82,7 @@ module Guide.State
RestoreItem(..),
RestoreTrait(..),
SetDirty(..), UnsetDirty(..),
LoadSession(..), StoreSession(..),
DeleteSession(..), GetSessions(..),
@ -440,7 +440,7 @@ setCategoryGroup catId group' = do
setCategoryNotes :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
setCategoryNotes catId notes' = do
oldNotes <- categoryById catId . notes <<.= toMarkdownBlock notes'
let edit = Edit'SetCategoryNotes catId (oldNotes ^. mdText) notes'
let edit = Edit'SetCategoryNotes catId (oldNotes ^. mdSource) notes'
(edit,) <$> use (categoryById catId)
setCategoryStatus :: Uid Category -> CategoryStatus -> Acid.Update GlobalState (Edit, Category)
@ -516,7 +516,7 @@ setItemDescription itemId description' = do
oldDescr <- itemById itemId . description <<.=
toMarkdownBlock description'
let edit = Edit'SetItemDescription itemId
(oldDescr ^. mdText) description'
(oldDescr ^. mdSource) description'
(edit,) <$> use (itemById itemId)
setItemNotes :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
@ -524,7 +524,7 @@ setItemNotes itemId notes' = do
let pref = "item-notes-" <> uidToText itemId <> "-"
oldNotes <- itemById itemId . notes <<.=
toMarkdownTree pref notes'
let edit = Edit'SetItemNotes itemId (oldNotes ^. mdText) notes'
let edit = Edit'SetItemNotes itemId (oldNotes ^. mdSource) notes'
(edit,) <$> use (itemById itemId)
setItemEcosystem :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
@ -532,7 +532,7 @@ setItemEcosystem itemId ecosystem' = do
oldEcosystem <- itemById itemId . ecosystem <<.=
toMarkdownBlock ecosystem'
let edit = Edit'SetItemEcosystem itemId
(oldEcosystem ^. mdText) ecosystem'
(oldEcosystem ^. mdSource) ecosystem'
(edit,) <$> use (itemById itemId)
setTraitContent :: Uid Item -> Uid Trait -> Text -> Acid.Update GlobalState (Edit, Trait)
@ -540,7 +540,7 @@ setTraitContent itemId traitId content' = do
oldContent <- itemById itemId . traitById traitId . content <<.=
toMarkdownInline content'
let edit = Edit'SetTraitContent itemId traitId
(oldContent ^. mdText) content'
(oldContent ^. mdSource) content'
(edit,) <$> use (itemById itemId . traitById traitId)
-- delete
@ -781,26 +781,26 @@ setDirty = dirty .= True
unsetDirty :: Acid.Update GlobalState Bool
unsetDirty = dirty <<.= False
-- | Retrieves a session by 'SessionID'.
-- | Retrieves a session by 'SessionID'.
-- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'.
loadSession :: SessionId -> Acid.Query GlobalState (Maybe GuideSession)
loadSession key = view (sessionStore . at key)
-- | Stores a session object.
-- | Stores a session object.
-- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'.
storeSession :: GuideSession -> Acid.Update GlobalState ()
storeSession sess = do
sessionStore %= M.insert (sess ^. sess_id) sess
setDirty
-- | Deletes a session by 'SessionID'.
-- | Deletes a session by 'SessionID'.
-- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'.
deleteSession :: SessionId -> Acid.Update GlobalState ()
deleteSession key = do
sessionStore %= M.delete key
setDirty
-- | Retrieves all sessions.
-- | Retrieves all sessions.
-- Note: This utilizes a "wrapper" around Spock.Session, 'GuideSession'.
getSessions :: Acid.Query GlobalState [GuideSession]
getSessions = do
@ -815,7 +815,7 @@ getUser key = view (users . at key)
createUser :: User -> Acid.Update GlobalState Bool
createUser user = do
m <- toList <$> use users
if all (canCreateUser user) (m ^.. each)
if all (canCreateUser user) (m ^.. each)
then do
users %= M.insert (user ^. userID) user
return True
@ -841,7 +841,7 @@ loginUser :: Text -> ByteString -> Acid.Query GlobalState (Either String User)
loginUser email password = do
matches <- filter (\u -> u ^. userEmail == email) . toList <$> view users
case matches of
[user] ->
[user] ->
if verifyUser user password
then return $ Right user
else return $ Left "wrong password"

2
src/Guide/Views.hs
View File

@ -752,7 +752,7 @@ renderSearchResult r = do
a_ [class_ "category-link", href_ (categoryLink cat)] $
toHtml (cat^.title)
div_ [class_ "category-description notes-like"] $
toHtml (extractPreface $ toMarkdownTree "" $ cat^.notes.mdText)
toHtml (extractPreface $ toMarkdownTree "" $ cat^.notes.mdSource)
SRItem cat item -> do
a_ [class_ "category-link in-item-sr", href_ (categoryLink cat)] $
toHtml (cat^.title)

2
src/Guide/Views/Category.hs
View File

@ -182,6 +182,6 @@ renderCategoryNotes category = cached (CacheCategoryNotes (category^.uid)) $ do
[rows_ "10", class_ " editor "]
contents
(\val -> JS.submitCategoryNotes
(this, category^.uid, category^.notes.mdText, val))
(this, category^.uid, category^.notes.mdSource, val))
(JS.switchSection (this, "normal" :: Text))
"or press Ctrl+Enter to save"

4
src/Guide/Views/Item.hs
View File

@ -177,7 +177,7 @@ renderItemEcosystem item = cached (CacheItemEcosystem (item^.uid)) $ do
[rows_ "3", class_ " editor "]
(item^.ecosystem)
(\val -> JS.submitItemEcosystem
(this, item^.uid, item^.ecosystem.mdText, val))
(this, item^.uid, item^.ecosystem.mdSource, val))
(JS.switchSection (this, "normal" :: Text))
"or press Ctrl+Enter to save"
@ -294,7 +294,7 @@ renderItemNotes category item = cached (CacheItemNotes (item^.uid)) $ do
textareaUid <- randomLongUid
contents <- if markdownNull (item^.notes)
then liftIO $ T.readFile "static/item-notes-template.md"
else return (item^.notes.mdText)
else return (item^.notes.mdSource)
let buttons = do
textButton "collapse notes" $
JS.switchSection (this, "collapsed" :: Text)

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

@ -187,7 +187,7 @@ markdownEditor
-> JS -- ^ “Cancel” handler
-> Text -- ^ Instruction (e.g. “press Ctrl+Enter to save”)
-> HtmlT m ()
markdownEditor attr (view mdText -> s) submit cancel instr = do
markdownEditor attr (view mdSource -> s) submit cancel instr = do
textareaUid <- randomLongUid
let val = JS $ "document.getElementById(\""+|textareaUid|+"\").value"
-- Autocomplete has to be turned off thanks to
@ -219,7 +219,7 @@ smallMarkdownEditor
-> Maybe JS -- ^ “Cancel” handler (if “Cancel” is needed)
-> Text -- ^ Instruction (e.g. “press Enter to add”)
-> HtmlT m ()
smallMarkdownEditor attr (view mdText -> s) submit mbCancel instr = do
smallMarkdownEditor attr (view mdSource -> s) submit mbCancel instr = do
textareaId <- randomLongUid
let val = JS $ "document.getElementById(\""+|textareaId|+"\").value"
textarea_ ([class_ "fullwidth", uid_ textareaId, autocomplete_ "off"] ++

10
tests/MarkdownSpec.hs
View File

@ -28,7 +28,7 @@ import Guide.Markdown
tests :: Spec
tests = describe "Markdown" $ do
allMarkdowns $ \convert -> do
it "has mdText filled accurately" $ do
it "has mdSource filled accurately" $ do
for_ mdBlockExamples $ \s ->
s `shouldBe` fst (convert s)
it "only has allowed tags" $ do
@ -130,7 +130,7 @@ tests = describe "Markdown" $ do
headingAnn = "i-foo_",
content = WithSource "y\n" [foo2MD],
contentAnn = "<p>y</p>\n"},
subForest = [] }]}]}
subForest = [] }]}]}
it "has a correct TOC" $ do
let s = "x\n\n# foo\n\n## foo\n\ny"
let headingMD = MD.Node Nothing (TEXT "foo") []
@ -149,15 +149,15 @@ htmlToText = T.toStrict . renderText . toHtml
allMarkdowns :: ((Text -> (Text, Text)) -> Spec) -> Spec
allMarkdowns f = do
describe "inline MD" $
f ((view mdText &&& htmlToText) . toMarkdownInline)
f ((view mdSource &&& htmlToText) . toMarkdownInline)
blockMarkdowns f
blockMarkdowns :: ((Text -> (Text, Text)) -> Spec) -> Spec
blockMarkdowns f = do
describe "block MD" $
f ((view mdText &&& htmlToText) . toMarkdownBlock)
f ((view mdSource &&& htmlToText) . toMarkdownBlock)
describe "block+toc MD" $
f ((view mdText &&& htmlToText) . toMarkdownTree "")
f ((view mdSource &&& htmlToText) . toMarkdownTree "")
mdInlineExamples :: [Text]
mdInlineExamples = [