scrapbook (empty) → 0.3.2
raw patch · 29 files changed
+1554/−0 lines, 29 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, data-default, drinkery, extensible, feed, gitrev, req, rio, scrapbook, tasty, tasty-hunit, xml-conduit, xml-types, yaml
Files
- CHANGELOG.md +40/−0
- LICENSE +21/−0
- README.md +94/−0
- Setup.hs +2/−0
- app/Main.hs +83/−0
- scrapbook.cabal +139/−0
- src/ScrapBook.hs +10/−0
- src/ScrapBook/Cmd.hs +22/−0
- src/ScrapBook/Cmd/Options.hs +31/−0
- src/ScrapBook/Cmd/Run.hs +29/−0
- src/ScrapBook/Collecter.hs +40/−0
- src/ScrapBook/Data/Config.hs +62/−0
- src/ScrapBook/Data/Format.hs +38/−0
- src/ScrapBook/Data/Site.hs +97/−0
- src/ScrapBook/Feed.hs +63/−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 +31/−0
- src/ScrapBook/Fetch/Internal.hs +55/−0
- src/ScrapBook/Internal/Instances.hs +27/−0
- src/ScrapBook/Internal/Utils.hs +35/−0
- src/ScrapBook/Json.hs +26/−0
- src/ScrapBook/Write.hs +41/−0
- src/ScrapBook/Write/Internal.hs +29/−0
- test/Driver.hs +1/−0
- test/Test/ScrapBook/Cmd.hs +69/−0
- test/Test/ScrapBook/Data/Site.hs +29/−0
- test/Test/ScrapBook/Internal/Utils.hs +35/−0
+ CHANGELOG.md view
@@ -0,0 +1,40 @@+# Changelog for scrapbook++## Unreleased changes++### 0.3.2++- Misc: remove deps lib+ - extensible-instances+ - data-default-instances-text+- Misc: update extensible to 0.5++### 0.3.1++- Refactor: update resolver to lts-12.26+- Misc: support docker image+- Misc: add TravisCI++## 0.3.0++- Refactor: update resolver to lts-12++## 0.2.0++- Feat: version option+- Feat: RSS 2.0+- Fix: remove namespace in xml tag+- Feat: summary+- Feat: mltiple input files+- Fix: occur error when write file on no exist directory+- Feat: default output file name is input file name+- Fix: help message+- Feat: add json output format+- Feat: add config to filter links with attr on Atom feed+- Refactor: use `rio` library+- Refactor: change several functions to polymorphic with `extensible`+- Fix: don't exit whole program when raise fetch exception++## Alpha++- alpha release
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 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,94 @@+# scrapbook++[](https://hackage.haskell.org/package/scrapbook)+[](https://travis-ci.org/matsubara0507/scrapbook)+[](https://microbadger.com/images/matsubara0507/scrapbook "Get your own image badge on microbadger.com")++This is cli tool that collect posts of site that is wrote in config yaml using feed or scraping.++## Usage++1. clone this repository or add `scrapbook` package to `extra-deps` in `stack.yaml`+2. run `stack install`++e.g.++```+$ stack exec -- scrapbook -o "example" example/sites.yaml+```++### Docker++```+$ docker run --rm -v `pwd`:/work matsubara0507/scrapbook bin/bash -c "cd work && scrapbook -o 'example' example/sites.yaml"+```++### Command++```+scrapbook [options] [input-file]+ -o DIR --output=DIR Write output to DIR instead of stdout.+ -t FORMAT, -w FORMAT --to=FORMAT, --write=FORMAT Specify output format. default is `feed`.+ --version Show version+```++### GHCi++```haskell+>> import Control.Lens ((^.))+>> import Data.Maybe+>> conf <- fromJust <$> readConfig "example/sites.yaml"+>> (Right posts) <- collect . fmap concat $ mapM (fetch . toSite) (conf ^. #sites)+>> collect $ writeFeed "example" (fromJust $ conf ^. #feed) posts+Right ()+```++## Example++see [matsuara0507/scrapbook-example](https://github.com/matsubara0507/scrapbook-example)++## Documentation++How to write config yaml file.++```yaml+# configuration for generating Atom feed (Optional)+feed:+ ## write as site title to Atom feed+ title: "Sample Site Posts"+ ## write as site url to Atom feed+ baseUrl: "https://example.com"+ ## file name (Optional)+ ### if nothing, use same name from input file+ name: atom.xml++# Haskeller's site configuration+sites:+ ## Title of site+ - title: "ひげメモ"+ ## Author of site+ author: matsubara0507+ ## URL of site+ url: https://matsubara0507.github.io+ ## Feed url of site+ ### there are several field to set feed url+ ### `feed` is basic field. This field auto branch to Atom or RSS 2.0.+ feed: https://matsubara0507.github.io/feed+ - title: "Kuro's Blog"+ author: "Hiroyuki Kurokawa"+ url: http://kurokawh.blogspot.com/+ ### `atom` is for Atom feed. + atom:+ ### feed url of Atom+ url: http://kurokawh.blogspot.com/feeds/posts/default+ ### set attr as constraint for link on each entry of Atom feed (Optional)+ ### if nothing, choice head. if set multiple attr, conjunction.+ linkAttrs:+ rel: alternate+ - title: "あどけない話"+ author: "kazu-yamamoto"+ url: http://d.hatena.ne.jp/kazu-yamamoto+ ### `rss` is for RSS 2.0 feed.+ ### set feed url.+ rss: http://d.hatena.ne.jp/kazu-yamamoto/rss2+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Paths_scrapbook (version)+import RIO+import qualified RIO.ByteString as B+import RIO.Directory+import RIO.FilePath++import Data.Drinkery+import Data.Extensible+import Data.Extensible.GetOpt+import Data.Version (Version)+import qualified Data.Version as Version+import Data.Yaml (ParseException, decodeEither',+ decodeFileEither)+import Development.GitRev+import ScrapBook+import ScrapBook.Cmd++main :: IO ()+main = withGetOpt "[options] [input-file]" opts $ \r args ->+ case toCmd (#input @= args <: r) of+ RunScrapBook opts' -> runScrapBook opts'+ PrintVersion -> B.putStr $ fromString (showVersion version)+ where+ opts = #output @= outputOpt+ <: #write @= writeFormatOpt+ <: #version @= versionOpt+ <: nil++runScrapBook :: Options -> IO ()+runScrapBook opts = tapListT (readInputD opts) $&+ traverseFrom_ consume (fmap liftIO $ writeOutput' opts <=< run' (opts ^. #write))++readInput :: Options -> IO [Either ParseException Config]+readInput opts = sequence $+ case opts ^. #input of+ [] -> pure $ decodeEither' <$> B.getContents+ paths -> decodeFileEither' <$> paths+ where+ decodeFileEither' path =+ fmap (updateFileName (opts ^. #write) path) <$> decodeFileEither path++readInputD :: Options -> ListT () IO (Either ParseException Config)+readInputD = sample <=< liftIO . readInput++writeOutput :: Options -> Config -> Text -> IO ()+writeOutput opts conf txt =+ case opts ^. #output of+ Just dir -> writeFileWithDir (mconcat [dir, "/", name]) txt+ Nothing -> hPutBuilder stdin $ encodeUtf8Builder txt+ where+ name = fileName conf $ opts ^. #write++writeOutput' :: Options -> (Config, Text) -> IO ()+writeOutput' opts = handle terr . uncurry (writeOutput opts)++showVersion :: Version -> String+showVersion v = unwords+ [ "Version"+ , Version.showVersion v ++ ","+ , "Git revision"+ , $(gitHash)+ , "(" ++ $(gitCommitCount) ++ " commits)"+ ]++terr :: CollectError -> IO ()+terr err = hPutBuilder stderr $ encodeUtf8Builder (tshow err)++writeFileWithDir :: FilePath -> Text -> IO ()+writeFileWithDir path txt = do+ createDirectoryIfMissing True $ dropFileName path+ writeFileUtf8 path txt
+ scrapbook.cabal view
@@ -0,0 +1,139 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 6fed08fa82539fc53a52aa92d1228ba3edff9b7747cfc273df4eac5b42a860e8++name: scrapbook+version: 0.3.2+description: Please see the README on Github at <https://github.com/matsubara0507/scrapbook#readme>+homepage: https://github.com/matsubara0507/scrapbook#readme+bug-reports: https://github.com/matsubara0507/scrapbook/issues+author: MATSUBARA Nobutada+copyright: 2018 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+ 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+ , data-default+ , extensible+ , feed+ , req+ , rio+ , xml-conduit+ , xml-types+ , 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+ default-language: Haskell2010++executable scrapbook+ main-is: Main.hs+ 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+ build-depends:+ aeson+ , aeson-pretty+ , base >=4.7 && <5+ , data-default+ , drinkery+ , extensible+ , feed+ , gitrev+ , req+ , rio+ , scrapbook+ , xml-conduit+ , xml-types+ , yaml+ other-modules:+ Paths_scrapbook+ default-language: Haskell2010++test-suite scrapbook-test+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ 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+ build-depends:+ aeson+ , aeson-pretty+ , base >=4.7 && <5+ , data-default+ , extensible+ , feed+ , req+ , rio+ , scrapbook+ , 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 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/Cmd.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedLabels #-}++module ScrapBook.Cmd+ ( module X+ , Cmd (..)+ , toCmd+ ) where++import RIO++import ScrapBook.Cmd.Options as X+import ScrapBook.Cmd.Run as X++data Cmd+ = RunScrapBook Options+ | PrintVersion+ deriving (Show, Eq)++toCmd :: Options -> Cmd+toCmd opts+ | opts ^. #version = PrintVersion+ | otherwise = RunScrapBook opts
+ src/ScrapBook/Cmd/Options.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeOperators #-}++module ScrapBook.Cmd.Options where++import RIO++import Data.Extensible+import Data.Extensible.GetOpt+import ScrapBook.Data.Format++type Options = Record+ '[ "input" >: [FilePath]+ , "output" >: Maybe FilePath+ , "write" >: Format+ , "version" >: Bool+ ]++outputOpt :: OptDescr' (Maybe FilePath)+outputOpt =+ optionReqArg (pure . listToMaybe) ['o'] ["output"]+ "DIR" "Write output to DIR instead of stdout."++writeFormatOpt :: OptDescr' Format+writeFormatOpt =+ optionReqArg (pure . optFormat) ['t','w'] ["to","write"]+ "FORMAT" "Specify output format. default is `feed`."++versionOpt :: OptDescr' Bool+versionOpt = optFlag [] ["version"] "Show version"
+ src/ScrapBook/Cmd/Run.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeOperators #-}++module ScrapBook.Cmd.Run+ ( run+ , run'+ ) where++import RIO++import Data.Yaml (ParseException)+import ScrapBook++run :: MonadUnliftIO m => Format -> Config -> m Text+run fmt conf = do+ results <- forM (conf ^. #sites) $ \site ->+ collect (fetch $ toSite site) `catch` handler+ collect $ write conf fmt (concat results)+ where+ handler :: MonadUnliftIO m => CollectError -> m [Post Site]+ handler e = collect (logError $ displayShow e) >> pure []++run' :: (MonadUnliftIO m, MonadThrow m) =>+ Format -> Either ParseException Config -> m (Config, Text)+run' fmt = \case+ Left err -> throwM $ YamlParseException err+ Right conf -> (,) conf <$> run fmt conf
+ 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 =+ ( 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 view
@@ -0,0 +1,38 @@+{-# 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 view
@@ -0,0 +1,97 @@+{-# 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 view
@@ -0,0 +1,63 @@+{-# 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 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+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,31 @@+{-# 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 view
@@ -0,0 +1,55 @@+{-# 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 view
@@ -0,0 +1,27 @@+{-# 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 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 (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 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,41 @@+{-# 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 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/Driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ test/Test/ScrapBook/Cmd.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}++module Test.ScrapBook.Cmd where++import RIO++import Data.Extensible+import Data.Extensible.GetOpt+import ScrapBook.Cmd+import Test.Tasty+import Test.Tasty.HUnit++opts :: Options+opts+ = #input @= ["sites.yaml"]+ <: #output @= Just "example"+ <: #write @= embedAssoc (#feed @= ())+ <: #version @= False+ <: nil++getOptRecord' ::+ RecordOf (OptionDescr h) xs+ -> [String]+ -> Either [String] (RecordOf h xs, [String])+getOptRecord' r args = getOptRecord r args & \case+ (result, rs, [], _) -> Right (result, rs)+ (_, _, errs, _) -> Left errs++test_toCmd :: [TestTree]+test_toCmd =+ [ testCase "default optsion" $+ toCmd opts @?= RunScrapBook opts+ , testCase "#version field is True" $+ toCmd (opts & #version `set` True) @?= PrintVersion+ ]++test_optParser :: [TestTree]+test_optParser =+ [ testCase "correct case: basic" $+ getOptRecord' parser ["-o", "example", "sites.yaml"] @?=+ Right (shrink opts, ["sites.yaml"])+ , testCase "correct case: version" $+ getOptRecord' parser ["--version", "-o", "example", "sites.yaml"] @?=+ Right (shrink (opts & #version `set` True) , ["sites.yaml"])+ , testCase "correct case: no output" $+ getOptRecord' parser ["sites.yaml"] @?=+ Right (shrink (opts & #output `set` Nothing) , ["sites.yaml"])+ , testCase "correct case: no arguments" $+ getOptRecord' parser [] @?=+ Right (shrink (opts & #output `set` Nothing) , [])+ , testCase "correct case: feed format " $+ getOptRecord' parser ["-o", "example", "-t", "feed", "sites.yaml"] @?=+ Right (shrink opts , ["sites.yaml"])+ , testCase "correct case: json format " $+ getOptRecord' parser ["-o", "example", "-t", "json", "sites.yaml"] @?=+ Right (shrink (opts & #write `set` embedAssoc (#json @= ())) , ["sites.yaml"])+ , testCase "incorrect case: unkown ooption" $+ getOptRecord' parser ["-h", "-o", "example", "sites.yaml"] @?=+ Left ["unrecognized option `-h'\n"]+ ]+ where+ parser+ = #output @= outputOpt+ <: #write @= writeFormatOpt+ <: #version @= versionOpt+ <: nil
+ test/Test/ScrapBook/Data/Site.hs view
@@ -0,0 +1,29 @@+{-# 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 view
@@ -0,0 +1,35 @@+{-# 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+ ]