scrapbook-core (empty) → 0.5.0
raw patch · 23 files changed
+1185/−0 lines, 23 filesdep +aesondep +aeson-prettydep +base
Dependencies added: aeson, aeson-pretty, base, extensible, feed, modern-uri, req, rio, scrapbook-core, tasty, tasty-hunit, xml-conduit, xml-types, yaml
Files
- CHANGELOG.md +13/−0
- LICENSE +21/−0
- README.md +6/−0
- scrapbook-core.cabal +110/−0
- src/ScrapBook.hs +10/−0
- src/ScrapBook/Collecter.hs +40/−0
- src/ScrapBook/Data/Config.hs +62/−0
- src/ScrapBook/Data/Format.hs +35/−0
- src/ScrapBook/Data/Site.hs +96/−0
- src/ScrapBook/Feed.hs +61/−0
- src/ScrapBook/Feed/Atom.hs +106/−0
- src/ScrapBook/Feed/Atom/Internal.hs +249/−0
- src/ScrapBook/Feed/RSS.hs +50/−0
- src/ScrapBook/Fetch.hs +30/−0
- src/ScrapBook/Fetch/Internal.hs +53/−0
- src/ScrapBook/Internal/Instances.hs +23/−0
- src/ScrapBook/Internal/Utils.hs +35/−0
- src/ScrapBook/Json.hs +26/−0
- src/ScrapBook/Write.hs +40/−0
- src/ScrapBook/Write/Internal.hs +29/−0
- test/Spec.hs +13/−0
- test/Test/ScrapBook/Data/Site.hs +34/−0
- test/Test/ScrapBook/Internal/Utils.hs +43/−0
+ CHANGELOG.md view
@@ -0,0 +1,13 @@+# Changelog for scrapbook++## Unreleased changes++## 0.5.0++- Refactor: update resolver to lts-16.9+ - update feed package to 1.3+ - update req package to 3.5.0++## 0.4.0++Divid scrapbook package
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 MATSUBARA Nobutada++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,6 @@+# scrapbook++[](https://hackage.haskell.org/package/scrapbook-core)+[](https://travis-ci.org/matsubara0507/scrapbook)++Core package for scrapbook cli.
+ scrapbook-core.cabal view
@@ -0,0 +1,110 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 07177cd9c7ed93914cb1a4a866f715eb356dd2fce01ec7eedb1ce164f4e395b8++name: scrapbook-core+version: 0.5.0+synopsis: Core Package for scrapbook+description: Please see the README on GitHub at <https://github.com/matsubara0507/scrapbook#readme>+category: Web+homepage: https://github.com/matsubara0507/scrapbook#readme+bug-reports: https://github.com/matsubara0507/scrapbook/issues+author: MATSUBARA Nobutada+maintainer: MATSUBARA Nobutada+copyright: 2019 MATSUBARA Nobutada+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/matsubara0507/scrapbook++library+ exposed-modules:+ ScrapBook+ ScrapBook.Collecter+ ScrapBook.Data.Config+ ScrapBook.Data.Format+ ScrapBook.Data.Site+ ScrapBook.Feed+ ScrapBook.Feed.Atom+ ScrapBook.Feed.RSS+ ScrapBook.Fetch+ ScrapBook.Json+ ScrapBook.Write+ other-modules:+ ScrapBook.Feed.Atom.Internal+ ScrapBook.Fetch.Internal+ ScrapBook.Internal.Utils+ ScrapBook.Internal.Instances+ ScrapBook.Write.Internal+ hs-source-dirs:+ src+ default-extensions: NoImplicitPrelude+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -optP-Wno-nonportable-include-path+ build-depends:+ aeson+ , aeson-pretty+ , base >=4.7 && <5+ , extensible >=0.5+ , feed >=1.3+ , modern-uri+ , req >=3.0+ , rio >=0.1.5+ , xml-conduit+ , xml-types+ , yaml+ default-language: Haskell2010++test-suite scrapbook-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Test.ScrapBook.Data.Site+ Test.ScrapBook.Internal.Utils+ ScrapBook+ ScrapBook.Collecter+ ScrapBook.Data.Config+ ScrapBook.Data.Format+ ScrapBook.Data.Site+ ScrapBook.Feed+ ScrapBook.Feed.Atom+ ScrapBook.Feed.Atom.Internal+ ScrapBook.Feed.RSS+ ScrapBook.Fetch+ ScrapBook.Fetch.Internal+ ScrapBook.Internal.Instances+ ScrapBook.Internal.Utils+ ScrapBook.Json+ ScrapBook.Write+ ScrapBook.Write.Internal+ Paths_scrapbook_core+ hs-source-dirs:+ test+ src+ default-extensions: NoImplicitPrelude+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -optP-Wno-nonportable-include-path+ build-depends:+ aeson+ , aeson-pretty+ , base >=4.7 && <5+ , extensible >=0.5+ , feed >=1.3+ , modern-uri+ , req >=3.0+ , rio >=0.1.5+ , scrapbook-core+ , tasty+ , tasty-hunit+ , xml-conduit+ , xml-types+ , yaml+ default-language: Haskell2010
+ src/ScrapBook.hs view
@@ -0,0 +1,10 @@+module ScrapBook+ ( module X+ ) where++import ScrapBook.Collecter as X+import ScrapBook.Data.Config as X+import ScrapBook.Data.Format as X+import ScrapBook.Data.Site as X+import ScrapBook.Fetch as X+import ScrapBook.Write as X
+ src/ScrapBook/Collecter.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module ScrapBook.Collecter where++import RIO+import qualified RIO.Text as T++import Data.Yaml (ParseException)+import Network.HTTP.Req (HttpException)++type Collecter = RIO Env++newtype Env = Env { logFunc :: LogFunc }++instance HasLogFunc Env where+ logFuncL = lens logFunc (\x y -> x { logFunc = y })++data CollectError+ = FetchException (Either HttpException Text)+ | WriteException Text+ | CollectException Text+ | YamlParseException ParseException+ deriving (Typeable)++instance Exception CollectError++instance Show CollectError where+ show = \case+ FetchException (Left e) -> "fetch phase error: " <> show e+ FetchException (Right t) -> "fetch phase error: " <> T.unpack t+ WriteException t -> "write phase error: " <> T.unpack t+ CollectException t -> "error (no phase): " <> T.unpack t+ YamlParseException e -> "reading yaml error: " <> show e++collect :: MonadUnliftIO m => Collecter a -> m a+collect f = do+ opt <- logOptionsHandle stdout False+ withLogFunc opt $ \logFunc -> runRIO Env{..} f
+ src/ScrapBook/Data/Config.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module ScrapBook.Data.Config where++import RIO+import qualified RIO.Text as T++import Data.Extensible+import Data.Yaml+import ScrapBook.Data.Site+import ScrapBook.Internal.Utils (embedM)++type Config = Record+ '[ "feed" >: Maybe FeedConfig+ , "json" >: Maybe Text -- ^ output file name+ , "sites" >: [SiteConfig]+ ]++type HasWriteConfigFields xs =+ ( Lookup xs "feed" (Maybe FeedConfig)+ , Lookup xs "json" (Maybe Text)+ )++type FeedConfig = Record+ '[ "title" >: Text+ , "baseUrl" >: Text+ , "name" >: Maybe Text -- ^ output file name+ ]++type SiteConfig = Record+ '[ "title" >: Text+ , "author" >: Text+ , "url" >: Text+ , "feed" >: Maybe Text+ , "atom" >: Maybe AtomConfig+ , "rss" >: Maybe Text+ ]++readConfig :: FilePath -> IO (Maybe Config)+readConfig = fmap (either (const Nothing) pure) . decodeFileEither++toSite :: SiteConfig -> Site+toSite conf+ = #title @= (conf ^. #title)+ <: #author @= (conf ^. #author)+ <: #url @= (conf ^. #url)+ <: #id @= toSiteId conf+ <: nil++toSiteId :: SiteConfig -> SiteId+toSiteId conf = fromMaybe (embed $ #url @= conf ^. #url)+ $ embedM (#atom <@=> conf ^. #atom)+ <|> embedM (#rss <@=> conf ^. #rss)+ <|> embedM (#feed <@=> conf ^. #feed)++feedName :: FeedConfig -> FilePath+feedName conf = maybe "atom.xml" T.unpack (conf ^. #name)
+ src/ScrapBook/Data/Format.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++module ScrapBook.Data.Format+ ( Format+ , optFormat+ ) where++import RIO++import Data.Extensible+import ScrapBook.Internal.Utils (valid)++type Format = Variant FormatFields++type FormatFields =+ '[ "feed" >: ()+ , "json" >: ()+ ]++optFormat :: [String] -> Format+optFormat args = fromMaybe feed' (gen Nothing)+ where+ gen = henumerateFor+ (Proxy :: Proxy (KeyTargetAre KnownSymbol Monoid))+ (Proxy :: Proxy FormatFields)+ $ \m r ->+ let key = stringKeyOf m in+ let val = EmbedAt m $ Field (pure mempty) in+ r <|> (fmap (const val) . valid (key ==) =<< listToMaybe args)++feed' :: Format+feed' = embedAssoc $ #feed @= ()
+ src/ScrapBook/Data/Site.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module ScrapBook.Data.Site+ ( Site+ , SiteFields+ , IsSiteFields+ , SiteId+ , AtomConfig+ , toAtomConfig+ , Post+ , Date+ , Url+ , toAbsoluteUrl+ , Summary (..)+ , summaryToText+ ) where++import RIO+import qualified RIO.Text as T++import Data.Aeson (ToJSON (..))+import qualified Data.Aeson as JSON+import Data.Extensible+import ScrapBook.Internal.Instances (kvToJSON)+import ScrapBook.Internal.Utils (toHost)+import Text.Atom.Feed (Date)++type Site = Record SiteFields++type SiteFields =+ '[ "title" >: Text+ , "author" >: Text+ , "url" >: Url+ , "id" >: SiteId+ ]++type IsSiteFields xs =+ ( Forall (KeyTargetAre KnownSymbol (Instance1 ToJSON Identity)) xs+ , Lookup xs "title" Text+ , Lookup xs "author" Text+ , Lookup xs "url" Url+ , Lookup xs "id" SiteId+ )++type SiteId = Variant+ '[ "feed" >: Text+ , "atom" >: AtomConfig+ , "rss" >: Text -- ^ RSS 2.0+ , "url" >: Url+ ]++type AtomConfig = Record+ '[ "url" >: Text+ , "linkAttrs" >: Maybe (Map Text Text)+ ]++toAtomConfig :: Url -> AtomConfig+toAtomConfig url = mempty & #url `set` url++type Post s = Record+ '[ "title" >: Text+ , "url" >: Url+ , "date" >: Date+ , "summary" >: Maybe Summary+ , "site" >: s+ ]++type Url = Text++data Summary+ = TextSummary Text+ | HtmlSummary Text+ deriving (Show, Eq)++instance ToJSON Summary where+ toJSON (TextSummary txt) = JSON.Object $ kvToJSON "text" txt+ toJSON (HtmlSummary txt) = JSON.Object $ kvToJSON "html" txt++summaryToText :: Summary -> Text+summaryToText (TextSummary txt) = txt+summaryToText (HtmlSummary txt) = txt++-- |+-- if url have prefix `/`, append base url+toAbsoluteUrl :: IsSiteFields xs => Record xs -> Url -> Url+toAbsoluteUrl site url =+ case T.uncons url of+ Just ('/', _) -> toHost (site ^. #url) `mappend` url+ _ -> url
+ src/ScrapBook/Feed.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ScrapBook.Feed+ ( writeFeed+ ) where++import RIO+import RIO.FilePath+import qualified RIO.Text as T+import qualified RIO.Text.Lazy as T.Lazy++import Data.Extensible+import ScrapBook.Collecter+import ScrapBook.Data.Config+import ScrapBook.Data.Site+import ScrapBook.Feed.Atom+import ScrapBook.Feed.RSS (fromRSSFeed)+import ScrapBook.Fetch.Internal (Fetch (..), fetchHtml,+ throwFetchError)+import ScrapBook.Write.Internal (Write (..), throwWriteError)+import Text.Feed.Import (parseFeedString)+import Text.Feed.Types (Feed (..))+import qualified Text.XML as XML++instance Fetch ("feed" >: Text) where+ fetchFrom _ site url = do+ resp <- T.unpack <$> fetchHtml url+ case parseFeedString resp of+ Just (AtomFeed feed) -> pure $ fromAtomFeed site (toAtomConfig url) feed+ Just (RSSFeed feed) -> pure $ fromRSSFeed site feed+ _ -> throwFetchError (Right "can't parse feed.")++instance Write ("feed" >: ()) where+ writeTo _ conf posts = do+ conf' <-+ maybe (throwWriteError "add feed config on yaml.") pure $ conf ^. #feed+ case toDocument (toAtomFeed conf' posts) of+ Left err -> throwWriteError $ mconcat (toList err)+ Right docs -> pure $ T.Lazy.toStrict (XML.renderText XML.def docs)+ fileName' _ conf = feedName $ fromMaybe mempty (conf ^. #feed)+ updateFileName' _ path conf =+ conf & #feed `over` fmap (over #name $ maybe (pure $ T.pack name) pure)+ where+ name = replaceExtension (takeFileName path) "xml"++writeFeed :: IsSiteFields xs =>+ FilePath -> FeedConfig -> [Post (Record xs)] -> Collecter ()+writeFeed dir conf posts =+ case toDocument (toAtomFeed conf posts) of+ Left err -> throwWriteError $ mconcat (toList err)+ Right docs -> liftIO $ XML.writeFile XML.def path docs+ where+ path = mconcat [dir, "/", feedName conf]
+ src/ScrapBook/Feed/Atom.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ScrapBook.Feed.Atom+ ( fromAtomFeed+ , toAtomFeed+ , toEntry+ , fromEntry+ , toDocument+ ) where++import qualified Data.List as L+import RIO+import qualified RIO.Map as M+import qualified RIO.Text as T++import Data.Extensible+import qualified Data.Ord as Ord+import qualified Data.XML.Types as XML (Content (..))+import ScrapBook.Data.Config+import ScrapBook.Data.Site+import qualified ScrapBook.Feed.Atom.Internal as My+import ScrapBook.Fetch.Internal (Fetch (..), fetchHtml,+ throwFetchError)+import qualified Text.Atom.Feed as Atom+import Text.Feed.Import (parseFeedString)+import Text.Feed.Types (Feed (..))+import qualified Text.XML as XML++instance Fetch ("atom" >: AtomConfig) where+ fetchFrom _ site conf = do+ resp <- T.unpack <$> fetchHtml (conf ^. #url)+ case parseFeedString resp of+ Just (AtomFeed feed) -> pure $ fromAtomFeed site conf feed+ _ -> throwFetchError (Right "can't parse atom feed.")++fromAtomFeed ::+ IsSiteFields xs => Record xs -> AtomConfig -> Atom.Feed -> [Post (Record xs)]+fromAtomFeed site conf feed = fromEntry site conf <$> Atom.feedEntries feed++toAtomFeed :: IsSiteFields xs => FeedConfig -> [Post (Record xs)] -> Atom.Feed+toAtomFeed conf posts =+ (Atom.nullFeed+ (mconcat [conf ^. #baseUrl, "/", T.pack $ feedName conf])+ (Atom.TextString $ conf ^. #title)+ (maybe "" (view #date) $ listToMaybe posts'))+ { Atom.feedEntries = map toEntry posts'+ , Atom.feedLinks = [Atom.nullLink $ conf ^. #baseUrl]+ }+ where+ posts' = L.sortOn (Ord.Down . view #date) posts++toEntry :: IsSiteFields xs => Post (Record xs) -> Atom.Entry+toEntry post =+ (Atom.nullEntry+ (post ^. #url) (Atom.TextString $ post ^. #title) (post ^. #date))+ { Atom.entryAuthors =+ [ Atom.nullPerson { Atom.personName = post ^. #site ^. #author } ]+ , Atom.entryLinks = [Atom.nullLink $ post ^. #url]+ , Atom.entrySummary = fmap fromSummary (post ^. #summary)+ }++fromEntry ::+ IsSiteFields xs => Record xs -> AtomConfig -> Atom.Entry -> Post (Record xs)+fromEntry site conf entry+ = #title @= txtToText (Atom.entryTitle entry)+ <: #url @= toUrl site conf entry+ <: #date @= Atom.entryUpdated entry+ <: #summary @= (toSummary =<< Atom.entrySummary entry)+ <: #site @= site+ <: nil++txtToText :: Atom.TextContent -> Text+txtToText = T.pack . Atom.txtToString++toDocument :: Atom.Feed -> Either (Set Text) XML.Document+toDocument feed = XML.fromXMLElement (My.xmlFeed feed)+ <&> \elm -> XML.Document (XML.Prologue [] Nothing []) elm []++toUrl :: IsSiteFields xs => Record xs -> AtomConfig -> Atom.Entry -> Text+toUrl site conf entry =+ maybe ""+ (toAbsoluteUrl site . Atom.linkHref )+ (listToMaybe . filter (p . Atom.linkAttrs) $ Atom.entryLinks entry)+ where+ p attrs = all (`elem` attrs) $+ toAttr <$> maybe [] M.toList (conf ^. #linkAttrs)++toAttr :: (Text, Text) -> Atom.Attr+toAttr (k, v) = (fromString $ T.unpack k, [XML.ContentText v])++toSummary :: Atom.TextContent -> Maybe Summary+toSummary (Atom.TextString txt) = Just $ TextSummary txt+toSummary (Atom.HTMLString txt) = Just $ HtmlSummary txt+toSummary _ = Nothing++fromSummary :: Summary -> Atom.TextContent+fromSummary (TextSummary txt) = Atom.TextString txt+fromSummary (HtmlSummary txt) = Atom.HTMLString txt
+ src/ScrapBook/Feed/Atom/Internal.hs view
@@ -0,0 +1,249 @@+---+-- |+-- Copy from: https://hackage.haskell.org/package/feed-1.0.0.0/docs/src/Text-Atom-Feed-Export.html+-- Custmize export XML+---+{-# LANGUAGE OverloadedStrings #-}++module ScrapBook.Feed.Atom.Internal+ ( xmlFeed+ ) where++import RIO hiding (Category)+import qualified RIO.Text as T++import Data.XML.Types as XML+import Text.Atom.Feed++xmlFeed :: Feed -> XML.Element+xmlFeed f = ( atomNode "feed"+ $ map NodeElement+ $ [xmlTitle (feedTitle f)]+ ++ [xmlId (feedId f)]+ ++ [xmlUpdated (feedUpdated f)]+ ++ map xmlLink (feedLinks f)+ ++ map xmlAuthor (feedAuthors f)+ ++ map xmlCategory (feedCategories f)+ ++ map xmlContributor (feedContributors f)+ ++ mb xmlGenerator (feedGenerator f)+ ++ mb xmlIcon (feedIcon f)+ ++ mb xmlLogo (feedLogo f)+ ++ mb xmlRights (feedRights f)+ ++ mb xmlSubtitle (feedSubtitle f)+ ++ map xmlEntry (feedEntries f)+ ++ feedOther f+ )+ { elementAttributes = [xmlnsAtom]+ }++---++atomPrefix :: Maybe Text+atomPrefix = Nothing -- Just "atom"++atomThrPrefix :: Maybe Text+atomThrPrefix = Just "thr"++atomNS :: Text+atomNS = "http://www.w3.org/2005/Atom"++atomThreadNS :: Text+atomThreadNS = "http://purl.org/syndication/thread/1.0"++blankElement :: Name -> [Node] -> XML.Element+blankElement name = XML.Element name []++xmlnsAtom :: Attr+xmlnsAtom = (qn, [ContentText atomNS])+ where+ qn = case atomPrefix of+ Nothing -> Name+ { nameLocalName = "xmlns"+ , nameNamespace = Nothing+ , namePrefix = Nothing+ }+ Just s -> Name+ { nameLocalName = s+ , nameNamespace = Nothing -- XXX: is this ok?+ , namePrefix = Just "xmlns"+ }++atomName :: Text -> Name+atomName nc =+ Name {nameLocalName = nc, nameNamespace = Nothing, namePrefix = atomPrefix}++atomAttr :: Text -> Text -> Attr+atomAttr x y = (atomName x, [ContentText y])++atomNode :: Text -> [Node] -> XML.Element+atomNode x = blankElement (atomName x)++atomLeaf :: Text -> Text -> XML.Element+atomLeaf tag txt = blankElement (atomName tag) [NodeContent $ ContentText txt]++atomThreadName :: Text -> Name+atomThreadName nc = Name+ { nameLocalName = nc+ , nameNamespace = Just atomThreadNS+ , namePrefix = atomThrPrefix+ }++atomThreadAttr :: Text -> Text -> Attr+atomThreadAttr x y = (atomThreadName x, [ContentText y])++atomThreadNode :: Text -> [Node] -> XML.Element+atomThreadNode x = blankElement (atomThreadName x)++atomThreadLeaf :: Text -> Text -> XML.Element+atomThreadLeaf tag txt =+ blankElement (atomThreadName tag) [NodeContent $ ContentText txt]++--------------------------------------------------------------------------------++xmlEntry :: Entry -> XML.Element+xmlEntry e = ( atomNode "entry"+ $ map NodeElement+ $ [xmlId (entryId e)]+ ++ [xmlTitle (entryTitle e)]+ ++ [xmlUpdated (entryUpdated e)]+ ++ map xmlAuthor (entryAuthors e)+ ++ map xmlCategory (entryCategories e)+ ++ mb xmlContent (entryContent e)+ ++ map xmlContributor (entryContributor e)+ ++ map xmlLink (entryLinks e)+ ++ mb xmlPublished (entryPublished e)+ ++ mb xmlRights (entryRights e)+ ++ mb xmlSource (entrySource e)+ ++ mb xmlSummary (entrySummary e)+ ++ mb xmlInReplyTo (entryInReplyTo e)+ ++ mb xmlInReplyTotal (entryInReplyTotal e)+ ++ entryOther e+ )+ { elementAttributes = entryAttrs e+ }++xmlContent :: EntryContent -> XML.Element+xmlContent cont = case cont of+ TextContent t ->+ (atomLeaf "content" t) { elementAttributes = [atomAttr "type" "text"] }+ HTMLContent t ->+ (atomLeaf "content" t) {elementAttributes = [atomAttr "type" "html"]}+ XHTMLContent x -> (atomNode "content" [NodeElement x])+ { elementAttributes = [atomAttr "type" "xhtml"]+ }+ MixedContent mbTy cs ->+ (atomNode "content" cs) { elementAttributes = mb (atomAttr "type") mbTy }+ ExternalContent mbTy src -> (atomNode "content" [])+ { elementAttributes = atomAttr "src" src : mb (atomAttr "type") mbTy+ }++xmlCategory :: Category -> XML.Element+xmlCategory c = (atomNode "category" (map NodeElement (catOther c)))+ { elementAttributes = [atomAttr "term" (catTerm c)]+ ++ mb (atomAttr "scheme") (catScheme c)+ ++ mb (atomAttr "label") (catLabel c)+ }++xmlLink :: Link -> XML.Element+xmlLink l = (atomNode "link" (map NodeElement (linkOther l)))+ { elementAttributes = [atomAttr "href" (linkHref l)]+ ++ mb (atomAttr "rel" . either id id) (linkRel l)+ ++ mb (atomAttr "type") (linkType l)+ ++ mb (atomAttr "hreflang") (linkHrefLang l)+ ++ mb (atomAttr "title") (linkTitle l)+ ++ mb (atomAttr "length") (linkLength l)+ ++ linkAttrs l+ }++xmlSource :: Source -> Element+xmlSource s =+ atomNode "source"+ $ map NodeElement+ $ sourceOther s+ ++ map xmlAuthor (sourceAuthors s)+ ++ map xmlCategory (sourceCategories s)+ ++ mb xmlGenerator (sourceGenerator s)+ ++ mb xmlIcon (sourceIcon s)+ ++ mb xmlId (sourceId s)+ ++ map xmlLink (sourceLinks s)+ ++ mb xmlLogo (sourceLogo s)+ ++ mb xmlRights (sourceRights s)+ ++ mb xmlSubtitle (sourceSubtitle s)+ ++ mb xmlTitle (sourceTitle s)+ ++ mb xmlUpdated (sourceUpdated s)++xmlGenerator :: Generator -> Element+xmlGenerator g = (atomLeaf "generator" (genText g))+ { elementAttributes = mb (atomAttr "uri") (genURI g)+ ++ mb (atomAttr "version") (genVersion g)+ }++xmlAuthor :: Person -> XML.Element+xmlAuthor p = atomNode "author" (xmlPerson p)++xmlContributor :: Person -> XML.Element+xmlContributor c = atomNode "contributor" (xmlPerson c)++xmlPerson :: Person -> [XML.Node]+xmlPerson p =+ map NodeElement+ $ [atomLeaf "name" (personName p)]+ ++ mb (atomLeaf "uri") (personURI p)+ ++ mb (atomLeaf "email") (personEmail p)+ ++ personOther p++xmlInReplyTo :: InReplyTo -> XML.Element+xmlInReplyTo irt = (atomThreadNode "in-reply-to" (replyToContent irt))+ { elementAttributes = mb (atomThreadAttr "ref") (Just $ replyToRef irt)+ ++ mb (atomThreadAttr "href") (replyToHRef irt)+ ++ mb (atomThreadAttr "type") (replyToType irt)+ ++ mb (atomThreadAttr "source") (replyToSource irt)+ ++ replyToOther irt+ }++xmlInReplyTotal :: InReplyTotal -> XML.Element+xmlInReplyTotal irt = (atomThreadLeaf "total" (T.pack $ show $ replyToTotal irt))+ { elementAttributes = replyToTotalOther irt+ }++xmlId :: Text -> XML.Element+xmlId = atomLeaf "id"++xmlIcon :: URI -> XML.Element+xmlIcon = atomLeaf "icon"++xmlLogo :: URI -> XML.Element+xmlLogo = atomLeaf "logo"++xmlUpdated :: Date -> XML.Element+xmlUpdated = atomLeaf "updated"++xmlPublished :: Date -> XML.Element+xmlPublished = atomLeaf "published"++xmlRights :: TextContent -> XML.Element+xmlRights = xmlTextContent "rights"++xmlTitle :: TextContent -> XML.Element+xmlTitle = xmlTextContent "title"++xmlSubtitle :: TextContent -> XML.Element+xmlSubtitle = xmlTextContent "subtitle"++xmlSummary :: TextContent -> XML.Element+xmlSummary = xmlTextContent "summary"++xmlTextContent :: Text -> TextContent -> XML.Element+xmlTextContent tg t = case t of+ TextString s ->+ (atomLeaf tg s) { elementAttributes = [atomAttr "type" "text"] }+ HTMLString s ->+ (atomLeaf tg s) { elementAttributes = [atomAttr "type" "html"] }+ XHTMLString e -> (atomNode tg [XML.NodeElement e])+ { elementAttributes = [atomAttr "type" "xhtml"]+ }++--------------------------------------------------------------------------------+mb :: (a -> b) -> Maybe a -> [b]+mb _ Nothing = []+mb f (Just x) = [f x]
+ src/ScrapBook/Feed/RSS.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ScrapBook.Feed.RSS+ ( fromRSSFeed+ , fromEntry+ ) where++import RIO+import qualified RIO.Text as T++import Data.Extensible+import ScrapBook.Data.Site+import ScrapBook.Fetch.Internal (Fetch (..), fetchHtml,+ throwFetchError)+import ScrapBook.Internal.Utils (formatTimeFromRFC822)+import Text.Feed.Import (parseFeedString)+import Text.Feed.Types (Feed (..))+import Text.RSS.Syntax (RSS, RSSItem)+import qualified Text.RSS.Syntax as RSS++instance Fetch ("rss" >: Text) where+ fetchFrom _ site feedUrl = do+ resp <- T.unpack <$> fetchHtml feedUrl+ case parseFeedString resp of+ Just (RSSFeed feed) -> pure $ fromRSSFeed site feed+ _ -> throwFetchError (Right "can't parse rss feed.")++fromRSSFeed :: IsSiteFields xs => Record xs -> RSS -> [Post (Record xs)]+fromRSSFeed site feed = fromEntry site <$> RSS.rssItems (RSS.rssChannel feed)++fromEntry :: IsSiteFields xs => Record xs -> RSSItem -> Post (Record xs)+fromEntry site entry+ = #title @= fromMaybe "" (RSS.rssItemTitle entry)+ <: #url @= toUrl site entry+ <: #date @= fromMaybe "" (formatTimeFromRFC822 =<< RSS.rssItemPubDate entry)+ <: #summary @= HtmlSummary <$> RSS.rssItemDescription entry+ <: #site @= site+ <: nil++toUrl :: IsSiteFields xs => Record xs -> RSSItem -> Text+toUrl site entry =+ maybe "" (toAbsoluteUrl site) (RSS.rssItemLink entry)
+ src/ScrapBook/Fetch.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ScrapBook.Fetch+ ( fetch+ , Fetch (..)+ ) where++import RIO++import Data.Extensible+import ScrapBook.Collecter+import ScrapBook.Data.Site+import ScrapBook.Feed ()+import ScrapBook.Fetch.Internal (Fetch (..))++fetch :: IsSiteFields xs => Record xs -> Collecter [Post (Record xs)]+fetch site = flip matchField (site ^. #id) $+ htabulateFor (Proxy :: Proxy Fetch) $+ \m -> Field (Match $ fetchFrom m site . runIdentity)++instance Fetch ("url" >: Text) where+ fetchFrom _ _ _ = throwM $ CollectException "undefined fetching behavior."
+ src/ScrapBook/Fetch/Internal.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++module ScrapBook.Fetch.Internal+ ( Fetch (..)+ , fetchHtml+ , throwFetchError+ ) where++import RIO++import Data.Extensible+import Network.HTTP.Req+import ScrapBook.Collecter+import ScrapBook.Data.Site (IsSiteFields, Post)+import qualified Text.URI as URI++class Fetch kv where+ fetchFrom :: IsSiteFields xs =>+ proxy kv -> Record xs -> TargetOf kv -> Collecter [Post (Record xs)]++fetchHtml :: Text -> Collecter Text+fetchHtml url = do+ result <- get' url bsResponse+ case result of+ Left err -> throwFetchError (Left err)+ Right resp ->+ either (throwFetchError . Right . tshow) pure $ decodeUtf8' (responseBody resp)++get' :: HttpResponse r => Text -> Proxy r -> Collecter (Either HttpException r)+get' url proxy = do+ uri <- URI.mkURI url+ case useURI uri of+ Just (Right (url', opts)) ->+ runReq' defaultHttpConfig (req GET url' NoReqBody proxy opts) <* sleep' 1000+ Just (Left (url', opts)) ->+ runReq' defaultHttpConfig (req GET url' NoReqBody proxy opts) <* sleep' 1000+ Nothing ->+ throwFetchError (Right $ "cannot parse url: " <> url)+ where+ sleep' :: Int -> Collecter ()+ sleep' n = logInfo (display $ "fethed: " <> url) *> threadDelay n+++runReq' :: (MonadIO m) => HttpConfig -> Req a -> m (Either HttpException a)+runReq' conf = liftIO . try . runReq conf++throwFetchError :: Either HttpException Text -> Collecter a+throwFetchError = throwM . FetchException
+ src/ScrapBook/Internal/Instances.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ScrapBook.Internal.Instances where++import RIO+import qualified RIO.HashMap as M.Hash++import Data.Aeson (ToJSON (..))+import qualified Data.Aeson as JSON+import Data.Extensible++instance Forall (KeyTargetAre KnownSymbol ToJSON) xs => ToJSON (Variant xs) where+ toJSON = matchField $+ htabulateFor (Proxy :: Proxy (KeyTargetAre KnownSymbol ToJSON)) $ \m ->+ Field (Match $ JSON.Object . kvToJSON (stringKeyOf m) . runIdentity)++kvToJSON :: ToJSON v => Text -> v -> JSON.Object+kvToJSON key val =+ M.Hash.fromList [("type", JSON.String key), ("value", toJSON val)]
+ src/ScrapBook/Internal/Utils.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-}++module ScrapBook.Internal.Utils where++import RIO+import qualified RIO.Text as T+import RIO.Time++import Data.Extensible++embedM :: (Functor f, x ∈ xs) => Comp f h x -> f (xs :/ h)+embedM = fmap embed . getComp++embedAssocM :: (Functor f, Lookup xs k a) => Comp f h (k >: a) -> f (xs :/ h)+embedAssocM = fmap embedAssoc . getComp++valid :: (a -> Bool) -> a -> Maybe a+valid p a = if p a then pure a else Nothing++toHost :: Text -> Text+toHost url = fromMaybe url+ $ mappend "https://" . T.takeWhile (/= '/') <$> T.stripPrefix "https://" url+ <|> mappend "http://" . T.takeWhile (/= '/') <$> T.stripPrefix "http://" url++formatTimeFromRFC822 :: Text -> Maybe Text+formatTimeFromRFC822 time = formatTimeToRFC3339 <$>+ parseTimeM True defaultTimeLocale rfc822DateFormat (T.unpack time)++formatTimeToRFC3339 :: UTCTime -> Text+formatTimeToRFC3339 =+ T.pack . formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%S%Ez")
+ src/ScrapBook/Json.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ScrapBook.Json+ (+ ) where++import RIO+import RIO.FilePath+import qualified RIO.Text as T++import Data.Aeson.Encode.Pretty (encodePretty)+import Data.Extensible+import ScrapBook.Write.Internal (Write (..), throwWriteError)++instance Write ("json" >: ()) where+ writeTo _ _conf =+ either (throwWriteError . tshow) pure . decodeUtf8' . toStrictBytes . encodePretty+ fileName' _ conf = maybe "posts.json" T.unpack $ conf ^. #json+ updateFileName' _ path conf =+ conf & #json `over` maybe (pure $ T.pack name) pure+ where+ name = replaceExtension (takeFileName path) "json"
+ src/ScrapBook/Write.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module ScrapBook.Write+ ( write+ , fileName+ , updateFileName+ , Write (..)+ ) where++import RIO++import Data.Extensible+import ScrapBook.Collecter (Collecter)+import ScrapBook.Data.Config (HasWriteConfigFields)+import ScrapBook.Data.Format (Format)+import ScrapBook.Data.Site (IsSiteFields, Post)+import ScrapBook.Feed ()+import ScrapBook.Json ()+import ScrapBook.Write.Internal (Write (..))++write :: (IsSiteFields xs, HasWriteConfigFields ys) =>+ Record ys -> Format -> [Post (Record xs)] -> Collecter Text+write conf fmt posts = flip matchField fmt $+ htabulateFor (Proxy :: Proxy Write) $+ \m -> Field (Match . pure $ writeTo m conf posts)++fileName :: HasWriteConfigFields xs => Record xs -> Format -> FilePath+fileName conf = matchField $+ htabulateFor (Proxy :: Proxy Write) $+ \m -> Field (Match . pure $ fileName' m conf)++updateFileName :: HasWriteConfigFields xs =>+ Format -> FilePath -> Record xs -> Record xs+updateFileName = matchField $+ htabulateFor (Proxy :: Proxy Write) $ Field . Match . pure . updateFileName'
+ src/ScrapBook/Write/Internal.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++module ScrapBook.Write.Internal+ ( Write (..)+ , throwWriteError+ ) where++import RIO++import Data.Extensible+import ScrapBook.Collecter (CollectError (..), Collecter)+import ScrapBook.Data.Config (HasWriteConfigFields)+import ScrapBook.Data.Site (IsSiteFields, Post)++class Write kv where+ writeTo ::+ (IsSiteFields xs, HasWriteConfigFields ys) =>+ proxy kv -> Record ys -> [Post (Record xs)] -> Collecter Text+ fileName' ::+ HasWriteConfigFields ys =>+ proxy kv -> Record ys -> FilePath+ updateFileName' ::+ HasWriteConfigFields ys =>+ proxy kv -> FilePath -> Record ys -> Record ys++throwWriteError :: Text -> Collecter a+throwWriteError = throwM . WriteException
+ test/Spec.hs view
@@ -0,0 +1,13 @@+module Main where++import RIO+import qualified Test.ScrapBook.Data.Site+import qualified Test.ScrapBook.Internal.Utils++import Test.Tasty++main :: IO ()+main = defaultMain $ testGroup "scrapbook-core package"+ [ Test.ScrapBook.Data.Site.tests+ , Test.ScrapBook.Internal.Utils.tests+ ]
+ test/Test/ScrapBook/Data/Site.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.ScrapBook.Data.Site where++import RIO++import Data.Extensible+import ScrapBook.Data.Site+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "ScrapBook.Data.Site"+ [ testGroup "toAbsoluteUrl" test_toAbsoluteUrl+ ]++site :: Site+site+ = #title @= "Hoge Site"+ <: #author @= "hoge"+ <: #url @= "https://example.com"+ <: #id @= embedAssoc (#feed @= "https://example.com/feed")+ <: nil++test_toAbsoluteUrl :: [TestTree]+test_toAbsoluteUrl =+ [ testCase "prefix is `/`" $+ toAbsoluteUrl site "/aaa/bbb.html" @?= "https://example.com/aaa/bbb.html"+ , testCase "prefix is not `/`" $+ toAbsoluteUrl site "https://example.com/aaa/bbb.html" @?= "https://example.com/aaa/bbb.html"+ , testCase "empty string" $+ toAbsoluteUrl site "" @?= ""+ ]
+ test/Test/ScrapBook/Internal/Utils.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.ScrapBook.Internal.Utils where++import RIO++import ScrapBook.Internal.Utils+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "ScrapBook.Internal.Utils"+ [ testGroup "valid" test_valid+ , testGroup "toHost" test_toHost+ , testGroup "formatTimeFromRFC822" test_formatTimeFromRFC822+ ]+++test_valid :: [TestTree]+test_valid =+ [ testCase "valid (const True)" $ valid (const True) 'a' @?= Just 'a'+ , testCase "valid (const False)" $ valid (const False) 'a' @?= Nothing+ ]++test_toHost :: [TestTree]+test_toHost =+ [ testCase "toHost use Http" $+ toHost "http://example.com/hoge/fuga" @?= "http://example.com"+ , testCase "toHost use Https" $+ toHost "https://example.com/hoge/fuga" @?= "https://example.com"+ , testCase "toHost: no host" $+ toHost "http://" @?= "http://"+ , testCase "toHost: no scheme" $+ toHost "abc" @?= "abc"+ ]++test_formatTimeFromRFC822 :: [TestTree]+test_formatTimeFromRFC822 =+ [ testCase "correct case" $+ formatTimeFromRFC822 "Tue, 06 Mar 2018 05:29:45 GMT" @?= Just "2018-03-06T05:29:45+00:00"+ , testCase "empty string" $+ formatTimeFromRFC822 "" @?= Nothing+ ]