diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,25 @@ ## Unreleased changes +## 0.5.0 + +- Refactor: update resolver to lts-16.9 + - update feed package to 1.3 + - update req package to 3.5.0 + +## 0.4.0 + +- Refactor: update resolver to lts-14.4 + - update extensible package to 0.6.1 + - update req package to 2.1.0 + - update feed package to 1.2.0 + - update rio package to 0.1.12 +- Refactor: update config to build Docker image with stack v2 +- Refactor: change deps package to githash from gitrev +- Refactor: remove deps package default-data +- Misc: divid to core package (scrapbook-core) +- Fix: mistake hPut stdin + ### 0.3.3 - Misc: update package.yaml info for Hackage diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,7 +20,15 @@ ### Docker ``` -$ docker run --rm -v `pwd`:/work matsubara0507/scrapbook bin/bash -c "cd work && scrapbook -o 'example' example/sites.yaml" +$ docker run --rm -v `pwd`/example:/work matsubara0507/scrapbook scrapbook sites.yaml +``` + +build docker image: + +``` +$ stack --docker build -j 1 Cabal # if out of memory in docker +$ stack --docker --local-bin-path=./bin install +$ docker build -t matsubara0507/scrapbook . --build-arg local_bin_path=./bin ``` ### Command diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -23,7 +23,7 @@ import qualified Data.Version as Version import Data.Yaml (ParseException, decodeEither', decodeFileEither) -import Development.GitRev +import qualified GitHash import ScrapBook import ScrapBook.Cmd @@ -31,7 +31,7 @@ main = withGetOpt "[options] [input-file]" opts $ \r args -> case toCmd (#input @= args <: r) of RunScrapBook opts' -> runScrapBook opts' - PrintVersion -> B.putStr $ fromString (showVersion version) + PrintVersion -> B.putStr $ fromString (showVersion version) <> "\n" where opts = #output @= outputOpt <: #write @= writeFormatOpt @@ -58,7 +58,7 @@ writeOutput opts conf txt = case opts ^. #output of Just dir -> writeFileWithDir (mconcat [dir, "/", name]) txt - Nothing -> hPutBuilder stdin $ encodeUtf8Builder txt + Nothing -> hPutBuilder stdout $ encodeUtf8Builder txt where name = fileName conf $ opts ^. #write @@ -70,9 +70,11 @@ [ "Version" , Version.showVersion v ++ "," , "Git revision" - , $(gitHash) - , "(" ++ $(gitCommitCount) ++ " commits)" + , GitHash.giHash gi + , "(" ++ show (GitHash.giCommitCount gi) ++ " commits)" ] + where + gi = $$(GitHash.tGitInfoCwd) terr :: CollectError -> IO () terr err = hPutBuilder stderr $ encodeUtf8Builder (tshow err) diff --git a/scrapbook.cabal b/scrapbook.cabal --- a/scrapbook.cabal +++ b/scrapbook.cabal @@ -1,15 +1,15 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.0. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 28607306b149d9d63aa85130e8069e7639c838c93a7496b8bd1087a12e64eb4d +-- hash: c331e195d30d8a40a6dd4a3093627084e9d65e9d406494e57e06ef870301e959 name: scrapbook -version: 0.3.3 -synopsis: Automatically derive Kotlin class to query servant webservices -description: Please see the README on Github at +version: 0.5.0 +synopsis: collect posts of site that is wrote in config yaml using feed or scraping +description: Please see the README on GitHub at category: Web homepage: https://github.com/matsubara0507/scrapbook#readme bug-reports: https://github.com/matsubara0507/scrapbook/issues @@ -33,38 +33,17 @@ default-extensions: NoImplicitPrelude ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -optP-Wno-nonportable-include-path build-depends: - aeson - , aeson-pretty - , base >=4.7 && <5 - , data-default - , extensible - , feed - , req - , rio - , xml-conduit - , xml-types + base >=4.7 && <5 + , extensible >=0.5 + , rio >=0.1.5 + , scrapbook-core >=0.5 , yaml exposed-modules: - ScrapBook ScrapBook.Cmd ScrapBook.Cmd.Options ScrapBook.Cmd.Run - ScrapBook.Collecter - ScrapBook.Data.Config - ScrapBook.Data.Format - ScrapBook.Data.Site - ScrapBook.Feed - ScrapBook.Feed.Atom - ScrapBook.Feed.RSS - ScrapBook.Fetch - ScrapBook.Json - ScrapBook.Write other-modules: - ScrapBook.Feed.Atom.Internal - ScrapBook.Fetch.Internal - ScrapBook.Internal.Utils - ScrapBook.Internal.Instances - ScrapBook.Write.Internal + Paths_scrapbook default-language: Haskell2010 executable scrapbook @@ -72,21 +51,15 @@ hs-source-dirs: app default-extensions: NoImplicitPrelude - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -optP-Wno-nonportable-include-path build-depends: - aeson - , aeson-pretty - , base >=4.7 && <5 - , data-default + base >=4.7 && <5 , drinkery - , extensible - , feed - , gitrev - , req - , rio + , extensible >=0.5 + , githash + , rio >=0.1.5 , scrapbook - , xml-conduit - , xml-types + , scrapbook-core >=0.5 , yaml other-modules: Paths_scrapbook @@ -94,49 +67,25 @@ test-suite scrapbook-test type: exitcode-stdio-1.0 - main-is: Driver.hs + main-is: Spec.hs + other-modules: + Test.ScrapBook.Cmd + ScrapBook.Cmd + ScrapBook.Cmd.Options + ScrapBook.Cmd.Run + Paths_scrapbook hs-source-dirs: test src default-extensions: NoImplicitPrelude - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -optP-Wno-nonportable-include-path build-depends: - aeson - , aeson-pretty - , base >=4.7 && <5 - , data-default - , extensible - , feed - , req - , rio + base >=4.7 && <5 + , extensible >=0.5 + , rio >=0.1.5 , scrapbook + , scrapbook-core >=0.5 , tasty , tasty-hunit - , xml-conduit - , xml-types , yaml - other-modules: - Test.ScrapBook.Cmd - Test.ScrapBook.Data.Site - Test.ScrapBook.Internal.Utils - ScrapBook - ScrapBook.Cmd - ScrapBook.Cmd.Options - ScrapBook.Cmd.Run - ScrapBook.Collecter - ScrapBook.Data.Config - ScrapBook.Data.Format - ScrapBook.Data.Site - ScrapBook.Feed - ScrapBook.Feed.Atom - ScrapBook.Feed.Atom.Internal - ScrapBook.Feed.RSS - ScrapBook.Fetch - ScrapBook.Fetch.Internal - ScrapBook.Internal.Instances - ScrapBook.Internal.Utils - ScrapBook.Json - ScrapBook.Write - ScrapBook.Write.Internal - Paths_scrapbook default-language: Haskell2010 diff --git a/src/ScrapBook.hs b/src/ScrapBook.hs deleted file mode 100644 --- a/src/ScrapBook.hs +++ /dev/null @@ -1,10 +0,0 @@ -module ScrapBook - ( module X - ) where - -import ScrapBook.Collecter as X -import ScrapBook.Data.Config as X -import ScrapBook.Data.Format as X -import ScrapBook.Data.Site as X -import ScrapBook.Fetch as X -import ScrapBook.Write as X diff --git a/src/ScrapBook/Collecter.hs b/src/ScrapBook/Collecter.hs deleted file mode 100644 --- a/src/ScrapBook/Collecter.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} - -module ScrapBook.Collecter where - -import RIO -import qualified RIO.Text as T - -import Data.Yaml (ParseException) -import Network.HTTP.Req (HttpException) - -type Collecter = RIO Env - -newtype Env = Env { logFunc :: LogFunc } - -instance HasLogFunc Env where - logFuncL = lens logFunc (\x y -> x { logFunc = y }) - -data CollectError - = FetchException (Either HttpException Text) - | WriteException Text - | CollectException Text - | YamlParseException ParseException - deriving (Typeable) - -instance Exception CollectError - -instance Show CollectError where - show = \case - FetchException (Left e) -> "fetch phase error: " <> show e - FetchException (Right t) -> "fetch phase error: " <> T.unpack t - WriteException t -> "write phase error: " <> T.unpack t - CollectException t -> "error (no phase): " <> T.unpack t - YamlParseException e -> "reading yaml error: " <> show e - -collect :: MonadUnliftIO m => Collecter a -> m a -collect f = do - opt <- logOptionsHandle stdout False - withLogFunc opt $ \logFunc -> runRIO Env{..} f diff --git a/src/ScrapBook/Data/Config.hs b/src/ScrapBook/Data/Config.hs deleted file mode 100644 --- a/src/ScrapBook/Data/Config.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module ScrapBook.Data.Config where - -import RIO -import qualified RIO.Text as T - -import Data.Extensible -import Data.Yaml -import ScrapBook.Data.Site -import ScrapBook.Internal.Utils (embedM) - -type Config = Record - '[ "feed" >: Maybe FeedConfig - , "json" >: Maybe Text -- ^ output file name - , "sites" >: [SiteConfig] - ] - -type HasWriteConfigFields xs = - ( Associate "feed" (Maybe FeedConfig) xs - , Associate "json" (Maybe Text) xs - ) - -type FeedConfig = Record - '[ "title" >: Text - , "baseUrl" >: Text - , "name" >: Maybe Text -- ^ output file name - ] - -type SiteConfig = Record - '[ "title" >: Text - , "author" >: Text - , "url" >: Text - , "feed" >: Maybe Text - , "atom" >: Maybe AtomConfig - , "rss" >: Maybe Text - ] - -readConfig :: FilePath -> IO (Maybe Config) -readConfig = fmap (either (const Nothing) pure) . decodeFileEither - -toSite :: SiteConfig -> Site -toSite conf - = #title @= (conf ^. #title) - <: #author @= (conf ^. #author) - <: #url @= (conf ^. #url) - <: #id @= toSiteId conf - <: nil - -toSiteId :: SiteConfig -> SiteId -toSiteId conf = fromMaybe (embed $ #url @= conf ^. #url) - $ embedM (#atom <@=> conf ^. #atom) - <|> embedM (#rss <@=> conf ^. #rss) - <|> embedM (#feed <@=> conf ^. #feed) - -feedName :: FeedConfig -> FilePath -feedName conf = maybe "atom.xml" T.unpack (conf ^. #name) diff --git a/src/ScrapBook/Data/Format.hs b/src/ScrapBook/Data/Format.hs deleted file mode 100644 --- a/src/ScrapBook/Data/Format.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} - -module ScrapBook.Data.Format - ( Format - , optFormat - ) where - -import RIO - -import Data.Default -import Data.Extensible -import Data.Proxy (Proxy (..)) -import GHC.TypeLits -import ScrapBook.Internal.Utils (valid) - -type Format = Variant FormatFields - -type FormatFields = - '[ "feed" >: () - , "json" >: () - ] - -optFormat :: [String] -> Format -optFormat args = fromMaybe feed' (gen Nothing) - where - gen = henumerateFor - (Proxy :: Proxy (KeyValue KnownSymbol Default)) - (Proxy :: Proxy FormatFields) - $ \m r -> - let key = symbolVal $ proxyAssocKey m in - let val = EmbedAt m $ Field (pure def) in - r <|> (fmap (const val) . valid (key ==) =<< listToMaybe args) - -feed' :: Format -feed' = embedAssoc $ #feed @= () diff --git a/src/ScrapBook/Data/Site.hs b/src/ScrapBook/Data/Site.hs deleted file mode 100644 --- a/src/ScrapBook/Data/Site.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module ScrapBook.Data.Site - ( Site - , SiteFields - , IsSiteFields - , SiteId - , AtomConfig - , toAtomConfig - , Post - , Date - , Url - , toAbsoluteUrl - , Summary (..) - , summaryToText - ) where - -import RIO -import qualified RIO.Text as T - -import Data.Aeson (ToJSON (..)) -import qualified Data.Aeson as JSON -import Data.Extensible -import GHC.TypeLits (KnownSymbol) -import ScrapBook.Internal.Instances (kvToJSON) -import ScrapBook.Internal.Utils (toHost) -import Text.Atom.Feed (Date) - -type Site = Record SiteFields - -type SiteFields = - '[ "title" >: Text - , "author" >: Text - , "url" >: Url - , "id" >: SiteId - ] - -type IsSiteFields xs = - ( Forall (KeyValue KnownSymbol (Instance1 ToJSON Identity)) xs - , Associate "title" Text xs - , Associate "author" Text xs - , Associate "url" Url xs - , Associate "id" SiteId xs - ) - -type SiteId = Variant - '[ "feed" >: Text - , "atom" >: AtomConfig - , "rss" >: Text -- ^ RSS 2.0 - , "url" >: Url - ] - -type AtomConfig = Record - '[ "url" >: Text - , "linkAttrs" >: Maybe (Map Text Text) - ] - -toAtomConfig :: Url -> AtomConfig -toAtomConfig url = mempty & #url `set` url - -type Post s = Record - '[ "title" >: Text - , "url" >: Url - , "date" >: Date - , "summary" >: Maybe Summary - , "site" >: s - ] - -type Url = Text - -data Summary - = TextSummary Text - | HtmlSummary Text - deriving (Show, Eq) - -instance ToJSON Summary where - toJSON (TextSummary txt) = JSON.Object $ kvToJSON "text" txt - toJSON (HtmlSummary txt) = JSON.Object $ kvToJSON "html" txt - -summaryToText :: Summary -> Text -summaryToText (TextSummary txt) = txt -summaryToText (HtmlSummary txt) = txt - --- | --- if url have prefix `/`, append base url -toAbsoluteUrl :: IsSiteFields xs => Record xs -> Url -> Url -toAbsoluteUrl site url = - case T.uncons url of - Just ('/', _) -> toHost (site ^. #url) `mappend` url - _ -> url diff --git a/src/ScrapBook/Feed.hs b/src/ScrapBook/Feed.hs deleted file mode 100644 --- a/src/ScrapBook/Feed.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module ScrapBook.Feed - ( writeFeed - ) where - -import RIO -import RIO.FilePath -import qualified RIO.Text as T -import qualified RIO.Text.Lazy as T.Lazy - -import Control.Monad.IO.Class (liftIO) -import Data.Default (def) -import Data.Extensible -import ScrapBook.Collecter -import ScrapBook.Data.Config -import ScrapBook.Data.Site -import ScrapBook.Feed.Atom -import ScrapBook.Feed.RSS (fromRSSFeed) -import ScrapBook.Fetch.Internal (Fetch (..), fetchHtml, - throwFetchError) -import ScrapBook.Write.Internal (Write (..), throwWriteError) -import Text.Feed.Import (parseFeedString) -import Text.Feed.Types (Feed (..)) -import qualified Text.XML as XML - -instance Fetch ("feed" >: Text) where - fetchFrom _ site url = do - resp <- T.unpack <$> fetchHtml url - case parseFeedString resp of - Just (AtomFeed feed) -> pure $ fromAtomFeed site (toAtomConfig url) feed - Just (RSSFeed feed) -> pure $ fromRSSFeed site feed - _ -> throwFetchError (Right "can't parse feed.") - -instance Write ("feed" >: ()) where - writeTo _ conf posts = do - conf' <- - maybe (throwWriteError "add feed config on yaml.") pure $ conf ^. #feed - case toDocument (toAtomFeed conf' posts) of - Left err -> throwWriteError $ mconcat (toList err) - Right docs -> pure $ T.Lazy.toStrict (XML.renderText def docs) - fileName' _ conf = feedName $ fromMaybe mempty (conf ^. #feed) - updateFileName' _ path conf = - conf & #feed `over` fmap (over #name $ maybe (pure $ T.pack name) pure) - where - name = replaceExtension (takeFileName path) "xml" - -writeFeed :: IsSiteFields xs => - FilePath -> FeedConfig -> [Post (Record xs)] -> Collecter () -writeFeed dir conf posts = - case toDocument (toAtomFeed conf posts) of - Left err -> throwWriteError $ mconcat (toList err) - Right docs -> liftIO $ XML.writeFile def path docs - where - path = mconcat [dir, "/", feedName conf] diff --git a/src/ScrapBook/Feed/Atom.hs b/src/ScrapBook/Feed/Atom.hs deleted file mode 100644 --- a/src/ScrapBook/Feed/Atom.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module ScrapBook.Feed.Atom - ( fromAtomFeed - , toAtomFeed - , toEntry - , fromEntry - , toDocument - ) where - -import qualified Data.List as L -import RIO -import qualified RIO.Map as M -import qualified RIO.Text as T - -import Data.Extensible -import qualified Data.Ord as Ord -import qualified Data.XML.Types as XML (Content (..)) -import ScrapBook.Data.Config -import ScrapBook.Data.Site -import qualified ScrapBook.Feed.Atom.Internal as My -import ScrapBook.Fetch.Internal (Fetch (..), fetchHtml, - throwFetchError) -import qualified Text.Atom.Feed as Atom -import Text.Feed.Import (parseFeedString) -import Text.Feed.Types (Feed (..)) -import qualified Text.XML as XML - -instance Fetch ("atom" >: AtomConfig) where - fetchFrom _ site conf = do - resp <- T.unpack <$> fetchHtml (conf ^. #url) - case parseFeedString resp of - Just (AtomFeed feed) -> pure $ fromAtomFeed site conf feed - _ -> throwFetchError (Right "can't parse atom feed.") - -fromAtomFeed :: - IsSiteFields xs => Record xs -> AtomConfig -> Atom.Feed -> [Post (Record xs)] -fromAtomFeed site conf feed = fromEntry site conf <$> Atom.feedEntries feed - -toAtomFeed :: IsSiteFields xs => FeedConfig -> [Post (Record xs)] -> Atom.Feed -toAtomFeed conf posts = - (Atom.nullFeed - (mconcat [conf ^. #baseUrl, "/", T.pack $ feedName conf]) - (Atom.TextString $ conf ^. #title) - (maybe "" (view #date) $ listToMaybe posts')) - { Atom.feedEntries = map toEntry posts' - , Atom.feedLinks = [Atom.nullLink $ conf ^. #baseUrl] - } - where - posts' = L.sortOn (Ord.Down . view #date) posts - -toEntry :: IsSiteFields xs => Post (Record xs) -> Atom.Entry -toEntry post = - (Atom.nullEntry - (post ^. #url) (Atom.TextString $ post ^. #title) (post ^. #date)) - { Atom.entryAuthors = - [ Atom.nullPerson { Atom.personName = post ^. #site ^. #author } ] - , Atom.entryLinks = [Atom.nullLink $ post ^. #url] - , Atom.entrySummary = fmap fromSummary (post ^. #summary) - } - -fromEntry :: - IsSiteFields xs => Record xs -> AtomConfig -> Atom.Entry -> Post (Record xs) -fromEntry site conf entry - = #title @= txtToText (Atom.entryTitle entry) - <: #url @= toUrl site conf entry - <: #date @= Atom.entryUpdated entry - <: #summary @= (toSummary =<< Atom.entrySummary entry) - <: #site @= site - <: nil - -txtToText :: Atom.TextContent -> Text -txtToText = T.pack . Atom.txtToString - -toDocument :: Atom.Feed -> Either (Set Text) XML.Document -toDocument feed = XML.fromXMLElement (My.xmlFeed feed) - <&> \elm -> XML.Document (XML.Prologue [] Nothing []) elm [] - -toUrl :: IsSiteFields xs => Record xs -> AtomConfig -> Atom.Entry -> Text -toUrl site conf entry = - maybe "" - (toAbsoluteUrl site . Atom.linkHref ) - (listToMaybe . filter (p . Atom.linkAttrs) $ Atom.entryLinks entry) - where - p attrs = all (`elem` attrs) $ - toAttr <$> maybe [] M.toList (conf ^. #linkAttrs) - -toAttr :: (Text, Text) -> Atom.Attr -toAttr (k, v) = (fromString $ T.unpack k, [XML.ContentText v]) - -toSummary :: Atom.TextContent -> Maybe Summary -toSummary (Atom.TextString txt) = Just $ TextSummary txt -toSummary (Atom.HTMLString txt) = Just $ HtmlSummary txt -toSummary _ = Nothing - -fromSummary :: Summary -> Atom.TextContent -fromSummary (TextSummary txt) = Atom.TextString txt -fromSummary (HtmlSummary txt) = Atom.HTMLString txt diff --git a/src/ScrapBook/Feed/Atom/Internal.hs b/src/ScrapBook/Feed/Atom/Internal.hs deleted file mode 100644 --- a/src/ScrapBook/Feed/Atom/Internal.hs +++ /dev/null @@ -1,249 +0,0 @@ ---- --- | --- Copy from: https://hackage.haskell.org/package/feed-1.0.0.0/docs/src/Text-Atom-Feed-Export.html --- Custmize export XML ---- -{-# LANGUAGE OverloadedStrings #-} - -module ScrapBook.Feed.Atom.Internal - ( xmlFeed - ) where - -import RIO -import qualified RIO.Text as T - -import Data.XML.Types as XML -import Text.Atom.Feed - -xmlFeed :: Feed -> XML.Element -xmlFeed f = ( atomNode "feed" - $ map NodeElement - $ [xmlTitle (feedTitle f)] - ++ [xmlId (feedId f)] - ++ [xmlUpdated (feedUpdated f)] - ++ map xmlLink (feedLinks f) - ++ map xmlAuthor (feedAuthors f) - ++ map xmlCategory (feedCategories f) - ++ map xmlContributor (feedContributors f) - ++ mb xmlGenerator (feedGenerator f) - ++ mb xmlIcon (feedIcon f) - ++ mb xmlLogo (feedLogo f) - ++ mb xmlRights (feedRights f) - ++ mb xmlSubtitle (feedSubtitle f) - ++ map xmlEntry (feedEntries f) - ++ feedOther f - ) - { elementAttributes = [xmlnsAtom] - } - ---- - -atomPrefix :: Maybe Text -atomPrefix = Nothing -- Just "atom" - -atomThrPrefix :: Maybe Text -atomThrPrefix = Just "thr" - -atomNS :: Text -atomNS = "http://www.w3.org/2005/Atom" - -atomThreadNS :: Text -atomThreadNS = "http://purl.org/syndication/thread/1.0" - -blankElement :: Name -> [Node] -> XML.Element -blankElement name = XML.Element name [] - -xmlnsAtom :: Attr -xmlnsAtom = (qn, [ContentText atomNS]) - where - qn = case atomPrefix of - Nothing -> Name - { nameLocalName = "xmlns" - , nameNamespace = Nothing - , namePrefix = Nothing - } - Just s -> Name - { nameLocalName = s - , nameNamespace = Nothing -- XXX: is this ok? - , namePrefix = Just "xmlns" - } - -atomName :: Text -> Name -atomName nc = - Name {nameLocalName = nc, nameNamespace = Nothing, namePrefix = atomPrefix} - -atomAttr :: Text -> Text -> Attr -atomAttr x y = (atomName x, [ContentText y]) - -atomNode :: Text -> [Node] -> XML.Element -atomNode x = blankElement (atomName x) - -atomLeaf :: Text -> Text -> XML.Element -atomLeaf tag txt = blankElement (atomName tag) [NodeContent $ ContentText txt] - -atomThreadName :: Text -> Name -atomThreadName nc = Name - { nameLocalName = nc - , nameNamespace = Just atomThreadNS - , namePrefix = atomThrPrefix - } - -atomThreadAttr :: Text -> Text -> Attr -atomThreadAttr x y = (atomThreadName x, [ContentText y]) - -atomThreadNode :: Text -> [Node] -> XML.Element -atomThreadNode x = blankElement (atomThreadName x) - -atomThreadLeaf :: Text -> Text -> XML.Element -atomThreadLeaf tag txt = - blankElement (atomThreadName tag) [NodeContent $ ContentText txt] - --------------------------------------------------------------------------------- - -xmlEntry :: Entry -> XML.Element -xmlEntry e = ( atomNode "entry" - $ map NodeElement - $ [xmlId (entryId e)] - ++ [xmlTitle (entryTitle e)] - ++ [xmlUpdated (entryUpdated e)] - ++ map xmlAuthor (entryAuthors e) - ++ map xmlCategory (entryCategories e) - ++ mb xmlContent (entryContent e) - ++ map xmlContributor (entryContributor e) - ++ map xmlLink (entryLinks e) - ++ mb xmlPublished (entryPublished e) - ++ mb xmlRights (entryRights e) - ++ mb xmlSource (entrySource e) - ++ mb xmlSummary (entrySummary e) - ++ mb xmlInReplyTo (entryInReplyTo e) - ++ mb xmlInReplyTotal (entryInReplyTotal e) - ++ entryOther e - ) - { elementAttributes = entryAttrs e - } - -xmlContent :: EntryContent -> XML.Element -xmlContent cont = case cont of - TextContent t -> - (atomLeaf "content" t) { elementAttributes = [atomAttr "type" "text"] } - HTMLContent t -> - (atomLeaf "content" t) { elementAttributes = [atomAttr "type" "html"] } - XHTMLContent x -> (atomNode "content" [NodeElement x]) - { elementAttributes = [atomAttr "type" "xhtml"] - } - MixedContent mbTy cs -> - (atomNode "content" cs) { elementAttributes = mb (atomAttr "type") mbTy } - ExternalContent mbTy src -> (atomNode "content" []) - { elementAttributes = atomAttr "src" src : mb (atomAttr "type") mbTy - } - -xmlCategory :: Category -> XML.Element -xmlCategory c = (atomNode "category" (map NodeElement (catOther c))) - { elementAttributes = [atomAttr "term" (catTerm c)] - ++ mb (atomAttr "scheme") (catScheme c) - ++ mb (atomAttr "label") (catLabel c) - } - -xmlLink :: Link -> XML.Element -xmlLink l = (atomNode "link" (map NodeElement (linkOther l))) - { elementAttributes = [atomAttr "href" (linkHref l)] - ++ mb (atomAttr "rel" . either id id) (linkRel l) - ++ mb (atomAttr "type") (linkType l) - ++ mb (atomAttr "hreflang") (linkHrefLang l) - ++ mb (atomAttr "title") (linkTitle l) - ++ mb (atomAttr "length") (linkLength l) - ++ linkAttrs l - } - -xmlSource :: Source -> Element -xmlSource s = - atomNode "source" - $ map NodeElement - $ sourceOther s - ++ map xmlAuthor (sourceAuthors s) - ++ map xmlCategory (sourceCategories s) - ++ mb xmlGenerator (sourceGenerator s) - ++ mb xmlIcon (sourceIcon s) - ++ mb xmlId (sourceId s) - ++ map xmlLink (sourceLinks s) - ++ mb xmlLogo (sourceLogo s) - ++ mb xmlRights (sourceRights s) - ++ mb xmlSubtitle (sourceSubtitle s) - ++ mb xmlTitle (sourceTitle s) - ++ mb xmlUpdated (sourceUpdated s) - -xmlGenerator :: Generator -> Element -xmlGenerator g = (atomLeaf "generator" (genText g)) - { elementAttributes = mb (atomAttr "uri") (genURI g) - ++ mb (atomAttr "version") (genVersion g) - } - -xmlAuthor :: Person -> XML.Element -xmlAuthor p = atomNode "author" (xmlPerson p) - -xmlContributor :: Person -> XML.Element -xmlContributor c = atomNode "contributor" (xmlPerson c) - -xmlPerson :: Person -> [XML.Node] -xmlPerson p = - map NodeElement - $ [atomLeaf "name" (personName p)] - ++ mb (atomLeaf "uri") (personURI p) - ++ mb (atomLeaf "email") (personEmail p) - ++ personOther p - -xmlInReplyTo :: InReplyTo -> XML.Element -xmlInReplyTo irt = (atomThreadNode "in-reply-to" (replyToContent irt)) - { elementAttributes = mb (atomThreadAttr "ref") (Just $ replyToRef irt) - ++ mb (atomThreadAttr "href") (replyToHRef irt) - ++ mb (atomThreadAttr "type") (replyToType irt) - ++ mb (atomThreadAttr "source") (replyToSource irt) - ++ replyToOther irt - } - -xmlInReplyTotal :: InReplyTotal -> XML.Element -xmlInReplyTotal irt = (atomThreadLeaf "total" (T.pack $ show $ replyToTotal irt)) - { elementAttributes = replyToTotalOther irt - } - -xmlId :: Text -> XML.Element -xmlId = atomLeaf "id" - -xmlIcon :: URI -> XML.Element -xmlIcon = atomLeaf "icon" - -xmlLogo :: URI -> XML.Element -xmlLogo = atomLeaf "logo" - -xmlUpdated :: Date -> XML.Element -xmlUpdated = atomLeaf "updated" - -xmlPublished :: Date -> XML.Element -xmlPublished = atomLeaf "published" - -xmlRights :: TextContent -> XML.Element -xmlRights = xmlTextContent "rights" - -xmlTitle :: TextContent -> XML.Element -xmlTitle = xmlTextContent "title" - -xmlSubtitle :: TextContent -> XML.Element -xmlSubtitle = xmlTextContent "subtitle" - -xmlSummary :: TextContent -> XML.Element -xmlSummary = xmlTextContent "summary" - -xmlTextContent :: Text -> TextContent -> XML.Element -xmlTextContent tg t = case t of - TextString s -> - (atomLeaf tg s) { elementAttributes = [atomAttr "type" "text"] } - HTMLString s -> - (atomLeaf tg s) { elementAttributes = [atomAttr "type" "html"] } - XHTMLString e -> (atomNode tg [XML.NodeElement e]) - { elementAttributes = [atomAttr "type" "xhtml"] - } - --------------------------------------------------------------------------------- -mb :: (a -> b) -> Maybe a -> [b] -mb _ Nothing = [] -mb f (Just x) = [f x] diff --git a/src/ScrapBook/Feed/RSS.hs b/src/ScrapBook/Feed/RSS.hs deleted file mode 100644 --- a/src/ScrapBook/Feed/RSS.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module ScrapBook.Feed.RSS - ( fromRSSFeed - , fromEntry - ) where - -import RIO -import qualified RIO.Text as T - -import Data.Extensible -import ScrapBook.Data.Site -import ScrapBook.Fetch.Internal (Fetch (..), fetchHtml, - throwFetchError) -import ScrapBook.Internal.Utils (formatTimeFromRFC822) -import Text.Feed.Import (parseFeedString) -import Text.Feed.Types (Feed (..)) -import Text.RSS.Syntax (RSS, RSSItem) -import qualified Text.RSS.Syntax as RSS - -instance Fetch ("rss" >: Text) where - fetchFrom _ site feedUrl = do - resp <- T.unpack <$> fetchHtml feedUrl - case parseFeedString resp of - Just (RSSFeed feed) -> pure $ fromRSSFeed site feed - _ -> throwFetchError (Right "can't parse rss feed.") - -fromRSSFeed :: IsSiteFields xs => Record xs -> RSS -> [Post (Record xs)] -fromRSSFeed site feed = fromEntry site <$> RSS.rssItems (RSS.rssChannel feed) - -fromEntry :: IsSiteFields xs => Record xs -> RSSItem -> Post (Record xs) -fromEntry site entry - = #title @= fromMaybe "" (RSS.rssItemTitle entry) - <: #url @= toUrl site entry - <: #date @= fromMaybe "" (formatTimeFromRFC822 =<< RSS.rssItemPubDate entry) - <: #summary @= HtmlSummary <$> RSS.rssItemDescription entry - <: #site @= site - <: nil - -toUrl :: IsSiteFields xs => Record xs -> RSSItem -> Text -toUrl site entry = - maybe "" (toAbsoluteUrl site) (RSS.rssItemLink entry) diff --git a/src/ScrapBook/Fetch.hs b/src/ScrapBook/Fetch.hs deleted file mode 100644 --- a/src/ScrapBook/Fetch.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module ScrapBook.Fetch - ( fetch - , Fetch (..) - ) where - -import RIO - -import Data.Extensible -import Data.Proxy (Proxy (..)) -import ScrapBook.Collecter -import ScrapBook.Data.Site -import ScrapBook.Feed () -import ScrapBook.Fetch.Internal (Fetch (..)) - -fetch :: IsSiteFields xs => Record xs -> Collecter [Post (Record xs)] -fetch site = flip matchField (site ^. #id) $ - htabulateFor (Proxy :: Proxy Fetch) $ - \m -> Field (Match $ fetchFrom m site . runIdentity) - -instance Fetch ("url" >: Text) where - fetchFrom _ _ _ = throwM $ CollectException "undefined fetching behavior." diff --git a/src/ScrapBook/Fetch/Internal.hs b/src/ScrapBook/Fetch/Internal.hs deleted file mode 100644 --- a/src/ScrapBook/Fetch/Internal.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} - -module ScrapBook.Fetch.Internal - ( Fetch (..) - , fetchHtml - , throwFetchError - ) where - -import RIO - -import Data.Default (def) -import Data.Extensible -import Data.Proxy (Proxy (..)) -import Network.HTTP.Req -import ScrapBook.Collecter -import ScrapBook.Data.Site (IsSiteFields, Post) - -class Fetch kv where - fetchFrom :: IsSiteFields xs => - proxy kv -> Record xs -> AssocValue kv -> Collecter [Post (Record xs)] - -fetchHtml :: Text -> Collecter Text -fetchHtml url = do - result <- get' url bsResponse - case result of - Left err -> throwFetchError (Left err) - Right resp -> - either (throwFetchError . Right . tshow) pure $ decodeUtf8' (responseBody resp) - -get' :: HttpResponse r => Text -> Proxy r -> Collecter (Either HttpException r) -get' url proxy = - case parseUrlHttp (encodeUtf8 url) of - Just (url', opts) -> - runReq' def (req GET url' NoReqBody proxy opts) <* sleep' 1000 - Nothing -> - case parseUrlHttps (encodeUtf8 url) of - Just (url', opts) -> - runReq' def (req GET url' NoReqBody proxy opts) <* sleep' 1000 - Nothing -> - throwFetchError (Right $ "cannot parse url: " <> url) - where - sleep' :: Int -> Collecter () - sleep' n = logInfo (display $ "fethed: " <> url) *> threadDelay n - - -runReq' :: (MonadIO m) => HttpConfig -> Req a -> m (Either HttpException a) -runReq' conf = liftIO . try . runReq conf - -throwFetchError :: Either HttpException Text -> Collecter a -throwFetchError = throwM . FetchException diff --git a/src/ScrapBook/Internal/Instances.hs b/src/ScrapBook/Internal/Instances.hs deleted file mode 100644 --- a/src/ScrapBook/Internal/Instances.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module ScrapBook.Internal.Instances where - -import RIO -import qualified RIO.HashMap as M.Hash -import qualified RIO.Text as T - -import Data.Aeson (ToJSON (..)) -import qualified Data.Aeson as JSON -import Data.Extensible -import Data.Proxy (Proxy (..)) -import GHC.TypeLits (KnownSymbol, symbolVal) - -instance Forall (KeyValue KnownSymbol ToJSON) xs => ToJSON (Variant xs) where - toJSON = matchField $ - htabulateFor (Proxy :: Proxy (KeyValue KnownSymbol ToJSON)) $ \m -> - let key = T.pack . symbolVal $ proxyAssocKey m - in Field (Match $ JSON.Object . kvToJSON key . runIdentity) - -kvToJSON :: ToJSON v => Text -> v -> JSON.Object -kvToJSON key val = - M.Hash.fromList [("type", JSON.String key), ("value", toJSON val)] diff --git a/src/ScrapBook/Internal/Utils.hs b/src/ScrapBook/Internal/Utils.hs deleted file mode 100644 --- a/src/ScrapBook/Internal/Utils.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-} - -module ScrapBook.Internal.Utils where - -import RIO -import qualified RIO.Text as T -import RIO.Time - -import Data.Extensible - -embedM :: (Functor f, x ∈ xs) => Comp f h x -> f (h :| xs) -embedM = fmap embed . getComp - -embedAssocM :: (Functor f, Associate k a xs) => Comp f h (k >: a) -> f (h :| xs) -embedAssocM = fmap embedAssoc . getComp - -valid :: (a -> Bool) -> a -> Maybe a -valid p a = if p a then pure a else Nothing - -toHost :: Text -> Text -toHost url = fromMaybe url - $ mappend "https://" . T.takeWhile (/= '/') <$> T.stripPrefix "https://" url - <|> mappend "http://" . T.takeWhile (/= '/') <$> T.stripPrefix "http://" url - -formatTimeFromRFC822 :: Text -> Maybe Text -formatTimeFromRFC822 time = formatTimeToRFC3339 <$> - parseTimeM True defaultTimeLocale rfc822DateFormat (T.unpack time) - -formatTimeToRFC3339 :: UTCTime -> Text -formatTimeToRFC3339 = - T.pack . formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%S%EZ") diff --git a/src/ScrapBook/Json.hs b/src/ScrapBook/Json.hs deleted file mode 100644 --- a/src/ScrapBook/Json.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module ScrapBook.Json - ( - ) where - -import RIO -import RIO.FilePath -import qualified RIO.Text as T - -import Data.Aeson.Encode.Pretty (encodePretty) -import Data.Extensible -import ScrapBook.Write.Internal (Write (..), throwWriteError) - -instance Write ("json" >: ()) where - writeTo _ _conf = - either (throwWriteError . tshow) pure . decodeUtf8' . toStrictBytes . encodePretty - fileName' _ conf = maybe "posts.json" T.unpack $ conf ^. #json - updateFileName' _ path conf = - conf & #json `over` maybe (pure $ T.pack name) pure - where - name = replaceExtension (takeFileName path) "json" diff --git a/src/ScrapBook/Write.hs b/src/ScrapBook/Write.hs deleted file mode 100644 --- a/src/ScrapBook/Write.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module ScrapBook.Write - ( write - , fileName - , updateFileName - , Write (..) - ) where - -import RIO - -import Data.Extensible -import Data.Proxy (Proxy (..)) -import ScrapBook.Collecter (Collecter) -import ScrapBook.Data.Config (HasWriteConfigFields) -import ScrapBook.Data.Format (Format) -import ScrapBook.Data.Site (IsSiteFields, Post) -import ScrapBook.Feed () -import ScrapBook.Json () -import ScrapBook.Write.Internal (Write (..)) - -write :: (IsSiteFields xs, HasWriteConfigFields ys) => - Record ys -> Format -> [Post (Record xs)] -> Collecter Text -write conf fmt posts = flip matchField fmt $ - htabulateFor (Proxy :: Proxy Write) $ - \m -> Field (Match . pure $ writeTo m conf posts) - -fileName :: HasWriteConfigFields xs => Record xs -> Format -> FilePath -fileName conf = matchField $ - htabulateFor (Proxy :: Proxy Write) $ - \m -> Field (Match . pure $ fileName' m conf) - -updateFileName :: HasWriteConfigFields xs => - Format -> FilePath -> Record xs -> Record xs -updateFileName = matchField $ - htabulateFor (Proxy :: Proxy Write) $ Field . Match . pure . updateFileName' diff --git a/src/ScrapBook/Write/Internal.hs b/src/ScrapBook/Write/Internal.hs deleted file mode 100644 --- a/src/ScrapBook/Write/Internal.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} - -module ScrapBook.Write.Internal - ( Write (..) - , throwWriteError - ) where - -import RIO - -import Data.Extensible -import ScrapBook.Collecter (CollectError (..), Collecter) -import ScrapBook.Data.Config (HasWriteConfigFields) -import ScrapBook.Data.Site (IsSiteFields, Post) - -class Write kv where - writeTo :: - (IsSiteFields xs, HasWriteConfigFields ys) => - proxy kv -> Record ys -> [Post (Record xs)] -> Collecter Text - fileName' :: - HasWriteConfigFields ys => - proxy kv -> Record ys -> FilePath - updateFileName' :: - HasWriteConfigFields ys => - proxy kv -> FilePath -> Record ys -> Record ys - -throwWriteError :: Text -> Collecter a -throwWriteError = throwM . WriteException diff --git a/test/Driver.hs b/test/Driver.hs deleted file mode 100644 --- a/test/Driver.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,11 @@ +module Main where + +import RIO +import qualified Test.ScrapBook.Cmd + +import Test.Tasty + +main :: IO () +main = defaultMain $ testGroup "scrapbook package" + [ Test.ScrapBook.Cmd.tests + ] diff --git a/test/Test/ScrapBook/Cmd.hs b/test/Test/ScrapBook/Cmd.hs --- a/test/Test/ScrapBook/Cmd.hs +++ b/test/Test/ScrapBook/Cmd.hs @@ -13,6 +13,12 @@ import Test.Tasty import Test.Tasty.HUnit +tests :: TestTree +tests = testGroup "ScrapBook.Cmd" + [ testGroup "toCmd" test_toCmd + , testGroup "optParser" test_optParser + ] + opts :: Options opts = #input @= ["sites.yaml"] diff --git a/test/Test/ScrapBook/Data/Site.hs b/test/Test/ScrapBook/Data/Site.hs deleted file mode 100644 --- a/test/Test/ScrapBook/Data/Site.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.ScrapBook.Data.Site where - -import RIO - -import Data.Extensible -import ScrapBook.Data.Site -import Test.Tasty -import Test.Tasty.HUnit - -site :: Site -site - = #title @= "Hoge Site" - <: #author @= "hoge" - <: #url @= "https://example.com" - <: #id @= embedAssoc (#feed @= "https://example.com/feed") - <: nil - -test_toAbsoluteUrl :: [TestTree] -test_toAbsoluteUrl = - [ testCase "prefix is `/`" $ - toAbsoluteUrl site "/aaa/bbb.html" @?= "https://example.com/aaa/bbb.html" - , testCase "prefix is not `/`" $ - toAbsoluteUrl site "https://example.com/aaa/bbb.html" @?= "https://example.com/aaa/bbb.html" - , testCase "empty string" $ - toAbsoluteUrl site "" @?= "" - ] diff --git a/test/Test/ScrapBook/Internal/Utils.hs b/test/Test/ScrapBook/Internal/Utils.hs deleted file mode 100644 --- a/test/Test/ScrapBook/Internal/Utils.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.ScrapBook.Internal.Utils where - -import RIO - -import ScrapBook.Internal.Utils -import Test.Tasty -import Test.Tasty.HUnit - -test_valid :: [TestTree] -test_valid = - [ testCase "valid (const True)" $ valid (const True) 'a' @?= Just 'a' - , testCase "valid (const False)" $ valid (const False) 'a' @?= Nothing - ] - -test_toHost :: [TestTree] -test_toHost = - [ testCase "toHost use Http" $ - toHost "http://example.com/hoge/fuga" @?= "http://example.com" - , testCase "toHost use Https" $ - toHost "https://example.com/hoge/fuga" @?= "https://example.com" - , testCase "toHost: no host" $ - toHost "http://" @?= "http://" - , testCase "toHost: no scheme" $ - toHost "abc" @?= "abc" - ] - -test_formatTimeFromRFC822 :: [TestTree] -test_formatTimeFromRFC822 = - [ testCase "correct case" $ - formatTimeFromRFC822 "Tue, 06 Mar 2018 05:29:45 GMT" @?= Just "2018-03-06T05:29:45Z" - , testCase "empty string" $ - formatTimeFromRFC822 "" @?= Nothing - ]