Skip to content
Permalink
Browse files

update microformats2-types

  • Loading branch information...
myfreeweb committed Feb 23, 2015
1 parent 55a1770 commit 5ce082d9d98cd8e59f6ba86e6852d2e9d781844d
@@ -5,6 +5,7 @@ all: install configure build haddock test hpc
build:
touch library/Sweetroll/Conf.hs
cabal build
strip dist/build/sweetroll/sweetroll

clean:
cabal clean
@@ -72,13 +72,13 @@ makeEntry ∷ [Param] → UTCTime → LText → (ReaderOptions → String → Pa
makeEntry pars now absUrl readerF = def
{ entryName = par "name"
, entrySummary = par "summary"
, entryContent = Left <$> readerF pandocReaderOptions <$> unpack <$> par "content"
, entryPublished = Just $ fromMaybe now $ parseISOTime =<< par "published"
, entryUpdated = Just now
, entryAuthor = somewhereFromMaybe $ par "author"
, entryCategory = parseTags $ fromMaybe "" $ par "category"
, entryUrl = Just absUrl
, entryInReplyTo = Right <$> par "in-reply-to"
, entryLikeOf = Right <$> par "like-of"
, entryRepostOf = Right <$> par "repost-of" }
where par = findByKey pars
, entryContent = PandocContent <$> readerF pandocReaderOptions <$> unpack <$> par "content"
, entryPublished = pure . fromMaybe now . headMay . catMaybes $ parseISOTime <$> par "published"
, entryUpdated = pure now
, entryAuthor = TextCard <$> par "author"
, entryCategory = join $ parseTags <$> par "category"
, entryUrl = pure absUrl
, entryInReplyTo = UrlEntry <$> par "in-reply-to"
, entryLikeOf = UrlEntry <$> par "like-of"
, entryRepostOf = UrlEntry <$> par "repost-of" }
where par = maybeToList . findByKey pars
@@ -37,34 +37,34 @@ data ViewResult = ViewResult

