packages feed

microformats2-parser 0.1.0 → 0.1.1

raw patch · 7 files changed

+138/−12 lines, 7 filesdep +blaze-htmldep +networkdep +optionsnew-component:exe:microformats2-parser

Dependencies added: blaze-html, network, options, scotty, streaming-commons, stringable, wai-extra, warp

Files

README.md view
@@ -10,6 +10,21 @@ [sweetroll]: https://github.com/myfreeweb/sweetroll [microformats2-types]: https://github.com/myfreeweb/microformats2-types +## [DEMO PAGE](https://unrelenting.technology/mf2/)++## Usage++```haskell+{-# LANGUAGE OverloadedStrings #-}+import Data.Microformats2.Parser+import Data.Microformats2.Types++parseEntry Sanitize $ documentRoot $ parseLBS "<body><p class=h-entry><h1 class=p-name>Yay!</h1></p></body>"+-- [ Entry { entryName = [ "Yay!" ], ... } ]+```++Look at the API docs [on Hackage](https://hackage.haskell.org/package/microformats2-parser) for more info.+ ## Development  Use [stack] to build.
+ executable/Main.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-}++module Main (main) where++import           Control.Exception+import           Data.Microformats2.Parser+import           Data.List+import           Data.Maybe (fromMaybe)+import qualified Data.Text.Lazy as TL+import           Data.Streaming.Network (bindPath)+import qualified Data.Stringable as S+import           Network.Wai.Handler.Warp+import qualified Network.Wai.Handler.CGI as CGI+import qualified Network.Socket as S+import           Web.Scotty+import           Text.Blaze.Html5 as H+import           Text.Blaze.Html5.Attributes as A+import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import qualified Options as O+++data AppOptions = AppOptions+  { port                     ∷ Int+  , socket                   ∷ String+  , protocol                 ∷ String }++instance O.Options AppOptions where+  defineOptions = pure AppOptions+    <*> O.simpleOption "port"              3000                                  "The port the app should listen for connections on (for http protocol)"+    <*> O.simpleOption "socket"            "/var/run/mf2/mf2.sock"               "The UNIX domain socket the app should listen for connections on (for unix protocol)"+    <*> O.simpleOption "protocol"          "http"                                "The protocol for the server. One of: http, unix, cgi"++exampleValue = "<body> <p class='h-adr'>   <span class='p-street-address'>17 Austerstræti</span>   <span class='p-locality'>Reykjavík</span>   <span class='p-country-name'>Iceland</span>   <span class='p-postal-code'>107</span> </p> <div class='h-card'>   <a class='p-name u-url'      href='http://blog.lizardwrangler.com/'      >Mitchell Baker</a>    (<a class='p-org h-card'        href='http://mozilla.org/'      >Mozilla Foundation</a>) </div> <article class='h-entry'>   <h1 class='p-name'>Microformats are amazing</h1>   <p>Published by <a class='p-author h-card' href='http://example.com'>W. Developer</a>      on <time class='dt-published' datetime='2013-06-13 12:00:00'>13<sup>th</sup> June 2013</time>     <p class='p-summary'>In which I extoll the virtues of using microformats.</p>     <div class='e-content'>     <p>Blah blah blah</p>   </div> </article> <span class='h-cite'>   <time class='dt-published'>YYYY-MM-DD</time>    <span class='p-author h-card'>AUTHOR</span>:    <cite><a class='u-url p-name' href='URL'>TITLE</a></cite> </span> </body>"++homePage ∷ TL.Text → Html → Html+homePage v result = docTypeHtml $ do+  H.head $ do+    H.meta ! charset "utf-8"+    H.title "microformats2-parser"+    H.style "body { font-family: 'Helvetica Neue', sans-serif; max-width: 900px; margin: 0 auto; } a { color: #ba2323; } a:hover { color: #da4343; } pre, textarea, button { width: 100%; } textarea { resize: vertical; min-height: 10em; margin-bottom: 1em; } pre { white-space: pre-wrap; } footer { margin: 2em 0; }"+  H.body $ do+    h1 $ do+      a ! href "https://github.com/myfreeweb/microformats2-parser" $ "microformats2-parser"+    p "This is a test page for the Microformats 2 Haskell parser."+    p "Note:"+    ul $ do+      li "this demo page uses the Sanitize mode for e-content in h-cite and h-entry"+    H.form ! method "post" ! action "" $ do+      textarea ! name "html" $ toHtml v+      button "Parse!"+    result+    footer $ do+      a ! href "https://unrelenting.technology" $ "unrelenting.technology"++display ∷ Show α ⇒ α → Html+display = pre . toHtml . S.toLazyText . show++parseResult ∷ TL.Text → Html+parseResult h = section $ do+  let root = documentRoot $ parseLBS $ S.toLazyByteString h+  h2 "h-geo"+  display $ parseGeo root+  h2 "h-adr"+  display $ parseAdr root+  h2 "h-card"+  display $ parseCard root+  h2 "h-cite"+  display $ parseCite Sanitize root+  h2 "h-entry"+  display $ parseEntry Sanitize root++app = scottyApp $ do+  matchAny "/" $ do+    ps ← params+    let h' = lookup "html" ps+        result = case h' of+                   Just h → parseResult h+                   Nothing → toHtml ("" ∷ TL.Text)+    setHeader "Content-Type" "text/html; charset=utf-8"+    raw $ renderHtml $ homePage (fromMaybe exampleValue h') result++main = O.runCommand $ \opts args → do+  let warpSettings = setPort (port opts) defaultSettings+  case protocol opts of+    "http" → app >>= runSettings warpSettings+    "unix" → bracket (bindPath $ socket opts) S.close (\socket → app >>= runSettingsSocket warpSettings socket)+    "cgi" → app >>= CGI.run+    _ → putStrLn $ "Unsupported protocol: " ++ protocol opts
library/Data/Microformats2/Parser.hs view
@@ -166,7 +166,7 @@                        , entryRepostOf    = UrlEntry <$> extractPropertyL U "repost-of" e }  processContent ∷ HtmlContentMode → Element → [LT.Text]-processContent Unsafe   = extractPropertyContent getAllHtml P "content"-processContent Strip    = extractPropertyContent getAllText P "content"-processContent Escape   = map (LT.replace "<" "&lt;" . LT.replace ">" "&gt;" . LT.replace "&" "&amp;") . extractPropertyContent getAllHtml P "content"-processContent Sanitize = extractPropertyContent getAllHtmlSanitized P "content"+processContent Unsafe   = extractPropertyContent getAllHtml E "content"+processContent Strip    = extractPropertyContent getAllText E "content"+processContent Escape   = map (LT.replace "<" "&lt;" . LT.replace ">" "&gt;" . LT.replace "&" "&amp;") . extractPropertyContent getAllHtml E "content"+processContent Sanitize = extractPropertyContent getAllHtmlSanitized E "content"
library/Data/Microformats2/Parser/Internal.hs view
@@ -25,12 +25,12 @@ if' ∷ Bool → Maybe a → Maybe a if' c x = if c then x else Nothing -notMicroformat ∷ Traversal' Element Element-notMicroformat = attributeSatisfies "class" $ not . (≈ [re|h-\w+|])- entireNotMicroformat ∷ Traversal' Element Element-entireNotMicroformat f e@(Element _ _ ns) = com <$> f e <*> traverse (_Element (notMicroformat $ entireNotMicroformat f)) ns+entireNotMicroformat f e@(Element _ _ ns) = com <$> f e <*> traverse (_Element (entireNotMicroformat f)) (filter notMf ns)   where com (Element n a _) = Element n a+        notMf (NodeElement (Element _ a _)) = not $ (fromMaybe "" $ lookup "class" $ map unwrapName $ M.toList a) ≈ [re|h-\w+|]+        notMf _ = True+        unwrapName (Name n _ _, val) = (n, val)  hasOneClass ∷ [String] → Traversal' Element Element hasOneClass ns = attributeSatisfies "class" $ \a → any (\x → T.isInfixOf (T.pack x) a) ns
microformats2-parser.cabal view
@@ -1,5 +1,5 @@ name:            microformats2-parser-version:         0.1.0+version:         0.1.1 synopsis:        A Microformats 2 parser. category:        Web homepage:        https://github.com/myfreeweb/microformats2-parser@@ -40,6 +40,27 @@         Data.Microformats2.Parser.Internal     ghc-options: -Wall     hs-source-dirs: library++executable microformats2-parser+    build-depends:+        base >= 4.0.0.0 && < 5+      , options+      , warp+      , wai-extra+      , network+      , streaming-commons+      , stringable+      , text+      , scotty+      , blaze-html+      , blaze-markup+      , microformats2-parser+      , microformats2-types+    default-language: Haskell2010+    ghc-prof-options: -auto-all -prof+    ghc-options: -threaded -rtsopts -with-rtsopts=-N+    hs-source-dirs: executable+    main-is: Main.hs  test-suite tests     build-depends:
test-suite/Data/Microformats2/Parser/InternalSpec.hs view
@@ -19,6 +19,7 @@     it "parses p- properties" $ do       let nm = extractProperty P "name" . documentRoot . parseLBS       nm [xml|<div><span class="p-name">Hello Basic</span>|] `shouldBe` pure "Hello Basic"+      nm [xml|<div><p><span class="p-name">Hello Nested</span>|] `shouldBe` pure "Hello Nested"       nm [xml|<div><abbr class="p-name" title="Hello Abbr">HA</abbr>|] `shouldBe` pure "Hello Abbr"       nm [xml|<div><abbr class="p-name">HA</abbr>|] `shouldBe` pure "HA"       nm [xml|<div><data class="p-name" value="Hello Data" />|] `shouldBe` pure "Hello Data"
test-suite/Data/Microformats2/ParserSpec.hs view
@@ -194,7 +194,7 @@             <a class="p-name u-url u-uid" href="https://youtu.be/E99FnoYqoII">Rails is Omakase</a>             <span class="p-author h-card"><span class="p-name">DHH</span></span>             <time class="dt-published">2013-01-25</time>-            <p class="p-content">Rails is not that. Rails is omakase...</p>+            <p class="e-content">Rails is not that. Rails is omakase...</p>           </article>         </div>|] `shouldBe` [ def { citeName = pure "Rails is Omakase"                                   , citeUrl = pure "https://youtu.be/E99FnoYqoII"@@ -216,7 +216,7 @@             <a href="http://david.heinemeierhansson.com" class="p-author">David</a>             <time class="dt-published">2013-01-25</time>             <time class="dt-updated">2013-01-25T01:23</time>-            <p class="p-content">Rails is not that. Rails is omakase...</p>+            <p class="e-content">Rails is not that. Rails is omakase...</p>           </article>         </div>|] `shouldBe` [ def { entryName = pure "Rails is Omakase"                                   , entryUrl = pure "https://youtu.be/E99FnoYqoII"@@ -231,7 +231,7 @@     it "supports different html content modes" $ do       let src = [xml|<div>           <article class="h-entry">-            <p class="p-content"><script>alert('XSS')</script><a href="http://rubyonrails.org" onclick="alert()">Rails</a> is not that. Rails is omakase...</p>+            <p class="e-content"><script>alert('XSS')</script><a href="http://rubyonrails.org" onclick="alert()">Rails</a> is not that. Rails is omakase...</p>           </article>         </div>|]       parseEntry' Unsafe   src `shouldBe` [ def { entryContent = pure $ TextContent "<script>alert('XSS')</script><a href=\"http://rubyonrails.org\" onclick=\"alert()\">Rails</a> is not that. Rails is omakase..." } ]