diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,94 @@ +# scrapbook + +[![Hackage](https://img.shields.io/hackage/v/scrapbook.svg?style=flat)](https://hackage.haskell.org/package/scrapbook) +[![Build Status](https://travis-ci.org/matsubara0507/scrapbook.svg?branch=master)](https://travis-ci.org/matsubara0507/scrapbook) +[![](https://images.microbadger.com/badges/image/matsubara0507/scrapbook.svg)](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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/scrapbook.cabal b/scrapbook.cabal new file mode 100644 --- /dev/null +++ b/scrapbook.cabal @@ -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 +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 diff --git a/src/ScrapBook.hs b/src/ScrapBook.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook.hs @@ -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 diff --git a/src/ScrapBook/Cmd.hs b/src/ScrapBook/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Cmd.hs @@ -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 diff --git a/src/ScrapBook/Cmd/Options.hs b/src/ScrapBook/Cmd/Options.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Cmd/Options.hs @@ -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" diff --git a/src/ScrapBook/Cmd/Run.hs b/src/ScrapBook/Cmd/Run.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Cmd/Run.hs @@ -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 diff --git a/src/ScrapBook/Collecter.hs b/src/ScrapBook/Collecter.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Collecter.hs @@ -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 diff --git a/src/ScrapBook/Data/Config.hs b/src/ScrapBook/Data/Config.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Data/Config.hs @@ -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) diff --git a/src/ScrapBook/Data/Format.hs b/src/ScrapBook/Data/Format.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Data/Format.hs @@ -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 @= () diff --git a/src/ScrapBook/Data/Site.hs b/src/ScrapBook/Data/Site.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Data/Site.hs @@ -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 diff --git a/src/ScrapBook/Feed.hs b/src/ScrapBook/Feed.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Feed.hs @@ -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] diff --git a/src/ScrapBook/Feed/Atom.hs b/src/ScrapBook/Feed/Atom.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Feed/Atom.hs @@ -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 diff --git a/src/ScrapBook/Feed/Atom/Internal.hs b/src/ScrapBook/Feed/Atom/Internal.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Feed/Atom/Internal.hs @@ -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] diff --git a/src/ScrapBook/Feed/RSS.hs b/src/ScrapBook/Feed/RSS.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Feed/RSS.hs @@ -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) diff --git a/src/ScrapBook/Fetch.hs b/src/ScrapBook/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Fetch.hs @@ -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." diff --git a/src/ScrapBook/Fetch/Internal.hs b/src/ScrapBook/Fetch/Internal.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Fetch/Internal.hs @@ -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 diff --git a/src/ScrapBook/Internal/Instances.hs b/src/ScrapBook/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Internal/Instances.hs @@ -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)] diff --git a/src/ScrapBook/Internal/Utils.hs b/src/ScrapBook/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Internal/Utils.hs @@ -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") diff --git a/src/ScrapBook/Json.hs b/src/ScrapBook/Json.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Json.hs @@ -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" diff --git a/src/ScrapBook/Write.hs b/src/ScrapBook/Write.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Write.hs @@ -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' diff --git a/src/ScrapBook/Write/Internal.hs b/src/ScrapBook/Write/Internal.hs new file mode 100644 --- /dev/null +++ b/src/ScrapBook/Write/Internal.hs @@ -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 diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/Test/ScrapBook/Cmd.hs b/test/Test/ScrapBook/Cmd.hs new file mode 100644 --- /dev/null +++ b/test/Test/ScrapBook/Cmd.hs @@ -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 diff --git a/test/Test/ScrapBook/Data/Site.hs b/test/Test/ScrapBook/Data/Site.hs new file mode 100644 --- /dev/null +++ b/test/Test/ScrapBook/Data/Site.hs @@ -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 "" @?= "" + ] diff --git a/test/Test/ScrapBook/Internal/Utils.hs b/test/Test/ScrapBook/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Test/ScrapBook/Internal/Utils.hs @@ -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 + ]