entryView CategoryName [EntrySlug] (EntrySlug, Entry) ViewResult
entryView catName otherSlugs (slug, e) =
ViewResult { titleParts = [toStrict (fromMaybe ("Note @ " ++ published) (entryName e)), pack catName]
ViewResult { titleParts = [toStrict (fromMaybe ("Note @ " ++ published) . headMay $ entryName e), pack catName]
, tplContext = ctx }
where content = renderContent writeHtmlString e
published = fromMaybe "" (formatTimeText <$> entryPublished e)
published = orEmpty $ formatTimeText <$> entryPublished e
slugIdx = fromMaybe (negate 1) $ elemIndex slug otherSlugs
prev = atMay otherSlugs $ slugIdx - 1
next = atMay otherSlugs $ slugIdx + 1
twitterId = lastMay =<< LT.splitOn "/" <$> find (isInfixOf "twitter.com") (entrySyndication e)
ctx = object [
"name" .= fromMaybe "" (entryName e)
"name" .= orEmpty (entryName e)
, "content" .= content
, "published" .= published
, "publishedAttr" .= fromMaybe "" (formatTimeAttr <$> entryPublished e)
, "publishedAttr" .= orEmpty (formatTimeAttr <$> entryPublished e)
, "permalink" .= mconcat ["/", catName, "/", pack slug]
, "isNote" .= isNothing (entryName e)
, "isNote" .= (null . entryName $ e)
, "category" .= catName
, "categoryHref" .= mconcat ["/", catName]
, "hasPrev" .= isJust prev
, "prevHref" .= mconcat ["/", catName, "/", fromMaybe "" prev]
, "hasNext" .= isJust next
, "nextHref" .= mconcat ["/", catName, "/", fromMaybe "" next]
, "hasSyndication" .= (not . null $ entrySyndication e)
, "hasSyndication" .= (not . null . entrySyndication $ e)
, "syndication" .= entrySyndication e
, "hasTwitterId" .= isJust twitterId
, "twitterId" .= fromMaybe "" twitterId
, "isReply" .= isJust (entryInReplyTo e)
, "replyForUrl" .= fromMaybe "" (derefEntry =<< entryInReplyTo e)
, "replyForName" .= fromMaybe "" (derefEntryName =<< entryInReplyTo e)
, "isReply" .= (not . null . entryInReplyTo $ e)
, "replyForUrl" .= fromMaybe "" (derefEntry =<< headMay (entryInReplyTo e))
, "replyForName" .= fromMaybe "" (derefEntryName =<< headMay (entryInReplyTo e))
-- TODO: repost/like
]

@@ -104,9 +104,10 @@ notFoundView ∷ ViewResult
notFoundView = ViewResult { titleParts = ["404"], tplContext = object [] }

renderContent (WriterOptions Pandoc String) Entry LText
renderContent writer e = case fromMaybe (Right "") $ entryContent e of
Left p pack $ writer pandocWriterOptions p
Right t t
renderContent writer e = case headMay $ entryContent e of
Just (PandocContent p) pack $ writer pandocWriterOptions p
Just (TextContent t) t
_ -> ""

renderRaw Template [Pair] Text
renderRaw t c = renderTemplate t helpers $ object c
@@ -28,7 +28,7 @@ trimmedText ∷ Index LText → Entry → (Bool, LText)
trimmedText l entry = (isArticle, if isTrimmed then take (l - 1) t ++ "" else t)
where isTrimmed = length t > fromIntegral l
(isArticle, t) = case entryName entry of
Just n (True, n)
n : _ (True, n)
_ (False, renderContent writePlain entry)

ifSuccess (m * *) body a. Monad m Response body Maybe a m (Maybe a)
@@ -39,7 +39,7 @@ postAppDotNet entry = do
req parseUrlP "/posts" =<< getConfOpt adnApiHost
bearer getConfOpt adnApiToken
let (isArticle, txt) = trimmedText 250 entry
pUrl = fromMaybe "" $ entryUrl entry
pUrl = orEmpty . entryUrl $ entry
o = object
reqData = o [ "text" .= if isArticle then txt else "[x] " ++ txt
, "annotations" .= [ o [ "type" .= asLText "net.app.core.crosspost"
@@ -64,7 +64,7 @@ postTwitter entry = do
req parseUrlP "/statuses/update.json" =<< getConfOpt twitterApiHost
conf getConf
let (_, txt) = trimmedText 100 entry -- TODO: Figure out the number based on mentions of urls/domains in the first (140 - 25) characters
pUrl = fromMaybe "" $ entryUrl entry
pUrl = orEmpty . entryUrl $ entry
reqBody = writeForm [("status", txt ++ " " ++ pUrl)]
req' = req { method = "POST"
, queryString = reqBody -- Yes, queryString... WTF http://ox86.tumblr.com/post/36810273719/twitter-api-1-1-responds-with-status-401-code-32
@@ -80,7 +80,7 @@ postTwitter entry = do

-- | Constructs a tweet URL from tweet JSON.
--
-- >>> (tweetUrl $ decode $ fromString "{\"id_str\": \"1234\", \"user\": {\"screen_name\": \"username\"}}") Maybe String
-- >>> (tweetUrl $ decode $ fromString "{\"id_str\": \"1234\", \"user\": {\"screen_name\": \"username\"}}") :: Maybe String
-- Just "https://twitter.com/username/status/1234"
tweetUrl (S.Stringable s) Maybe Value Maybe s
tweetUrl root' = do
@@ -89,11 +89,16 @@ writeForm ps = intercalate "&" $ map (\(k, v) → enc k ++ "=" ++ enc v) ps
where enc = urlEncode True . toByteString

derefEntry EntryReference Maybe LText
derefEntry (Left (Here c)) = citeUrl c
derefEntry (Right l) = Just l
derefEntry _ = Nothing
derefEntry (EntryEntry e) = headMay . entryUrl $ e
derefEntry (CiteEntry c) = headMay . citeUrl $ c
derefEntry (TextEntry l) = Just l
derefEntry (UrlEntry l) = Just l

derefEntryName EntryReference Maybe LText
derefEntryName (Left (Here c)) = citeName c
derefEntryName (Right l) = Just l
derefEntryName _ = Nothing
derefEntryName (EntryEntry e) = headMay . entryName $ e
derefEntryName (CiteEntry c) = headMay . citeName $ c
derefEntryName (TextEntry l) = Just l
derefEntryName (UrlEntry l) = Just l

orEmpty [LText] LText
orEmpty = fromMaybe "" . headMay
@@ -67,12 +67,12 @@ sendWebmention from to = do
-- metadata (in-reply-to, like-of, repost-of).
sendWebmentions Entry SweetrollBase [(String, Bool)]
sendWebmentions e = mapM (sendWebmention from) links
where links = S.toList $ S.fromList $ contentLinks ++ metaLinks
metaLinks = map unpack $ mapMaybe derefEntry $ catMaybes [entryInReplyTo e, entryLikeOf e, entryRepostOf e]
contentLinks = PW.query extractLink $ pandocContent $ entryContent e
from = unpack $ fromMaybe "" $ entryUrl e
pandocContent (Just (Left p)) = p
pandocContent (Just (Right t)) = P.readMarkdown pandocReaderOptions $ unpack t
where links = S.toList . S.fromList $ contentLinks ++ metaLinks
metaLinks = map unpack . mapMaybe derefEntry . catMaybes . map headMay $ [entryInReplyTo e, entryLikeOf e, entryRepostOf e]
contentLinks = PW.query extractLink . pandocContent $ entryContent e
from = unpack . orEmpty . entryUrl $ e
pandocContent ((PandocContent p) : _) = p
pandocContent ((TextContent t) : _) = P.readMarkdown pandocReaderOptions . unpack $ t
pandocContent _ = P.readMarkdown pandocReaderOptions ""
extractLink (P.Link _ (u, _)) = [u]
extractLink _ = []
@@ -40,12 +40,12 @@ library
, blaze-markup
, blaze-builder
, time
, pcre-heavy == 0.2.*
, pcre-heavy >= 0.2.2
, aeson
, lens-aeson
, jwt
, gitson == 0.5.*
, microformats2-types == 0.3.*
, microformats2-types == 0.4.*
, wai
, wai-extra
, wai-middleware-static
@@ -134,9 +134,7 @@ test-suite tests
, simple-templates == 0.8.*
, aeson
, data-default
, hspec == 1.*
, HUnit
, QuickCheck
, hspec == 2.1.*
default-language: Haskell2010
ghc-options: -threaded -fhpc -Wall -Werror
hs-source-dirs: test-suite
@@ -118,8 +118,9 @@ ul, ol {
a {
color: #0074df;
transition: ease-in-out color 0.3s;
text-decoration: none;
}
a:hover, a:focus, a:active { color: #7fdbff }
a:hover, a:focus, a:active { color: #7fdbff; text-decoration: underline }
a.self-link { color: #343434; text-decoration: none; }
.fa-l { margin-right: 0.25em }
.fa-r { margin-left: 0.25em }
@@ -154,7 +155,7 @@ a.self-link { color: #343434; text-decoration: none; }
font-size: 90%;
color: #aaa;
}
.note-entry { border: 1px solid; border-color: #39cccc; border-color: rgba(57, 204, 204, 0.7) }
.note-entry { border: 1px solid; border-color: #39cccc; border-color: rgba(57, 204, 204, 0.3) }
.note-entry .entry-header { font-size: 90%; margin-bottom: 1em; }
.note-entry .entry-header, .note-entry .entry-header a { color: #aaa }
.note-entry .entry-content { font-size: 110% }
@@ -164,11 +165,9 @@ a.self-link { color: #343434; text-decoration: none; }
font-size: 95%;
line-height: 1.7;
}
.entry-footer a { text-decoration: none }
.entry-main .entry-header, .entry-main .entry-content, .entry-main .entry-footer { margin: 16px; margin: 1rem; }
.entry-main .entry-footer a { margin-left: 0.5em }
.entry-main .entry-footer .entry-actions indie-action:first-child a { margin-left: 0 }
.entry-footer a:hover { text-decoration: underline }
.entry-footer h2 {
font-size: 100%;
display: inline;
@@ -197,6 +196,7 @@ a.self-link { color: #343434; text-decoration: none; }
padding: 0 1em 0 0;
}
.index-category:last-child { padding: 0 }
#author-link { display: none; }
}
@media screen and (min-width:80em) {
.site-header, .site-content, .site-footer { width: 80% }
@@ -12,9 +12,10 @@
<body>
<header class="site-header">
<h1><a href="/">$website_title$</a></h1>
<a href="#author" id="author-link"><i class="fa fa-l fa-info-circle"></i></a>
</header>
<div class="site-content">
<aside class="site-author h-card">
<aside class="site-author h-card" id="author">
$author$
</aside>
$content$
@@ -49,9 +49,9 @@ spec = around_ inDir $ do
it "renders the index" $ do
transaction' $ do
saveNextDocument "posts" "first" $ def {
entryName = Just "Post 1" }
entryName = pure "Post 1" }
saveNextDocument "thingies" "tweeeet" $ def {
entryContent = Just $ Left $ readMarkdown def "Something 1" }
entryContent = pure . PandocContent . readMarkdown def $ "Something 1" }
resp app >>= get "/"
simpleBody resp `shouldSatisfy` (`contains` "posts")
simpleBody resp `shouldSatisfy` (`contains` "thingies")
@@ -63,9 +63,9 @@ spec = around_ inDir $ do
it "renders categories" $ do
transaction' $ do
saveNextDocument "articles" "first" $ def {
entryName = Just "First" }
entryName = pure "First" }
saveNextDocument "articles" "second" $ def {
entryName = Just "Second" }
entryName = pure "Second" }
resp app >>= get "/articles"
simpleBody resp `shouldSatisfy` (`contains` "articles")
simpleBody resp `shouldSatisfy` (`contains` "First")
@@ -79,8 +79,8 @@ spec = around_ inDir $ do

it "renders entries" $ do
transaction' $ saveNextDocument "articles" "hello-world" $ def {
entryName = Just "Hello, World!"
, entryAuthor = Somewhere "/" }
entryName = pure "Hello, World!"
, entryAuthor = pure . TextCard $ "/" }
resp app >>= get "/articles/hello-world"
simpleBody resp `shouldSatisfy` (`contains` "Hello, World!")
simpleStatus resp `shouldBe` ok200
@@ -93,7 +93,7 @@ spec = around_ inDir $ do
written readDocumentById "articles" 1 IO (Maybe Entry)
case written of
Just article do
entryContent article `shouldBe` (Just $ Left $ readMarkdown def "Hello")
entryContent article `shouldBe` (pure . PandocContent . readMarkdown def $ "Hello")
entryCategory article `shouldBe` ["test", "demo"]
Nothing error "article not written"

@@ -45,36 +45,36 @@ spec = do

it "renders notes" $ do
let testNote = def {
entryContent = Just $ Right "Hello, world!"
, entryPublished = parseISOTime ("2013-10-17T09:42:49.000Z" String) }
entryContent = pure . TextContent $ "Hello, world!"
, entryPublished = maybeToList . parseISOTime $ ("2013-10-17T09:42:49.000Z" String) }
testRender testEntryTpl (entryView "articles" [] ("first", testNote)) `shouldBe` [r|<note>
<p>Hello, world!</p>
<time datetime="2013-10-17 09:42">17.10.2013 09:42 AM</time>
</note>|]

it "renders articles" $ do
let testArticle = def {
entryName = Just "First post"
, entryContent = Just $ Right "<p>This is the content</p>"
, entryPublished = parseISOTime ("2013-10-17T09:42:49.000Z" String) }
entryName = pure "First post"
, entryContent = pure . TextContent $ "<p>This is the content</p>"
, entryPublished = maybeToList . parseISOTime $ ("2013-10-17T09:42:49.000Z" String) }
testRender testEntryTpl (entryView "articles" [] ("first", testArticle)) `shouldBe` [r|<article>
<h1><a href="/articles/first">First post</a></h1>
<p>This is the content</p>
<time datetime="2013-10-17 09:42">17.10.2013 09:42 AM</time>
</article>|]

it "renders categories" $ do
let testEntries = [ ("f", def { entryContent = Just $ Right "First note" })
, ("s", def { entryContent = Just $ Right "Second note" }) ]
let testEntries = [ ("f", def { entryContent = pure . TextContent $ "First note" })
, ("s", def { entryContent = pure . TextContent $ "Second note" }) ]
testRender testCategoryTpl (catView def "test" $ fromJust $ paginate False 10 1 testEntries) `shouldBe` [r|<category name="test">
<e href="/test/f">First note</e>
<e href="/test/s">Second note</e>
</category>|]

it "renders the index" $ do
let testCats = [ ("stuff", fromJust $ paginate False 10 1
[ ("first", def { entryContent = Just $ Right "First" })
, ("second", def { entryContent = Just $ Right "Second" }) ]) ]
[ ("first", def { entryContent = pure . TextContent $ "First" })
, ("second", def { entryContent = pure . TextContent $ "Second" }) ]) ]
testRender testIndexTpl (indexView def testCats) `shouldBe` [r|<index>
<category name="stuff">
<e href="/stuff/first">First</e>

0 comments on commit 5ce082d

Please sign in to comment.
You can’t perform that action at this time.