diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 "

Yay!

" +-- [ 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. diff --git a/executable/Main.hs b/executable/Main.hs new file mode 100644 --- /dev/null +++ b/executable/Main.hs @@ -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 = "

17 Austerstræti Reykjavík Iceland 107

Mitchell Baker (Mozilla Foundation)

Microformats are amazing

Published by W. Developer on

In which I extoll the virtues of using microformats.

Blah blah blah

AUTHOR: TITLE " + +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 diff --git a/library/Data/Microformats2/Parser.hs b/library/Data/Microformats2/Parser.hs --- a/library/Data/Microformats2/Parser.hs +++ b/library/Data/Microformats2/Parser.hs @@ -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.replace ">" ">" . LT.replace "&" "&") . 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.replace ">" ">" . LT.replace "&" "&") . extractPropertyContent getAllHtml E "content" +processContent Sanitize = extractPropertyContent getAllHtmlSanitized E "content" diff --git a/library/Data/Microformats2/Parser/Internal.hs b/library/Data/Microformats2/Parser/Internal.hs --- a/library/Data/Microformats2/Parser/Internal.hs +++ b/library/Data/Microformats2/Parser/Internal.hs @@ -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 diff --git a/microformats2-parser.cabal b/microformats2-parser.cabal --- a/microformats2-parser.cabal +++ b/microformats2-parser.cabal @@ -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: diff --git a/test-suite/Data/Microformats2/Parser/InternalSpec.hs b/test-suite/Data/Microformats2/Parser/InternalSpec.hs --- a/test-suite/Data/Microformats2/Parser/InternalSpec.hs +++ b/test-suite/Data/Microformats2/Parser/InternalSpec.hs @@ -19,6 +19,7 @@ it "parses p- properties" $ do let nm = extractProperty P "name" . documentRoot . parseLBS nm [xml|
Hello Basic|] `shouldBe` pure "Hello Basic" + nm [xml|

Hello Nested|] `shouldBe` pure "Hello Nested" nm [xml|

HA|] `shouldBe` pure "Hello Abbr" nm [xml|
HA|] `shouldBe` pure "HA" nm [xml|
|] `shouldBe` pure "Hello Data" diff --git a/test-suite/Data/Microformats2/ParserSpec.hs b/test-suite/Data/Microformats2/ParserSpec.hs --- a/test-suite/Data/Microformats2/ParserSpec.hs +++ b/test-suite/Data/Microformats2/ParserSpec.hs @@ -194,7 +194,7 @@ Rails is Omakase DHH -

Rails is not that. Rails is omakase...

+

Rails is not that. Rails is omakase...

|] `shouldBe` [ def { citeName = pure "Rails is Omakase" , citeUrl = pure "https://youtu.be/E99FnoYqoII" @@ -216,7 +216,7 @@ David -

Rails is not that. Rails is omakase...

+

Rails is not that. Rails is omakase...

|] `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|
-

Rails is not that. Rails is omakase...

+

Rails is not that. Rails is omakase...

|] parseEntry' Unsafe src `shouldBe` [ def { entryContent = pure $ TextContent "Rails is not that. Rails is omakase..." } ]