diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,22 @@ Changelog ========= +Version 0.2.12.0 +---------------- + +*September 28, 2026* + + + +* Add `lbNumDays` and `lbDay1Ts` to `Leaderboard`, parsed from the `num_days` + and `day1_ts` fields of the private leaderboard JSON. +* Add `lbmStarIndex` to `LeaderboardMember`, parsed from the `star_index` + field alongside each completion's `get_star_ts`. +* The `session` cookie is now an explicit `Header "Cookie"` in + `AdventAPI` via servant, scoped only to the endpoints that actually need it + (optional for `day` prompt, required for `input`/`answer`/private + leaderboard). Adds `SessionKey`, re-exported from `Advent`. + Version 0.2.11.0 ---------------- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/advent-of-code-api.cabal b/advent-of-code-api.cabal --- a/advent-of-code-api.cabal +++ b/advent-of-code-api.cabal @@ -1,57 +1,59 @@ -cabal-version: 1.12 +cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack -name: advent-of-code-api -version: 0.2.11.0 -synopsis: Advent of Code REST API bindings and servant API -description: Haskell bindings for Advent of Code REST API and a servant API. Please use - responsibly! See README.md or "Advent" module for an introduction and - tutorial. -category: Web -homepage: https://github.com/mstksg/advent-of-code-api#readme -bug-reports: https://github.com/mstksg/advent-of-code-api/issues -author: Justin Le -maintainer: justin@jle.im -copyright: (c) Justin Le 2018 -license: BSD3 -license-file: LICENSE -build-type: Simple -tested-with: - GHC >= 8.0 +name: advent-of-code-api +version: 0.2.12.0 +synopsis: Advent of Code REST API bindings and servant API +description: + Haskell bindings for Advent of Code REST API and a servant API. Please use + responsibly! See README.md or "Advent" module for an introduction and + tutorial. + +category: Web +homepage: https://github.com/mstksg/advent-of-code-api#readme +bug-reports: https://github.com/mstksg/advent-of-code-api/issues +author: Justin Le +maintainer: justin@jle.im +copyright: (c) Justin Le 2018 +license: BSD3 +license-file: LICENSE +build-type: Simple +tested-with: GHC >=8.0 extra-source-files: - README.md - CHANGELOG.md - test-data/correct-rank.txt - test-data/correct.txt - test-data/incorrect-high.txt - test-data/incorrect-low.txt - test-data/incorrect-wait.txt - test-data/incorrect.txt - test-data/invalid.txt - test-data/wait.txt - test-data/wait2.txt + CHANGELOG.md + README.md + test-data/correct-rank.txt + test-data/correct.txt + test-data/incorrect-high.txt + test-data/incorrect-low.txt + test-data/incorrect-wait.txt + test-data/incorrect.txt + test-data/invalid.txt + test-data/wait.txt + test-data/wait2.txt source-repository head - type: git + type: git location: https://github.com/mstksg/advent-of-code-api library exposed-modules: - Advent - Advent.API - Advent.Types + Advent + Advent.API + Advent.Types + other-modules: - Advent.Throttle - Advent.Cache - hs-source-dirs: - src - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns + Advent.Cache + Advent.Throttle + + hs-source-dirs: src + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns build-depends: aeson - , base >=4.9 && <5 + , base >=4.9 && <5 , bytestring , containers , deepseq @@ -62,7 +64,7 @@ , http-client , http-client-tls , http-media - , megaparsec >=7 + , megaparsec >=7 , mtl , profunctors , servant @@ -72,22 +74,25 @@ , tagsoup , text , time - , time-compat >=1.9 + , time-compat >=1.9 + default-language: Haskell2010 test-suite advent-of-code-api-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_advent_of_code_api - hs-source-dirs: - test - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: Paths_advent_of_code_api + hs-source-dirs: test + ghc-options: + -Wall -Wcompat -Werror=incomplete-patterns -threaded -rtsopts + -with-rtsopts=-N + build-depends: - HUnit - , advent-of-code-api - , base >=4.9 && <5 + advent-of-code-api + , base >=4.9 && <5 , directory , filepath + , HUnit , text + default-language: Haskell2010 diff --git a/src/Advent.hs b/src/Advent.hs --- a/src/Advent.hs +++ b/src/Advent.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Advent @@ -45,77 +44,88 @@ -- Please use responsibly. All actions are by default rate limited to one -- per three seconds, but this can be adjusted to a hard-limited cap of one -- per second. - module Advent ( -- * API - AoC(..) - , Part(..) - , Day(..) - , NextDayTime(..) - , DayStats(..) - , Stats - , AoCOpts(..) - , AoCUserAgent(..) - , SubmitRes(..), showSubmitRes - , statsForDayPart - , inferSubmitRes - , inferSubmitRes_ - , runAoC - , runAoC_ - , defaultAoCOpts - , AoCError(..) + AoC (..), + Part (..), + Day (..), + NextDayTime (..), + DayStats (..), + Stats, + AoCOpts (..), + AoCUserAgent (..), + SessionKey (..), + SubmitRes (..), + showSubmitRes, + statsForDayPart, + inferSubmitRes, + inferSubmitRes_, + runAoC, + runAoC_, + defaultAoCOpts, + AoCError (..), + -- ** Calendar - , challengeReleaseTime - , timeToRelease - , challengeReleased + challengeReleaseTime, + timeToRelease, + challengeReleased, + -- * Utility + -- ** Day - , mkDay, mkDay_, dayInt, pattern DayInt, _DayInt - , aocDay - , aocServerTime + mkDay, + mkDay_, + dayInt, + pattern DayInt, + _DayInt, + aocDay, + aocServerTime, + -- ** Part - , partChar, partInt + partChar, + partInt, + -- ** Leaderboard - , fullDailyBoard + fullDailyBoard, + -- ** Throttler - , setAoCThrottleLimit, getAoCThrottleLimit + setAoCThrottleLimit, + getAoCThrottleLimit, + -- * Internal - , aocReq - , aocBase - ) where + aocReq, + aocBase, +) where -import Advent.API -import Advent.Cache -import Advent.Throttle -import Advent.Types -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import Control.Monad.Except -import Data.Kind -import Data.Map (Map) -import Data.Maybe -import Data.Set (Set) -import Data.Text (Text) -import Data.Time hiding (Day) -import Data.Typeable -import GHC.Generics (Generic) -import Network.HTTP.Client -import Network.HTTP.Client.TLS -import Servant.API -import Servant.Client -import System.Directory -import System.FilePath -import Text.Printf -import qualified Data.Aeson as A -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL +import Advent.API +import Advent.Cache +import Advent.Throttle +import Advent.Types +import Control.Exception +import Control.Monad +import Control.Monad.Except +import qualified Data.Aeson as A +import Data.Either (fromRight) +import Data.Kind +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -import qualified Servant.Client as Servant -import qualified System.IO.Unsafe as Unsafe +import Data.Time hiding (Day) +import Data.Typeable +import GHC.Generics (Generic) +import Network.HTTP.Client.TLS +import Servant.API +import Servant.Client +import System.Directory +import System.FilePath +import qualified System.IO.Unsafe as Unsafe +import Text.Printf #if MIN_VERSION_mtl(2,3,0) import Control.Monad.IO.Class (liftIO) @@ -152,138 +162,143 @@ -- up to and including Christmas Day (December 25th). You can convert an -- integer day (1 - 25) into a 'Day' using 'mkDay' or 'mkDay_'. data AoC :: Type -> Type where - -- | Fetch prompts for a given day. Returns a 'Map' of 'Part's and - -- their associated promps, as HTML. - -- - -- _Cacheing rules_: Is cached on a per-day basis. An empty session - -- key is given, it will be happy with only having Part 1 cached. If - -- a non-empty session key is given, it will trigger a cache - -- invalidation on every request until both Part 1 and Part 2 are - -- received. - AoCPrompt - :: Day - -> AoC (Map Part Text) - - -- | Fetch input, as plaintext. Returned verbatim. Be aware that - -- input might contain trailing newlines. - -- - -- /Cacheing rules/: Is cached forever, per day per session key. - AoCInput :: Day -> AoC Text - - -- | Submit a plaintext answer (the 'String') to a given day and part. - -- Receive a server reponse (as HTML) and a response code 'SubmitRes'. - -- - -- __WARNING__: Answers are not length-limited. Answers are stripped - -- of leading and trailing whitespace and run through 'URI.encode' - -- before submitting. - -- - -- /Cacheing rules/: Is never cached. - AoCSubmit - :: Day - -> Part - -> String - -> AoC (Text, SubmitRes) - - -- | Fetch the leaderboard for a given leaderboard public code (owner - -- member ID). Requires session key. - -- - -- The public code can be found in the URL of the leaderboard: - -- - -- > https://adventofcode.com/2019/leaderboard/private/view/12345 - -- - -- (the @12345@ above) - -- - -- __NOTE__: This is the most expensive and taxing possible API call, - -- and makes up the majority of bandwidth to the Advent of Code - -- servers. As a courtesy to all who are participating in Advent of - -- Code, please use this super respectfully, especially in December: if - -- you set up automation for this, please do not use it more than once - -- per day. - -- - -- /Cacheing rules/: Is never cached, so please use responsibly (see - -- note above). - -- - -- @since 0.2.0.0 - AoCLeaderboard - :: Integer - -> AoC Leaderboard - - -- | Fetch the daily leaderboard for a given day. Does not require - -- a session key. - -- - -- Leaderboard API calls tend to be expensive, so please be respectful - -- when using this. If you automate this, please do not fetch any more - -- often than necessary. - -- - -- /Cacheing rules/: Will be cached if a full leaderboard is observed. - -- - -- @since 0.2.3.0 - AoCDailyLeaderboard - :: Day - -> AoC DailyLeaderboard - - -- | Fetch the global leaderboard. Does not require - -- a session key. - -- - -- Leaderboard API calls tend to be expensive, so please be respectful - -- when using this. If you automate this, please do not fetch any more - -- often than necessary. - -- - -- /Cacheing rules/: Will not cache if an event is ongoing, but will be - -- cached if received after the event is over. - -- - -- @since 0.2.3.0 - AoCGlobalLeaderboard - :: AoC GlobalLeaderboard - - -- | From the calendar, fetch the next release's day and the - -- number of seconds util its release, if there is any at all. - -- - -- This does an actual request to the AoC servers, and is only accurate - -- to the second; to infer this information (to the millisecond level) - -- from the system clock, you should probably use 'timeToRelease' and - -- 'aocServerTime' instead, which requires no network requests. - -- - -- @since 0.2.8.0 - AoCNextDayTime - :: AoC NextDayTime - - -- | Fetch the per-day completion stats for the current year. Does not - -- require a session key. - -- - -- /Cacheing rules/: Not cached. - -- - -- @since 0.2.11.0 - AoCStats - :: AoC Stats + -- | Fetch prompts for a given day. Returns a 'Map' of 'Part's and + -- their associated promps, as HTML. + -- + -- _Cacheing rules_: Is cached on a per-day basis. An empty session + -- key is given, it will be happy with only having Part 1 cached. If + -- a non-empty session key is given, it will trigger a cache + -- invalidation on every request until both Part 1 and Part 2 are + -- received. + AoCPrompt :: + Day -> + AoC (Map Part Text) + -- | Fetch input, as plaintext. Returned verbatim. Be aware that + -- input might contain trailing newlines. + -- + -- /Cacheing rules/: Is cached forever, per day per session key. + AoCInput :: Day -> AoC Text + -- | Submit a plaintext answer (the 'String') to a given day and part. + -- Receive a server reponse (as HTML) and a response code 'SubmitRes'. + -- + -- __WARNING__: Answers are not length-limited. Answers are stripped + -- of leading and trailing whitespace and run through 'URI.encode' + -- before submitting. + -- + -- /Cacheing rules/: Is never cached. + AoCSubmit :: + Day -> + Part -> + String -> + AoC (Text, SubmitRes) + -- | Fetch the leaderboard for a given leaderboard public code (owner + -- member ID). Requires session key. + -- + -- The public code can be found in the URL of the leaderboard: + -- + -- > https://adventofcode.com/2019/leaderboard/private/view/12345 + -- + -- (the @12345@ above) + -- + -- __NOTE__: This is the most expensive and taxing possible API call, + -- and makes up the majority of bandwidth to the Advent of Code + -- servers. As a courtesy to all who are participating in Advent of + -- Code, please use this super respectfully, especially in December: if + -- you set up automation for this, please do not use it more than once + -- per day. + -- + -- /Cacheing rules/: Is never cached, so please use responsibly (see + -- note above). + -- + -- @since 0.2.0.0 + AoCLeaderboard :: + Integer -> + AoC Leaderboard + -- | Fetch the daily leaderboard for a given day. Does not require + -- a session key. + -- + -- Leaderboard API calls tend to be expensive, so please be respectful + -- when using this. If you automate this, please do not fetch any more + -- often than necessary. + -- + -- /Cacheing rules/: Will be cached if a full leaderboard is observed. + -- + -- @since 0.2.3.0 + AoCDailyLeaderboard :: + Day -> + AoC DailyLeaderboard + -- | Fetch the global leaderboard. Does not require + -- a session key. + -- + -- Leaderboard API calls tend to be expensive, so please be respectful + -- when using this. If you automate this, please do not fetch any more + -- often than necessary. + -- + -- /Cacheing rules/: Will not cache if an event is ongoing, but will be + -- cached if received after the event is over. + -- + -- @since 0.2.3.0 + AoCGlobalLeaderboard :: + AoC GlobalLeaderboard + -- | From the calendar, fetch the next release's day and the + -- number of seconds util its release, if there is any at all. + -- + -- This does an actual request to the AoC servers, and is only accurate + -- to the second; to infer this information (to the millisecond level) + -- from the system clock, you should probably use 'timeToRelease' and + -- 'aocServerTime' instead, which requires no network requests. + -- + -- @since 0.2.8.0 + AoCNextDayTime :: + AoC NextDayTime + -- | Fetch the per-day completion stats for the current year. Does not + -- require a session key. + -- + -- /Cacheing rules/: Not cached. + -- + -- @since 0.2.11.0 + AoCStats :: + AoC Stats deriving instance Show (AoC a) deriving instance Typeable (AoC a) -- | Get the day associated with a given API command, if there is one. aocDay :: AoC a -> Maybe Day -aocDay (AoCPrompt d ) = Just d -aocDay (AoCInput d ) = Just d -aocDay (AoCSubmit d _ _ ) = Just d +aocDay (AoCPrompt d) = Just d +aocDay (AoCInput d) = Just d +aocDay (AoCSubmit d _ _) = Just d aocDay (AoCLeaderboard _) = Nothing aocDay (AoCDailyLeaderboard d) = Just d aocDay AoCGlobalLeaderboard = Nothing -aocDay AoCNextDayTime = Nothing -aocDay AoCStats = Nothing +aocDay AoCNextDayTime = Nothing +aocDay AoCStats = Nothing -- | A possible (syncronous, logical, pure) error returnable from 'runAoC'. -- Does not cover any asynchronous or IO errors. +#if MIN_VERSION_servant_client_core(0,16,0) data AoCError -- | An error in the http request itself -- -- Note that if you are building this with servant-client-core <= 0.16, -- this will contain @ServantError@ instead of @ClientError@, which was -- the previous name of ths type. -#if MIN_VERSION_servant_client_core(0,16,0) = AoCClientError ClientError + -- | Tried to interact with a challenge that has not yet been + -- released. Contains the amount of time until release. + | AoCReleaseError NominalDiffTime + -- | The throttler limit is full. Either make less requests, or adjust + -- it with 'setAoCThrottleLimit'. + | AoCThrottleError + deriving (Show, Typeable, Generic) #else +data AoCError + -- | An error in the http request itself + -- + -- Note that if you are building this with servant-client-core <= 0.16, + -- this will contain @ServantError@ instead of @ClientError@, which was + -- the previous name of ths type. = AoCClientError ServantError -#endif -- | Tried to interact with a challenge that has not yet been -- released. Contains the amount of time until release. | AoCReleaseError NominalDiffTime @@ -291,6 +306,7 @@ -- it with 'setAoCThrottleLimit'. | AoCThrottleError deriving (Show, Typeable, Generic) +#endif instance Exception AoCError -- | Setings for running an API request. @@ -305,27 +321,27 @@ -- Throttling is hard-limited to a minimum of 1 second between calls. -- Please be respectful and do not try to bypass this. data AoCOpts = AoCOpts - { -- | Session key - _aSessionKey :: String - -- | Year of challenge - , _aYear :: Integer - -- | Structured user agent to use. See - -- - , _aUserAgent :: AoCUserAgent - -- | Cache directory. If 'Nothing' is given, one will be allocated - -- using 'getTemporaryDirectory'. - , _aCache :: Maybe FilePath - -- | Fetch results even if cached. Still subject to throttling. - -- Default is False. - , _aForce :: Bool - -- | Throttle delay, in milliseconds. Minimum is 1000000. Default - -- is 3000000 (3 seconds). - , _aThrottle :: Int - -- | Attempt to infer submission rank by fetching stats after a - -- correct submission that doesn't include rank information. - -- Default is False. - , _aInferRankOnSubmission :: Bool - } + { _aSessionKey :: String + -- ^ Session key + , _aYear :: Integer + -- ^ Year of challenge + , _aUserAgent :: AoCUserAgent + -- ^ Structured user agent to use. See + -- + , _aCache :: Maybe FilePath + -- ^ Cache directory. If 'Nothing' is given, one will be allocated + -- using 'getTemporaryDirectory'. + , _aForce :: Bool + -- ^ Fetch results even if cached. Still subject to throttling. + -- Default is False. + , _aThrottle :: Int + -- ^ Throttle delay, in milliseconds. Minimum is 1000000. Default + -- is 3000000 (3 seconds). + , _aInferRankOnSubmission :: Bool + -- ^ Attempt to infer submission rank by fetching stats after a + -- correct submission that doesn't include rank information. + -- Default is False. + } deriving (Show, Typeable, Generic) -- | Sensible defaults for 'AoCOpts' for a given user agent, year and session @@ -333,18 +349,19 @@ -- -- Use system temporary directory as cache, and throttle requests to one -- request per three seconds. -defaultAoCOpts - :: AoCUserAgent - -> Integer - -> String - -> AoCOpts -defaultAoCOpts aua y s = AoCOpts +defaultAoCOpts :: + AoCUserAgent -> + Integer -> + String -> + AoCOpts +defaultAoCOpts aua y s = + AoCOpts { _aSessionKey = s - , _aYear = y - , _aUserAgent = aua - , _aCache = Nothing - , _aForce = False - , _aThrottle = 3000000 + , _aYear = y + , _aUserAgent = aua + , _aCache = Nothing + , _aForce = False + , _aThrottle = 3000000 , _aInferRankOnSubmission = False } @@ -353,43 +370,52 @@ aocBase = BaseUrl Https "adventofcode.com" 443 "" -- | 'ClientM' request for a given 'AoC' API call. -aocReq :: Maybe AoCUserAgent -> Integer -> AoC a -> ClientM a -aocReq aua yr = \case - AoCPrompt i -> let r :<|> _ = adventAPIPuzzleClient aua yr i in r - AoCInput i -> let _ :<|> r :<|> _ = adventAPIPuzzleClient aua yr i in r - AoCSubmit i p ans -> let _ :<|> _ :<|> r = adventAPIPuzzleClient aua yr i - in r (SubmitInfo p ans) <&> \(x :<|> y) -> (x, y) - AoCLeaderboard c -> let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> r = adventAPIClient aua yr - in r (PublicCode c) - AoCDailyLeaderboard d -> let _ :<|> _ :<|> _ :<|> _ :<|> r :<|> _ = adventAPIClient aua yr - in r d - AoCGlobalLeaderboard -> let _ :<|> _ :<|> _ :<|> r :<|> _ :<|> _ = adventAPIClient aua yr - in r - AoCNextDayTime -> let r :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ = adventAPIClient aua yr - in r - AoCStats -> let _ :<|> r :<|> _ :<|> _ :<|> _ :<|> _ = adventAPIClient aua yr - in r - +aocReq :: Maybe AoCUserAgent -> Maybe SessionKey -> Integer -> AoC a -> ClientM a +aocReq aua sess yr = \case + AoCPrompt i -> let r :<|> _ :<|> _ = adventAPIPuzzleClient aua yr i in r sess + AoCInput i -> let _ :<|> r :<|> _ = adventAPIPuzzleClient aua yr i in r (reqSess sess) + AoCSubmit i p ans -> + let _ :<|> _ :<|> r = adventAPIPuzzleClient aua yr i + in r (reqSess sess) (SubmitInfo p ans) <&> \(x :<|> y) -> (x, y) + AoCLeaderboard c -> + let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> r = adventAPIClient aua yr + in r (reqSess sess) (PublicCode c) + AoCDailyLeaderboard d -> + let _ :<|> _ :<|> _ :<|> _ :<|> r :<|> _ = adventAPIClient aua yr + in r d + AoCGlobalLeaderboard -> + let _ :<|> _ :<|> _ :<|> r :<|> _ :<|> _ = adventAPIClient aua yr + in r + AoCNextDayTime -> + let r :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ = adventAPIClient aua yr + in r + AoCStats -> + let _ :<|> r :<|> _ :<|> _ :<|> _ :<|> _ = adventAPIClient aua yr + in r + where + reqSess = fromMaybe dummyToken -- | Cache file for a given 'AoC' command -apiCache - :: Maybe String -- ^ session key - -> Integer -- ^ year - -> AoC a - -> Maybe FilePath +apiCache :: + -- | session key + Maybe String -> + -- | year + Integer -> + AoC a -> + Maybe FilePath apiCache sess yr = \case - AoCPrompt d -> Just $ printf "prompt/%04d/%02d.html" yr (dayInt d) - AoCInput d -> Just $ printf "input/%s%04d/%02d.txt" keyDir yr (dayInt d) - AoCSubmit{} -> Nothing - AoCLeaderboard{} -> Nothing - AoCDailyLeaderboard d -> Just $ printf "daily/%04d/%02d.json" yr (dayInt d) - AoCGlobalLeaderboard{} -> Just $ printf "global/%04d.json" yr - AoCNextDayTime -> Nothing - AoCStats -> Nothing + AoCPrompt d -> Just $ printf "prompt/%04d/%02d.html" yr (dayInt d) + AoCInput d -> Just $ printf "input/%s%04d/%02d.txt" keyDir yr (dayInt d) + AoCSubmit{} -> Nothing + AoCLeaderboard{} -> Nothing + AoCDailyLeaderboard d -> Just $ printf "daily/%04d/%02d.json" yr (dayInt d) + AoCGlobalLeaderboard{} -> Just $ printf "global/%04d.json" yr + AoCNextDayTime -> Nothing + AoCStats -> Nothing where keyDir = case sess of Nothing -> "" - Just s -> strip s ++ "/" + Just s -> strip s ++ "/" -- | Run an 'AoC' command with a given 'AoCOpts' to produce the result -- or a list of (lines of) errors. @@ -399,42 +425,49 @@ -- before submitting. runAoC :: AoCOpts -> AoC a -> IO (Either AoCError a) runAoC opts@AoCOpts{..} a = do - (keyMayb, cacheDir) <- case _aCache of - Just c -> pure (Nothing, c) - Nothing -> (Just _aSessionKey,) . ( "advent-of-code-api") <$> getTemporaryDirectory + (keyMayb, cacheDir) <- case _aCache of + Just c -> pure (Nothing, c) + Nothing -> (Just _aSessionKey,) . ( "advent-of-code-api") <$> getTemporaryDirectory - (yy,mm,dd) <- toGregorian - . localDay - . utcToLocalTime (read "EST") - <$> getCurrentTime - let eventOver = yy > _aYear - || (mm == 12 && dd > 25) - cacher = case apiCache keyMayb _aYear a of - Nothing -> id - Just fp -> cacheing (cacheDir fp) $ - if _aForce - then noCache - else saverLoader - (not (null _aSessionKey)) - (not eventOver) - a + (yy, mm, dd) <- + toGregorian + . localDay + . utcToLocalTime (read "EST") + <$> getCurrentTime + let eventOver = + yy > _aYear + || (mm == 12 && dd > 25) + cacher = case apiCache keyMayb _aYear a of + Nothing -> id + Just fp -> + cacheing (cacheDir fp) $ + if _aForce + then noCache + else + saverLoader + (not (null _aSessionKey)) + (not eventOver) + a - cacher . runExceptT $ do - forM_ (aocDay a) $ \d -> do - rel <- liftIO $ timeToRelease _aYear d - when (rel > 0) $ - throwError $ AoCReleaseError rel + cacher . runExceptT $ do + forM_ (aocDay a) $ \d -> do + rel <- liftIO $ timeToRelease _aYear d + when (rel > 0) $ + throwError $ + AoCReleaseError rel - mtr <- liftIO - . throttling aocThrottler (max 1000000 _aThrottle) - $ runClientM (aocReq (Just _aUserAgent) _aYear a) =<< aocClientEnv _aSessionKey - mcr <- maybe (throwError AoCThrottleError) pure mtr - res <- either (throwError . AoCClientError) pure mcr - case (a, _aInferRankOnSubmission, res) of - (AoCSubmit d p _, True, (txt, sr)) -> do - sr' <- liftIO $ inferSubmitRes_ opts d p sr - pure (txt, sr') - _ -> pure res + let sess = SessionKey (T.pack _aSessionKey) + mtr <- + liftIO + . throttling aocThrottler (max 1000000 _aThrottle) + $ runClientM (aocReq (Just _aUserAgent) (Just sess) _aYear a) =<< aocClientEnv + mcr <- maybe (throwError AoCThrottleError) pure mtr + res <- either (throwError . AoCClientError) pure mcr + case (a, _aInferRankOnSubmission, res) of + (AoCSubmit d p _, True, (txt, sr)) -> do + sr' <- liftIO $ inferSubmitRes_ opts d p sr + pure (txt, sr') + _ -> pure res -- | A version of 'runAoC' that throws an IO exception (of type 'AoCError') -- upon failure, instead of an 'Either'. @@ -448,7 +481,7 @@ -- @since 0.2.11.0 statsForDayPart :: Day -> Part -> Stats -> Integer statsForDayPart d Part1 = maybe 0 dsSilver . M.lookup d -statsForDayPart d Part2 = maybe 0 dsGold . M.lookup d +statsForDayPart d Part2 = maybe 0 dsGold . M.lookup d -- | If an Advent of Code submission returns 'SubCorrect' without an attached -- rank, attempt to infer the rank from 'AoCStats', assuming that it was just @@ -458,122 +491,116 @@ -- unchanged. -- -- @since 0.2.11.0 -inferSubmitRes - :: AoCOpts - -> Day - -> Part - -> SubmitRes - -> IO (Either AoCError SubmitRes) +inferSubmitRes :: + AoCOpts -> + Day -> + Part -> + SubmitRes -> + IO (Either AoCError SubmitRes) inferSubmitRes opts d p sr = case sr of - SubCorrect Nothing -> do - stats <- runAoC opts AoCStats - pure $ stats >>= \st -> - case M.lookup d st of - Just _ -> Right . SubCorrect . Just $ statsForDayPart d p st - Nothing -> Right $ SubCorrect Nothing - _ -> pure $ Right sr + SubCorrect Nothing -> do + stats <- runAoC opts AoCStats + pure $ + stats >>= \st -> + case M.lookup d st of + Just _ -> Right . SubCorrect . Just $ statsForDayPart d p st + Nothing -> Right $ SubCorrect Nothing + _ -> pure $ Right sr -- | Variant of 'inferSubmitRes' that returns the original response if stats -- lookup fails. -- -- @since 0.2.11.0 -inferSubmitRes_ - :: AoCOpts - -> Day - -> Part - -> SubmitRes - -> IO SubmitRes -inferSubmitRes_ opts d p sr = either (const sr) id <$> inferSubmitRes opts d p sr - -aocClientEnv :: String -> IO ClientEnv -aocClientEnv s = do - t <- getCurrentTime - v <- atomically . newTVar $ createCookieJar [c t] - mgr <- newTlsManager - pure $ (mkClientEnv mgr aocBase) - { Servant.cookieJar = Just v } - where - c t = Cookie - { cookie_name = "session" - , cookie_value = T.encodeUtf8 . T.pack $ s - , cookie_expiry_time = addUTCTime oneYear t - , cookie_domain = "adventofcode.com" - , cookie_path = "/" - , cookie_creation_time = t - , cookie_last_access_time = t - , cookie_persistent = True - , cookie_host_only = True - , cookie_secure_only = True - , cookie_http_only = True - } - oneYear = 60 * 60 * 24 * 356.25 +inferSubmitRes_ :: + AoCOpts -> + Day -> + Part -> + SubmitRes -> + IO SubmitRes +inferSubmitRes_ opts d p sr = fromRight sr <$> inferSubmitRes opts d p sr +aocClientEnv :: IO ClientEnv +aocClientEnv = (`mkClientEnv` aocBase) <$> newTlsManager -saverLoader - :: Bool -- ^ is there a non-empty session token? - -> Bool -- ^ is the event ongoing (True) or over (False)? - -> AoC a - -> SaverLoader (Either AoCError a) +saverLoader :: + -- | is there a non-empty session token? + Bool -> + -- | is the event ongoing (True) or over (False)? + Bool -> + AoC a -> + SaverLoader (Either AoCError a) saverLoader validToken evt = \case - AoCPrompt{} -> SL { _slSave = either (const Nothing) (Just . encodeMap) - , _slLoad = \str -> - let mp = decodeMap str - hasAll = S.null (expectedParts `S.difference` M.keysSet mp) - in Right mp <$ guard hasAll - } - AoCInput{} -> SL { _slSave = either (const Nothing) Just - , _slLoad = Just . Right - } - AoCSubmit{} -> noCache - AoCLeaderboard{} -> noCache - AoCDailyLeaderboard{} -> SL - { _slSave = either (const Nothing) (Just . TL.toStrict . TL.decodeUtf8 . A.encode) - , _slLoad = \str -> do - r <- A.decode . TL.encodeUtf8 . TL.fromStrict $ str - guard $ fullDailyBoard r - pure $ Right r - } - AoCGlobalLeaderboard{} -> SL - { _slSave = either - (const Nothing) - (Just . TL.toStrict . TL.decodeUtf8 . A.encode @(Bool, GlobalLeaderboard) . (evt,)) - , _slLoad = \str -> do - (evt', lb) <- A.decode @(Bool, GlobalLeaderboard) . TL.encodeUtf8 . TL.fromStrict $ str - guard $ not evt' -- only load cache if evt' is false: it was saved in a non-evt time - pure $ Right lb - } - AoCNextDayTime{} -> noCache - AoCStats{} -> noCache + AoCPrompt{} -> + SL + { _slSave = either (const Nothing) (Just . encodeMap) + , _slLoad = \str -> + let mp = decodeMap str + hasAll = S.null (expectedParts `S.difference` M.keysSet mp) + in Right mp <$ guard hasAll + } + AoCInput{} -> + SL + { _slSave = either (const Nothing) Just + , _slLoad = Just . Right + } + AoCSubmit{} -> noCache + AoCLeaderboard{} -> noCache + AoCDailyLeaderboard{} -> + SL + { _slSave = either (const Nothing) (Just . TL.toStrict . TL.decodeUtf8 . A.encode) + , _slLoad = \str -> do + r <- A.decode . TL.encodeUtf8 . TL.fromStrict $ str + guard $ fullDailyBoard r + pure $ Right r + } + AoCGlobalLeaderboard{} -> + SL + { _slSave = + either + (const Nothing) + (Just . TL.toStrict . TL.decodeUtf8 . A.encode @(Bool, GlobalLeaderboard) . (evt,)) + , _slLoad = \str -> do + (evt', lb) <- A.decode @(Bool, GlobalLeaderboard) . TL.encodeUtf8 . TL.fromStrict $ str + guard $ not evt' -- only load cache if evt' is false: it was saved in a non-evt time + pure $ Right lb + } + AoCNextDayTime{} -> noCache + AoCStats{} -> noCache where expectedParts :: Set Part expectedParts | validToken = S.fromDistinctAscList [Part1 ..] - | otherwise = S.singleton Part1 + | otherwise = S.singleton Part1 sep = ">>>>>>>>>" - encodeMap mp = T.intercalate "\n" . concat $ - [ maybeToList $ M.lookup Part1 mp - , [sep] - , maybeToList $ M.lookup Part2 mp - ] + encodeMap mp = + T.intercalate "\n" . concat $ + [ maybeToList $ M.lookup Part1 mp + , [sep] + , maybeToList $ M.lookup Part2 mp + ] decodeMap xs = mkMap Part1 part1 <> mkMap Part2 part2 where (part1, drop 1 -> part2) = span (/= sep) (T.lines xs) - mkMap p (T.intercalate "\n"->ln) + mkMap p (T.intercalate "\n" -> ln) | T.null (T.strip ln) = M.empty - | otherwise = M.singleton p ln + | otherwise = M.singleton p ln -- | Get time until release of a given challenge. -timeToRelease - :: Integer -- ^ year - -> Day -- ^ day - -> IO NominalDiffTime +timeToRelease :: + -- | year + Integer -> + -- | day + Day -> + IO NominalDiffTime timeToRelease y d = (zonedTimeToUTC (challengeReleaseTime y d) `diffUTCTime`) <$> getCurrentTime -- | Check if a challenge has been released yet. -challengeReleased - :: Integer -- ^ year - -> Day -- ^ day - -> IO Bool +challengeReleased :: + -- | year + Integer -> + -- | day + Day -> + IO Bool challengeReleased y = fmap (<= 0) . timeToRelease y -- | Utility to get the current time on AoC servers. Basically just gets the current diff --git a/src/Advent/API.hs b/src/Advent/API.hs --- a/src/Advent/API.hs +++ b/src/Advent/API.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Advent.API @@ -30,54 +30,56 @@ -- manual requestes. See notes in "Advent". -- -- @since 0.2.0.0 --- - module Advent.API ( -- * Servant API - AdventAPI - , AoCUserAgent(..) - , adventAPI - , adventAPIClient - , adventAPIPuzzleClient + AdventAPI, + AoCUserAgent (..), + SessionKey (..), + dummyToken, + adventAPI, + adventAPIClient, + adventAPIPuzzleClient, + -- * Types - , HTMLTags - , FromTags(..) - , Articles - , Divs - , Scripts - , RawText + HTMLTags, + FromTags (..), + Articles, + Divs, + Scripts, + RawText, + -- * Internal - , processHTML - ) where + processHTML, +) where -import Advent.Types -import Control.Applicative -import Control.Monad -import Control.Monad.State -import Data.Bifunctor -import Data.Char -import Data.Finite -import Data.Foldable -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map (Map) -import Data.Maybe -import Data.Ord -import Data.Proxy -import Data.Text (Text) -import Data.Time hiding (Day) -import GHC.TypeLits -import Servant.API -import Servant.Client -import Text.HTML.TagSoup.Tree (TagTree(..)) -import Text.Read (readMaybe) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Network.HTTP.Media as M -import qualified Text.HTML.TagSoup as H +import Advent.Types +import Control.Applicative +import Control.Monad +import Control.Monad.State +import Data.Bifunctor +import qualified Data.ByteString.Lazy as BSL +import Data.Char +import Data.Finite +import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Ord +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time hiding (Day) +import GHC.TypeLits +import qualified Network.HTTP.Media as M +import Servant.API +import Servant.Client +import qualified Text.HTML.TagSoup as H +import Text.HTML.TagSoup.Tree (TagTree (..)) import qualified Text.HTML.TagSoup.Tree as H +import Text.Read (readMaybe) #if !MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>)) @@ -91,10 +93,10 @@ data RawText instance Accept RawText where - contentType _ = "text" M.// "plain" + contentType _ = "text" M.// "plain" instance MimeUnrender RawText Text where - mimeUnrender _ = first show . T.decodeUtf8' . BSL.toStrict + mimeUnrender _ = first show . T.decodeUtf8' . BSL.toStrict -- | Interpret repsonse as a list of HTML 'T.Text' found in the given type of -- tag @@ -108,7 +110,7 @@ -- | Interpret a response as a list of HTML 'T.Text' found in @
@ tags. -- -- @since 0.2.3.0 -type Divs = HTMLTags "div" +type Divs = HTMLTags "div" -- | Interpret a response as a list of HTML 'T.Text' found in @