diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 index 6762241..0000000 --- a/.stylish-haskell.yaml +++ /dev/null @@ -1,481 +0,0 @@ -# stylish-haskell configuration file -# ================================== - -# The stylish-haskell tool is mainly configured by specifying steps. These steps -# are a list, so they have an order, and one specific step may appear more than -# once (if needed). Each file is processed by these steps in the given order. -steps: - # Convert some ASCII sequences to their Unicode equivalents. This is disabled - # by default. - # - unicode_syntax: - # # In order to make this work, we also need to insert the UnicodeSyntax - # # language pragma. If this flag is set to true, we insert it when it's - # # not already present. You may want to disable it if you configure - # # language extensions using some other method than pragmas. Default: - # # true. - # add_language_pragma: true - - # Format module header - # - # Currently, this option is not configurable and will format all exports and - # module declarations to minimize diffs - # - # - module_header: - # # How many spaces use for indentation in the module header. - # indent: 4 - # - # # Should export lists be sorted? Sorting is only performed within the - # # export section, as delineated by Haddock comments. - # sort: true - # - # # See `separate_lists` for the `imports` step. - # separate_lists: true - # - # # When to break the "where". - # # Possible values: - # # - exports: only break when there is an explicit export list. - # # - single: only break when the export list counts more than one export. - # # - inline: only break when the export list is too long. This is - # # determined by the `columns` setting. Not applicable when the export - # # list contains comments as newlines will be required. - # # - always: always break before the "where". - # break_where: exports - # - # # Where to put open bracket - # # Possible values: - # # - same_line: put open bracket on the same line as the module name, before the - # # comment of the module - # # - next_line: put open bracket on the next line, after module comment - # open_bracket: next_line - - # Format record definitions. This is disabled by default. - # - # You can control the layout of record fields. The only rules that can't be configured - # are these: - # - # - "|" is always aligned with "=" - # - "," in fields is always aligned with "{" - # - "}" is likewise always aligned with "{" - # - # - records: - # # How to format equals sign between type constructor and data constructor. - # # Possible values: - # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. - # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. - # equals: "indent 2" - # - # # How to format first field of each record constructor. - # # Possible values: - # # - "same_line" -- "{" and first field goes on the same line as the data constructor. - # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor - # first_field: "indent 2" - # - # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. - # field_comment: 2 - # - # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. - # deriving: 2 - # - # # How many spaces to insert before "via" clause counted from indentation of deriving clause - # # Possible values: - # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. - # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. - # via: "indent 2" - # - # # Sort typeclass names in the "deriving" list alphabetically. - # sort_deriving: true - # - # # Whether or not to break enums onto several lines - # # - # # Default: false - # break_enums: false - # - # # Whether or not to break single constructor data types before `=` sign - # # - # # Default: true - # break_single_constructors: true - # - # # Whether or not to curry constraints on function. - # # - # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ - # # - # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ - # # - # # Default: false - # curried_context: false - - # Align the right hand side of some elements. This is quite conservative - # and only applies to statements where each element occupies a single - # line. - # Possible values: - # - always - Always align statements. - # - adjacent - Align statements that are on adjacent lines in groups. - # - never - Never align statements. - # All default to always. - - simple_align: - cases: always - top_level_patterns: always - records: always - multi_way_if: always - - # Import cleanup - - imports: - # There are different ways we can align names and lists. - # - # - global: Align the import names and import list throughout the entire - # file. - # - # - file: Like global, but don't add padding when there are no qualified - # imports in the file. - # - # - group: Only align the imports per group (a group is formed by adjacent - # import lines). - # - # - none: Do not perform any alignment. - # - # Default: global. - align: none - - # The following options affect only import list alignment. - # - # List align has following options: - # - # - after_alias: Import list is aligned with end of import including - # 'as' and 'hiding' keywords. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - with_alias: Import list is aligned with start of alias or hiding. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - with_module_name: Import list is aligned `list_padding` spaces after - # the module name. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # init, last, length) - # - # This is mainly intended for use with `pad_module_names: false`. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # init, last, length, scanl, scanr, take, drop, - # sort, nub) - # - # - new_line: Import list starts always on new line. - # - # > import qualified Data.List as List - # > (concat, foldl, foldr, head, init, last, length) - # - # - repeat: Repeat the module name to align the import list. - # - # > import qualified Data.List as List (concat, foldl, foldr, head) - # > import qualified Data.List as List (init, last, length) - # - # Default: after_alias - list_align: after_alias - - # Right-pad the module names to align imports in a group: - # - # - true: a little more readable - # - # > import qualified Data.List as List (concat, foldl, foldr, - # > init, last, length) - # > import qualified Data.List.Extra as List (concat, foldl, foldr, - # > init, last, length) - # - # - false: diff-safe - # - # > import qualified Data.List as List (concat, foldl, foldr, init, - # > last, length) - # > import qualified Data.List.Extra as List (concat, foldl, foldr, - # > init, last, length) - # - # Default: true - pad_module_names: true - - # Long list align style takes effect when import is too long. This is - # determined by 'columns' setting. - # - # - inline: This option will put as much specs on same line as possible. - # - # - new_line: Import list will start on new line. - # - # - new_line_multiline: Import list will start on new line when it's - # short enough to fit to single line. Otherwise it'll be multiline. - # - # - multiline: One line per import list entry. - # Type with constructor list acts like single import. - # - # > import qualified Data.Map as M - # > ( empty - # > , singleton - # > , ... - # > , delete - # > ) - # - # Default: inline - long_list_align: multiline - - # Align empty list (importing instances) - # - # Empty list align has following options - # - # - inherit: inherit list_align setting - # - # - right_after: () is right after the module name: - # - # > import Vector.Instances () - # - # Default: inherit - empty_list_align: inherit - - # List padding determines indentation of import list on lines after import. - # This option affects 'long_list_align'. - # - # - : constant value - # - # - module_name: align under start of module name. - # Useful for 'file' and 'group' align settings. - # - # Default: 4 - list_padding: 4 - - # Separate lists option affects formatting of import list for type - # or class. The only difference is single space between type and list - # of constructors, selectors and class functions. - # - # - true: There is single space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable (fold, foldl, foldMap)) - # - # - false: There is no space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable(fold, foldl, foldMap)) - # - # Default: true - separate_lists: true - - # Space surround option affects formatting of import lists on a single - # line. The only difference is single space after the initial - # parenthesis and a single space before the terminal parenthesis. - # - # - true: There is single space associated with the enclosing - # parenthesis. - # - # > import Data.Foo ( foo ) - # - # - false: There is no space associated with the enclosing parenthesis - # - # > import Data.Foo (foo) - # - # Default: false - space_surround: false - - # Post qualify option moves any qualifies found in import declarations - # to the end of the declaration. This also adjust padding for any - # unqualified import declarations. - # - # - true: Qualified as is moved to the end of the - # declaration. - # - # > import Data.Bar - # > import Data.Foo qualified as F - # - # - false: Qualified remains in the default location and unqualified - # imports are padded to align with qualified imports. - # - # > import Data.Bar - # > import qualified Data.Foo as F - # - # Default: false - post_qualify: false - - # Automatically group imports based on their module names, with - # a blank line separating each group. Groups are ordered in - # alphabetical order. - # - # By default, this groups by the first part of each module's - # name (Control.* will be grouped together, Data.*... etc), but - # this can be configured with the group_patterns setting. - # - # When enabled, this rewrites existing blank lines and groups. - # - # - true: Group imports by the first part of the module name. - # - # > import Control.Applicative - # > import Control.Monad - # > import Control.Monad.MonadError - # > - # > import Data.Functor - # - # - false: Keep import groups as-is (still sorting and - # formatting the imports within each group) - # - # > import Control.Monad - # > import Data.Functor - # > - # > import Control.Applicative - # > import Control.Monad.MonadError - # - # Default: false - group_imports: false - - # A list of rules specifying how to group modules and how to - # order the groups. - # - # Each rule has a match field; the rule only applies to module - # names matched by this pattern. Patterns are POSIX extended - # regular expressions; see the documentation of Text.Regex.TDFA - # for details: - # https://hackage.haskell.org/package/regex-tdfa-1.3.1.2/docs/Text-Regex-TDFA.html - # - # Rules are processed in order, so only the *first* rule that - # matches a specific module will apply. Any module names that do - # not match a single rule will be put into a single group at the - # end of the import block. - # - # Example: group MyApp modules first, with everything else in - # one group at the end. - # - # group_rules: - # - match: "^MyApp\\>" - # - # > import MyApp - # > import MyApp.Foo - # > - # > import Control.Monad - # > import MyApps - # > import Test.MyApp - # - # A rule can also optionally have a sub_group pattern. Imports - # that match the rule will be broken up into further groups by - # the part of the module name matched by the sub_group pattern. - # - # Example: group MyApp modules first, then everything else - # sub-grouped by the first part of the module name. - # - # group_rules: - # - match: "^MyApp\\>" - # - match: "." - # sub_group: "^[^.]+" - # - # > import MyApp - # > import MyApp.Foo - # > - # > import Control.Applicative - # > import Control.Monad - # > - # > import Data.Map - # - # A pattern only needs to match part of the module name, which - # could be in the middle. You can use ^pattern to anchor to the - # beginning of the module name, pattern$ to anchor to the end - # and ^pattern$ to force a full match. Example: - # - # - "Test\\." would match "Test.Foo" and "Foo.Test.Lib" - # - "^Test\\." would match "Test.Foo" but not "Foo.Test.Lib" - # - "\\.Test$" would match "Foo.Test" but not "Foo.Test.Lib" - # - "^Test$" would *only* match "Test" - # - # You can use \\< and \\> to anchor against the beginning and - # end of words, respectively. For example: - # - # - "^Test\\." would match "Test.Foo" but not "Test" or "Tests" - # - "^Test\\>" would match "Test.Foo" and "Test", but not - # "Tests" - # - # The default is a single rule that matches everything and - # sub-groups based on the first component of the module name. - # - # Default: [{ "match" : ".*", "sub_group": "^[^.]+" }] - group_rules: - - match: ".*" - sub_group: "^[^.]+" - - # Language pragmas - - language_pragmas: - # We can generate different styles of language pragma lists. - # - # - vertical: Vertical-spaced language pragmas, one per line. - # - # - compact: A more compact style. - # - # - compact_line: Similar to compact, but wrap each line with - # `{-# LANGUAGE #-}'. - # - # - vertical_compact: Similar to vertical, but use only one language pragma. - # - # Default: vertical. - style: vertical - - # Align affects alignment of closing pragma brackets. - # - # - true: Brackets are aligned in same column. - # - # - false: Brackets are not aligned together. There is only one space - # between actual import and closing bracket. - # - # Default: true - align: false - - # stylish-haskell can detect redundancy of some language pragmas. If this - # is set to true, it will remove those redundant pragmas. Default: true. - remove_redundant: true - - # Language prefix to be used for pragma declaration, this allows you to - # use other options non case-sensitive like "language" or "Language". - # If a non correct String is provided, it will default to: LANGUAGE. - language_prefix: LANGUAGE - - # Replace tabs by spaces. This is disabled by default. - # - tabs: - # # Number of spaces to use for each tab. Default: 8, as specified by the - # # Haskell report. - # spaces: 8 - - # Remove trailing whitespace - - trailing_whitespace: {} - - # Squash multiple spaces between the left and right hand sides of some - # elements into single spaces. Basically, this undoes the effect of - # simple_align but is a bit less conservative. - # - squash: {} - -# A common setting is the number of columns (parts of) code will be wrapped -# to. Different steps take this into account. -# -# Set this to null to disable all line wrapping. -# -# Default: 80. -columns: 100 - -# By default, line endings are converted according to the OS. You can override -# preferred format here. -# -# - native: Native newline format. CRLF on Windows, LF on other OSes. -# -# - lf: Convert to LF ("\n"). -# -# - crlf: Convert to CRLF ("\r\n"). -# -# Default: native. -newline: native - -# Sometimes, language extensions are specified in a cabal file or from the -# command line instead of using language pragmas in the file. stylish-haskell -# needs to be aware of these, so it can parse the file correctly. -# -# No language extensions are enabled by default. -# language_extensions: - # - TemplateHaskell - # - QuasiQuotes - -# Attempt to find the cabal file in ancestors of the current directory, and -# parse options (currently only language extensions) from that. -# -# Default: true -cabal: true diff --git a/README.md b/README.md index 001605e..a3a8b56 100644 --- a/README.md +++ b/README.md @@ -7,3 +7,9 @@ - So we're gonna do the PDFs after all - Let's hope we can deduce the PDF path from the link - And also that the PDFs aren't generated on demand as well. + +## TODO + +- CI +- Docker container (in flake) +- try fourmolu diff --git a/app/Main.hs b/app/Main.hs index 40d47ec..92a0910 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,17 +13,17 @@ import Data.Time (Day, toGregorian) import Network.HTTP.Media ((//), (/:)) import Network.HTTP.Types (status200) import Servant - ( Accept (..) - , Capture - , Get - , MimeRender (..) - , Raw - , Server - , Tagged (..) - , serve - , (:<|>) (..) - , (:>) - ) + ( Accept (..) + , Capture + , Get + , MimeRender (..) + , Raw + , Server + , Tagged (..) + , serve + , (:<|>) (..) + , (:>) + ) import System.FilePath (()) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.Blaze.Html5 ((!)) @@ -48,20 +48,21 @@ main :: IO () main = do capabilities <- getNumCapabilities let maxResources = capabilities - connPool <- newPool $ defaultPoolConfig - (unsafeConnect "host=localhost port=5433 user=yore-test dbname=yore-test") - Opium.close - 10 - maxResources + connPool <- + newPool $ + defaultPoolConfig + (unsafeConnect "host=localhost port=5433 user=yore-test dbname=yore-test") + Opium.close + 10 + maxResources Warp.run 3000 $ serve (Proxy :: Proxy API) $ server connPool - where unsafeConnect s = either throwIO pure =<< Opium.connect s -type API - = Get '[HTML] RootModel - :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel - :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> Raw +type API = + Get '[HTML] RootModel + :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel + :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> Raw server :: Pool Opium.Connection -> Server API server connPool = rootR :<|> todayR :<|> apiTodayR @@ -82,13 +83,14 @@ server connPool = rootR :<|> todayR :<|> apiTodayR let fullPath = "download" dayFile.relative_path secondsUntilMidnight <- getSecondsUntilMidnight - respond $ responseFile - status200 - [ ("content-type", "application/pdf") - , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight) - ] - fullPath - Nothing + respond $ + responseFile + status200 + [ ("content-type", "application/pdf") + , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight) + ] + fullPath + Nothing data RootModel = RootModel Day DB.DayFile Int Int @@ -96,7 +98,8 @@ instance MimeRender HTML RootModel where mimeRender _ (RootModel dateThen dayFile issue count) = renderHtml $ do H.docTypeHtml $ do H.head $ do - H.style "body { margin: 0; font-family: Helvetica, sans-serif; } .layout { display: flex; flex-direction: column; width: 100vw; height: 100vh; } .topbar { user-select: none; text-align: center; padding: .5em; } .content { flex: 1; } iframe { border: 0; }" + H.style + "body { margin: 0; font-family: Helvetica, sans-serif; } .layout { display: flex; flex-direction: column; width: 100vw; height: 100vh; } .topbar { user-select: none; text-align: center; padding: .5em; } .content { flex: 1; } iframe { border: 0; }" H.body $ do H.div ! A.class_ "layout" $ do H.div ! A.class_ "topbar" $ do @@ -113,11 +116,11 @@ instance MimeRender HTML RootModel where buildLink label issue' | issue' == 0 = - H.a ! A.href "/" $ label + H.a ! A.href "/" $ label | issue' > 0 && issue' < count = - H.a ! A.href (H.toValue (printf "/today/issue/%d" issue' :: String)) $ label + H.a ! A.href (H.toValue (printf "/today/issue/%d" issue' :: String)) $ label | otherwise = - H.span ! A.style "color: grey;" $ label + H.span ! A.style "color: grey;" $ label -- Utils diff --git a/flake.nix b/flake.nix index 30e561f..ab49e46 100644 --- a/flake.nix +++ b/flake.nix @@ -74,7 +74,7 @@ pkgs.cabal-install pkgs.haskellPackages.implicit-hie pkgs.haskell-language-server - pkgs.stylish-haskell + pkgs.fourmolu pkgs.postgresql pkgs.dbmate ]; diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..1c61609 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,22 @@ +indentation: 2 +column-limit: 120 +function-arrows: leading +comma-style: leading +import-export-style: leading +import-grouping: by-scope-then-qualified +indent-wheres: true +record-brace-space: true +newlines-between-decls: 1 +haddock-style: single-line +haddock-style-module: single-line +haddock-location-signature: auto +let-style: auto +in-style: left-align +single-constraint-parens: always +single-deriving-parens: always +sort-constraints: false +sort-derived-classes: false +sort-deriving-clauses: false +trailing-section-operators: true +unicode: never +respectful: true diff --git a/src/Yore/DB.hs b/src/Yore/DB.hs index e66d030..601855c 100644 --- a/src/Yore/DB.hs +++ b/src/Yore/DB.hs @@ -14,7 +14,7 @@ module Yore.DB , getNumberOfIssues , Table (..) , getTables -) where + ) where import Data.Functor.Identity (Identity (..)) import Data.Text (Text) @@ -25,38 +25,44 @@ import qualified Database.PostgreSQL.Opium as Opium data Table = Table { schema :: String - , name :: String - } deriving (Show, Generic, Opium.FromRow) + , name :: String + } + deriving (Show, Generic, Opium.FromRow) getTables :: Opium.Connection -> IO (Either Opium.Error [Table]) getTables = Opium.fetch_ "SELECT table_schema AS schema, table_name AS name FROM information_schema.tables" data DayIndex = DayIndex { day_index_id :: Int - , day :: Day - } deriving (Show, Generic, Opium.FromRow) + , day :: Day + } + deriving (Show, Generic, Opium.FromRow) data DayFile = DayFile - { day_file_id :: Int - , day_index_id :: Int - , label :: Text + { day_file_id :: Int + , day_index_id :: Int + , label :: Text , relative_path :: FilePath - } deriving (Show, Generic, Opium.FromRow) + } + deriving (Show, Generic, Opium.FromRow) newtype CountResult = CountResult { count :: Int - } deriving (Show, Generic, Opium.FromRow) + } + deriving (Show, Generic, Opium.FromRow) createDayIndex :: Day -> Opium.Connection -> IO (Either Opium.Error DayIndex) -createDayIndex date = ex runIdentity . - Opium.fetch - "INSERT INTO yore.day_index (day) VALUES ($1) RETURNING *" - (Identity date) +createDayIndex date = + ex runIdentity + . Opium.fetch + "INSERT INTO yore.day_index (day) VALUES ($1) RETURNING *" + (Identity date) createDayFile :: Int -> Text -> FilePath -> Opium.Connection -> IO (Either Opium.Error ()) createDayFile dayId label path = Opium.execute - "INSERT INTO yore.day_file (day_index_id, label, relative_path) VALUES ($1, $2, $3)" (dayId, label, path) + "INSERT INTO yore.day_file (day_index_id, label, relative_path) VALUES ($1, $2, $3)" + (dayId, label, path) readDayIndex :: Day -> Opium.Connection -> IO (Either Opium.Error (Maybe DayIndex)) readDayIndex date = @@ -71,16 +77,18 @@ readDayPaths date = (Identity date) getDayFileByIssue :: Day -> Int -> Opium.Connection -> IO (Either Opium.Error DayFile) -getDayFileByIssue date issue = ex runIdentity . - Opium.fetch - "SELECT yore.day_file.* FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1 ORDER BY day_file_id LIMIT 1 OFFSET $2" - (date, issue) +getDayFileByIssue date issue = + ex runIdentity + . Opium.fetch + "SELECT yore.day_file.* FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1 ORDER BY day_file_id LIMIT 1 OFFSET $2" + (date, issue) getNumberOfIssues :: Day -> Opium.Connection -> IO (Either Opium.Error Int) -getNumberOfIssues date = ex (count . runIdentity) . - Opium.fetch - "SELECT count(*) FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1" - (Identity date) +getNumberOfIssues date = + ex (count . runIdentity) + . Opium.fetch + "SELECT count(*) FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1" + (Identity date) ex :: (a -> b) -> IO (Either e a) -> IO (Either e b) ex = fmap . fmap diff --git a/src/Yore/Download.hs b/src/Yore/Download.hs index a76c8f4..4e1aab3 100644 --- a/src/Yore/Download.hs +++ b/src/Yore/Download.hs @@ -17,8 +17,10 @@ import qualified Text.URI as URI -- | Download a URL and save it to a directory. -- Returns the path of the downloaded file relative to the directory. downloadInto - :: FilePath -- ^ Directory where to store the file. - -> Text -- ^ The URL to download. + :: FilePath + -- ^ Directory where to store the file. + -> Text + -- ^ The URL to download. -> IO FilePath downloadInto downloadDir textUrl = download >>= save where diff --git a/src/Yore/Index.hs b/src/Yore/Index.hs index 2debd1e..f0c48b2 100644 --- a/src/Yore/Index.hs +++ b/src/Yore/Index.hs @@ -20,5 +20,5 @@ createEntries date urls conn = do confidently $ DB.createDayFile dayIndex.day_index_id text url conn confidently $ Opium.execute_ "COMMIT" conn -confidently :: Exception e => IO (Either e a) -> IO a +confidently :: (Exception e) => IO (Either e a) -> IO a confidently action = action >>= either throwIO pure diff --git a/src/Yore/Scrape.hs b/src/Yore/Scrape.hs index 3e44829..0329016 100644 --- a/src/Yore/Scrape.hs +++ b/src/Yore/Scrape.hs @@ -15,20 +15,20 @@ import Data.Maybe (listToMaybe, mapMaybe) import Data.Text (Text) import Data.Time (Day, MonthOfYear, Year, fromGregorian, toGregorian) import Network.HTTP.Req - ( BsResponse - , GET (..) - , NoReqBody (..) - , Req - , bsResponse - , defaultHttpConfig - , formToQuery - , https - , req - , responseBody - , responseStatusCode - , runReq - , (/:) - ) + ( BsResponse + , GET (..) + , NoReqBody (..) + , Req + , bsResponse + , defaultHttpConfig + , formToQuery + , https + , req + , responseBody + , responseStatusCode + , runReq + , (/:) + ) import Text.HTML.Parser (Attr (..), Token (..), parseTokens) import Text.Printf (printf) import Text.URI (URI) @@ -41,18 +41,20 @@ import qualified Text.URI as URI -- | A single issue of a newspaper. There may be multiple isses per day. data Issue = Issue - { day :: Day + { day :: Day , label :: Text -- ^ A human-readable label for the issue, e.g. @1. Blatt@, @Sportblatt@ or @Handelsblatt@. - , url :: Text + , url :: Text -- ^ Where to fetch the PDF file for this issue. - } deriving (Eq, Show) + } + deriving (Eq, Show) data Target = Target - { day :: Day - , label :: Text + { day :: Day + , label :: Text , params :: Params - } deriving (Eq, Show) + } + deriving (Eq, Show) type Params = (Text, Text, Text) @@ -80,37 +82,42 @@ getIssueByTarget target = do let mbRefreshTarget = listToMaybe $ mapMaybe getRefreshTarget htmlTokens refreshTarget <- maybe (error "couldnt find refresh target") pure mbRefreshTarget - pure $ Issue - { day = target.day - , label = target.label - , url = refreshTarget - } + pure $ + Issue + { day = target.day + , label = target.label + , url = refreshTarget + } showmonthRequest :: Year -> MonthOfYear -> Req BsResponse -showmonthRequest year month = req - GET - (https "fz.ub.uni-freiburg.de" /: "show" /: "fz.cgi") - NoReqBody - bsResponse - (formToQuery - [ ("cmd", "showmonth") :: (String, String) - , ("year", printf "%04d" year) - , ("month", printf "%02d" month) - , ("project", "3") - ]) +showmonthRequest year month = + req + GET + (https "fz.ub.uni-freiburg.de" /: "show" /: "fz.cgi") + NoReqBody + bsResponse + ( formToQuery + [ ("cmd", "showmonth") :: (String, String) + , ("year", printf "%04d" year) + , ("month", printf "%02d" month) + , ("project", "3") + ] + ) showpdfRequest :: Params -> Req BsResponse -showpdfRequest (y, m, d) = req - GET - (https "fz.ub.uni-freiburg.de" /: "show" /: "fz.cgi") - NoReqBody - bsResponse - (formToQuery - [ ("cmd" :: Text, "showpdf") - , ("year", y) - , ("month", m) - , ("day", d) - ]) +showpdfRequest (y, m, d) = + req + GET + (https "fz.ub.uni-freiburg.de" /: "show" /: "fz.cgi") + NoReqBody + bsResponse + ( formToQuery + [ ("cmd" :: Text, "showpdf") + , ("year", y) + , ("month", m) + , ("day", d) + ] + ) parseTargets :: [Token] -> [Target] parseTargets = q0 [] @@ -147,7 +154,7 @@ getShowday t = do getAHref :: Token -> Maybe Text getAHref (TagOpen "a" attrs) = getAttr "href" attrs -getAHref _ = Nothing +getAHref _ = Nothing getRefreshTarget :: Token -> Maybe Text getRefreshTarget (TagOpen "meta" attrs) = do @@ -180,9 +187,9 @@ getParam param uri = decodeDecimalEntities :: Text -> Text decodeDecimalEntities = Text.pack . q0 . Text.unpack where - q0 "" = "" + q0 "" = "" q0 ('&' : '#' : r) = q1 0 r - q0 (c : r) = c : q0 r + q0 (c : r) = c : q0 r -- Silently swallows broken entities at the end of the string... q1 _ "" = "" diff --git a/src/Yore/Time.hs b/src/Yore/Time.hs index bef4420..636eb16 100644 --- a/src/Yore/Time.hs +++ b/src/Yore/Time.hs @@ -1,24 +1,23 @@ module Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight) where import Data.Time - ( Day - , addGregorianYearsClip - , getZonedTime - , isLeapYear - , localDay - , localTimeOfDay - , sinceMidnight - , toGregorian - , zonedTimeToLocalTime - ) + ( Day + , addGregorianYearsClip + , getZonedTime + , isLeapYear + , localDay + , localTimeOfDay + , sinceMidnight + , toGregorian + , zonedTimeToLocalTime + ) addYears :: Integer -> Day -> Maybe Day addYears yearOffset date | isFebruary29th && not (isLeapYear year') = - Nothing + Nothing | otherwise = - Just $ addGregorianYearsClip yearOffset date - + Just $ addGregorianYearsClip yearOffset date where (year, month, day) = toGregorian date year' = year + yearOffset diff --git a/yore.cabal b/yore.cabal index 0486786..3158e4a 100644 --- a/yore.cabal +++ b/yore.cabal @@ -27,6 +27,8 @@ common shared-options -Wpartial-fields -Wredundant-constraints default-language: GHC2021 + default-extensions: + NoImportQualifiedPost library import: shared-options