scrapbook 0.3.3 → 0.5.0
raw patch · 25 files changed
+80/−1109 lines, 25 filesdep +githashdep +scrapbook-coredep −aesondep −aeson-prettydep −data-defaultdep ~extensibledep ~rio
Dependencies added: githash, scrapbook-core
Dependencies removed: aeson, aeson-pretty, data-default, feed, gitrev, req, xml-conduit, xml-types
Dependency ranges changed: extensible, rio
Files
- CHANGELOG.md +19/−0
- README.md +9/−1
- app/Main.hs +7/−5
- scrapbook.cabal +28/−79
- src/ScrapBook.hs +0/−10
- src/ScrapBook/Collecter.hs +0/−40
- src/ScrapBook/Data/Config.hs +0/−62
- src/ScrapBook/Data/Format.hs +0/−38
- src/ScrapBook/Data/Site.hs +0/−97
- src/ScrapBook/Feed.hs +0/−63
- src/ScrapBook/Feed/Atom.hs +0/−106
- src/ScrapBook/Feed/Atom/Internal.hs +0/−249
- src/ScrapBook/Feed/RSS.hs +0/−50
- src/ScrapBook/Fetch.hs +0/−31
- src/ScrapBook/Fetch/Internal.hs +0/−55
- src/ScrapBook/Internal/Instances.hs +0/−27
- src/ScrapBook/Internal/Utils.hs +0/−35
- src/ScrapBook/Json.hs +0/−26
- src/ScrapBook/Write.hs +0/−41
- src/ScrapBook/Write/Internal.hs +0/−29
- test/Driver.hs +0/−1
- test/Spec.hs +11/−0
- test/Test/ScrapBook/Cmd.hs +6/−0
- test/Test/ScrapBook/Data/Site.hs +0/−29
- test/Test/ScrapBook/Internal/Utils.hs +0/−35
CHANGELOG.md view
@@ -2,6 +2,25 @@ ## 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++- Refactor: update resolver to lts-14.4+ - update extensible package to 0.6.1+ - update req package to 2.1.0+ - update feed package to 1.2.0+ - update rio package to 0.1.12+- Refactor: update config to build Docker image with stack v2+- Refactor: change deps package to githash from gitrev+- Refactor: remove deps package default-data+- Misc: divid to core package (scrapbook-core)+- Fix: mistake hPut stdin+ ### 0.3.3 - Misc: update package.yaml info for Hackage
README.md view
@@ -20,7 +20,15 @@ ### Docker ```-$ docker run --rm -v `pwd`:/work matsubara0507/scrapbook bin/bash -c "cd work && scrapbook -o 'example' example/sites.yaml"+$ docker run --rm -v `pwd`/example:/work matsubara0507/scrapbook scrapbook sites.yaml+```++build docker image:++```+$ stack --docker build -j 1 Cabal # if out of memory in docker+$ stack --docker --local-bin-path=./bin install+$ docker build -t matsubara0507/scrapbook . --build-arg local_bin_path=./bin ``` ### Command
app/Main.hs view
@@ -23,7 +23,7 @@ import qualified Data.Version as Version import Data.Yaml (ParseException, decodeEither', decodeFileEither)-import Development.GitRev+import qualified GitHash import ScrapBook import ScrapBook.Cmd @@ -31,7 +31,7 @@ main = withGetOpt "[options] [input-file]" opts $ \r args -> case toCmd (#input @= args <: r) of RunScrapBook opts' -> runScrapBook opts'- PrintVersion -> B.putStr $ fromString (showVersion version)+ PrintVersion -> B.putStr $ fromString (showVersion version) <> "\n" where opts = #output @= outputOpt <: #write @= writeFormatOpt@@ -58,7 +58,7 @@ writeOutput opts conf txt = case opts ^. #output of Just dir -> writeFileWithDir (mconcat [dir, "/", name]) txt- Nothing -> hPutBuilder stdin $ encodeUtf8Builder txt+ Nothing -> hPutBuilder stdout $ encodeUtf8Builder txt where name = fileName conf $ opts ^. #write @@ -70,9 +70,11 @@ [ "Version" , Version.showVersion v ++ "," , "Git revision"- , $(gitHash)- , "(" ++ $(gitCommitCount) ++ " commits)"+ , GitHash.giHash gi+ , "(" ++ show (GitHash.giCommitCount gi) ++ " commits)" ]+ where+ gi = $$(GitHash.tGitInfoCwd) terr :: CollectError -> IO () terr err = hPutBuilder stderr $ encodeUtf8Builder (tshow err)
scrapbook.cabal view
@@ -1,15 +1,15 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.0.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 28607306b149d9d63aa85130e8069e7639c838c93a7496b8bd1087a12e64eb4d+-- hash: c331e195d30d8a40a6dd4a3093627084e9d65e9d406494e57e06ef870301e959 name: scrapbook-version: 0.3.3-synopsis: Automatically derive Kotlin class to query servant webservices-description: Please see the README on Github at <https://github.com/matsubara0507/scrapbook#readme>+version: 0.5.0+synopsis: collect posts of site that is wrote in config yaml using feed or scraping+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@@ -33,38 +33,17 @@ 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- , data-default- , extensible- , feed- , req- , rio- , xml-conduit- , xml-types+ base >=4.7 && <5+ , extensible >=0.5+ , rio >=0.1.5+ , scrapbook-core >=0.5 , yaml exposed-modules:- ScrapBook ScrapBook.Cmd ScrapBook.Cmd.Options ScrapBook.Cmd.Run- 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+ Paths_scrapbook default-language: Haskell2010 executable scrapbook@@ -72,21 +51,15 @@ hs-source-dirs: app default-extensions: NoImplicitPrelude- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N+ 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- , data-default+ base >=4.7 && <5 , drinkery- , extensible- , feed- , gitrev- , req- , rio+ , extensible >=0.5+ , githash+ , rio >=0.1.5 , scrapbook- , xml-conduit- , xml-types+ , scrapbook-core >=0.5 , yaml other-modules: Paths_scrapbook@@ -94,49 +67,25 @@ test-suite scrapbook-test type: exitcode-stdio-1.0- main-is: Driver.hs+ main-is: Spec.hs+ other-modules:+ Test.ScrapBook.Cmd+ ScrapBook.Cmd+ ScrapBook.Cmd.Options+ ScrapBook.Cmd.Run+ Paths_scrapbook 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 -threaded -rtsopts -with-rtsopts=-N+ 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- , data-default- , extensible- , feed- , req- , rio+ base >=4.7 && <5+ , extensible >=0.5+ , rio >=0.1.5 , scrapbook+ , scrapbook-core >=0.5 , tasty , tasty-hunit- , xml-conduit- , xml-types , yaml- other-modules:- Test.ScrapBook.Cmd- Test.ScrapBook.Data.Site- Test.ScrapBook.Internal.Utils- ScrapBook- ScrapBook.Cmd- ScrapBook.Cmd.Options- ScrapBook.Cmd.Run- 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 default-language: Haskell2010
− src/ScrapBook.hs
@@ -1,10 +0,0 @@-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
@@ -1,40 +0,0 @@-{-# 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
@@ -1,62 +0,0 @@-{-# 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 =- ( Associate "feed" (Maybe FeedConfig) xs- , Associate "json" (Maybe Text) xs- )--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
@@ -1,38 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}--module ScrapBook.Data.Format- ( Format- , optFormat- ) where--import RIO--import Data.Default-import Data.Extensible-import Data.Proxy (Proxy (..))-import GHC.TypeLits-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 (KeyValue KnownSymbol Default))- (Proxy :: Proxy FormatFields)- $ \m r ->- let key = symbolVal $ proxyAssocKey m in- let val = EmbedAt m $ Field (pure def) in- r <|> (fmap (const val) . valid (key ==) =<< listToMaybe args)--feed' :: Format-feed' = embedAssoc $ #feed @= ()
− src/ScrapBook/Data/Site.hs
@@ -1,97 +0,0 @@-{-# 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 GHC.TypeLits (KnownSymbol)-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 (KeyValue KnownSymbol (Instance1 ToJSON Identity)) xs- , Associate "title" Text xs- , Associate "author" Text xs- , Associate "url" Url xs- , Associate "id" SiteId xs- )--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
@@ -1,63 +0,0 @@-{-# 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 Control.Monad.IO.Class (liftIO)-import Data.Default (def)-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 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 def path docs- where- path = mconcat [dir, "/", feedName conf]
− src/ScrapBook/Feed/Atom.hs
@@ -1,106 +0,0 @@-{-# 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
@@ -1,249 +0,0 @@------- |--- 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-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
@@ -1,50 +0,0 @@-{-# 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
@@ -1,31 +0,0 @@-{-# 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 Data.Proxy (Proxy (..))-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
@@ -1,55 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}--module ScrapBook.Fetch.Internal- ( Fetch (..)- , fetchHtml- , throwFetchError- ) where--import RIO--import Data.Default (def)-import Data.Extensible-import Data.Proxy (Proxy (..))-import Network.HTTP.Req-import ScrapBook.Collecter-import ScrapBook.Data.Site (IsSiteFields, Post)--class Fetch kv where- fetchFrom :: IsSiteFields xs =>- proxy kv -> Record xs -> AssocValue 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 =- case parseUrlHttp (encodeUtf8 url) of- Just (url', opts) ->- runReq' def (req GET url' NoReqBody proxy opts) <* sleep' 1000- Nothing ->- case parseUrlHttps (encodeUtf8 url) of- Just (url', opts) ->- runReq' def (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
@@ -1,27 +0,0 @@-{-# 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 qualified RIO.Text as T--import Data.Aeson (ToJSON (..))-import qualified Data.Aeson as JSON-import Data.Extensible-import Data.Proxy (Proxy (..))-import GHC.TypeLits (KnownSymbol, symbolVal)--instance Forall (KeyValue KnownSymbol ToJSON) xs => ToJSON (Variant xs) where- toJSON = matchField $- htabulateFor (Proxy :: Proxy (KeyValue KnownSymbol ToJSON)) $ \m ->- let key = T.pack . symbolVal $ proxyAssocKey m- in Field (Match $ JSON.Object . kvToJSON key . 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
@@ -1,35 +0,0 @@-{-# 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 (h :| xs)-embedM = fmap embed . getComp--embedAssocM :: (Functor f, Associate k a xs) => Comp f h (k >: a) -> f (h :| xs)-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
@@ -1,26 +0,0 @@-{-# 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
@@ -1,41 +0,0 @@-{-# 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 Data.Proxy (Proxy (..))-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
@@ -1,29 +0,0 @@-{-# 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/Driver.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ test/Spec.hs view
@@ -0,0 +1,11 @@+module Main where++import RIO+import qualified Test.ScrapBook.Cmd++import Test.Tasty++main :: IO ()+main = defaultMain $ testGroup "scrapbook package"+ [ Test.ScrapBook.Cmd.tests+ ]
test/Test/ScrapBook/Cmd.hs view
@@ -13,6 +13,12 @@ import Test.Tasty import Test.Tasty.HUnit +tests :: TestTree+tests = testGroup "ScrapBook.Cmd"+ [ testGroup "toCmd" test_toCmd+ , testGroup "optParser" test_optParser+ ]+ opts :: Options opts = #input @= ["sites.yaml"]
− test/Test/ScrapBook/Data/Site.hs
@@ -1,29 +0,0 @@-{-# 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--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
@@ -1,35 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test.ScrapBook.Internal.Utils where--import RIO--import ScrapBook.Internal.Utils-import Test.Tasty-import Test.Tasty.HUnit--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:45Z"- , testCase "empty string" $- formatTimeFromRFC822 "" @?= Nothing- ]