diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,19 @@ Changelog ========= +Version 0.2.0.0 +--------------- + +*November 3, 2019* + + + +* Switch from libcurl to servant, which allows for shedding of external + dependencies. +* Support leaderboard API with data type. +* Expose raw servant API and client functions, for those who want to build + documentation or a mock server or low-level client. + Version 0.1.2.X --------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ [![Build Status](https://travis-ci.org/mstksg/advent-of-code-api.svg?branch=master)](https://travis-ci.org/mstksg/advent-of-code-api) Haskell bindings for Advent of Code REST API. Caches and throttles requests -automatically. +automatically, and parses responses into meaningful data types. [advent-of-code-api]: https://hackage.haskell.org/package/advent-of-code-api @@ -29,10 +29,8 @@ request every three seconds, with ability to adjust up to as fast as a hard-coded limit of one request per second. -Note that leaderboard API is not yet supported. - -Requires *libcurl*, with future plans to move to a "pure Haskell" -networking backend. +The neatly exported bindings (handling cookies/authentication, cacheing, +throttling) are in *Advent*. Session Keys ------------ @@ -43,4 +41,12 @@ The session key can be found by logging in on a web client and checking the cookies. You can usually check these with in-browser developer tools. + +Servant API +----------- + +A Servant API (for integrating with *servant* for features like mock servers, +documentation and low-level client methods) is also exported in *Advent.API*. +The Servant API also parses into meaningful types, but lacks management of +cookies/auth, cacheing, and throttling. Please use especially responsibly. 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,18 +1,17 @@ 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.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 981dd4bf9967973046dfd1d35527c986c3f5609336fd03d8d7faf5944537342a +-- hash: 9e35c93b909c0ae1a536d52a0eb26455a393d111063a82c5cc5577f4fab16c13 name: advent-of-code-api -version: 0.1.2.3 -synopsis: Advent of Code REST API bindings -description: Haskell bindings for Advent of Code REST API. Please use responsibly! - See README.md or "Advent" module for an introduction and tutorial. - . - Requires libcurl. +version: 0.2.0.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 @@ -21,7 +20,7 @@ copyright: (c) Justin Le 2018 license: BSD3 license-file: LICENSE -tested-with: GHC >= 8.0 && < 8.8 +tested-with: GHC >= 8.0 build-type: Simple extra-source-files: README.md @@ -43,27 +42,35 @@ library exposed-modules: Advent + Advent.API other-modules: - Advent.Cache Advent.Throttle - Paths_advent_of_code_api + Advent.Cache hs-source-dirs: src ghc-options: -Wall -Wcompat -Werror=incomplete-patterns build-depends: - attoparsec + aeson + , attoparsec , base >=4.9 && <5 + , bytestring , containers - , curl , deepseq , directory , filepath , finite-typelits + , http-api-data + , http-client + , http-client-tls + , http-media , mtl + , servant + , servant-client + , servant-client-core + , stm , tagsoup , text , time - , uri-encode default-language: Haskell2010 test-suite advent-of-code-api-test diff --git a/src/Advent.hs b/src/Advent.hs --- a/src/Advent.hs +++ b/src/Advent.hs @@ -13,7 +13,7 @@ -- | -- Module : Advent --- Copyright : (c) Justin Le 2018 +-- Copyright : (c) Justin Le 2019 -- License : BSD3 -- -- Maintainer : justin@jle.im @@ -42,8 +42,6 @@ -- 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. --- --- Note that leaderboard API is not yet supported. module Advent ( -- * API @@ -51,6 +49,7 @@ , Part(..) , AoCOpts(..) , SubmitRes(..), showSubmitRes + , Leaderboard(..), LeaderboardMember(..) , runAoC , defaultAoCOpts , AoCError(..) @@ -67,42 +66,44 @@ -- ** Throttler , setAoCThrottleLimit, getAoCThrottleLimit -- * Internal - , parseSubmitRes - , processHTML + , aocReq + , aocBase ) where +import Advent.API import Advent.Cache import Advent.Throttle -import Control.Applicative +import Control.Concurrent.STM import Control.Exception import Control.Monad.Except -import Data.Char -import Data.Finite -import Data.Foldable import Data.Kind -import Data.Map (Map) +import Data.Map (Map) import Data.Maybe -import Data.Set (Set) -import Data.Text (Text) -import Data.Time +import Data.Set (Set) +import Data.Text (Text) +import Data.Time hiding (Day) import Data.Typeable -import GHC.Generics (Generic) -import Network.Curl +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.HTML.TagSoup.Tree (TagTree(..)) import Text.Printf -import qualified Data.Attoparsec.Text as P -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Network.URI.Encode as URI -import qualified System.IO.Unsafe as Unsafe -import qualified Text.HTML.TagSoup as H -import qualified Text.HTML.TagSoup.Tree as H +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 System.IO.Unsafe as Unsafe -#if !MIN_VERSION_base(4,11,0) +#if MIN_VERSION_base(4,11,0) +import Data.Functor +#else import Data.Semigroup ((<>)) + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap #endif initialThrottleLimit :: Int @@ -120,54 +121,22 @@ getAoCThrottleLimit :: IO Int getAoCThrottleLimit = getLimit aocThrottler --- | The result of a submission. -data SubmitRes - -- | Correct submission, including global rank (if reported, which - -- usually happens if rank is under 1000) - = SubCorrect (Maybe Integer) - -- | Incorrect submission. Contains the number of /seconds/ you must - -- wait before trying again. The 'Maybe' contains possible hints given - -- by the server (usually "too low" or "too high"). - | SubIncorrect Int (Maybe String) - -- | Submission was rejected because an incorrect submission was - -- recently submitted. Contains the number of /seconds/ you must wait - -- before trying again. - | SubWait Int - -- | Submission was rejected because it was sent to an invalid question - -- or part. Usually happens if you submit to a part you have already - -- answered or have not yet unlocked. - | SubInvalid - -- | Could not parse server response. Contains parse error. - | SubUnknown String - deriving (Show, Read, Eq, Ord, Typeable, Generic) - --- | A given part of a problem. All Advent of Code challenges are --- two-parts. --- --- You can usually get 'Part1' (if it is already released) with a nonsense --- session key, but 'Part2' always requires a valid session key. --- --- Note also that Challenge #25 typically only has a single part. -data Part = Part1 | Part2 - deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic) - -- | An API command. An @'AoC' a@ an AoC API request that returns -- results of type @a@. -- --- A lot of these commands take @'Finite' 25@, which represents a day of --- December up to and including Christmas Day (December 25th). You can --- convert an integer day (1 - 25) into a @'Finite' 25@ representing that --- day using 'mkDay' or 'mkDay_'. +-- A lot of these commands take 'Day', which represents a day of December +-- 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. AoCPrompt - :: Finite 25 + :: Day -> AoC (Map Part Text) -- | Fetch input, as plaintext. Returned verbatim. Be aware that -- input might contain trailing newlines. - AoCInput :: Finite 25 -> AoC Text + 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'. @@ -176,25 +145,55 @@ -- of leading and trailing whitespace and run through 'URI.encode' -- before submitting. AoCSubmit - :: Finite 25 + :: 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. + -- + -- @since 0.2.0.0 + AoCLeaderboard + :: Integer + -> AoC Leaderboard + deriving instance Show (AoC a) deriving instance Typeable (AoC a) --- | Get the day associated with a given API command. -aocDay :: AoC a -> Finite 25 -aocDay (AoCPrompt d ) = d -aocDay (AoCInput d ) = d -aocDay (AoCSubmit d _ _) = d +-- | 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 (AoCLeaderboard _) = Nothing -- | A possible (syncronous, logical, pure) error returnable from 'runAoC'. -- Does not cover any asynchronous or IO errors. data AoCError - -- | A libcurl error, with response code and response body - = AoCCurlError CurlCode String + -- | 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 +#else + = AoCClientError ServantError +#endif -- | Tried to interact with a challenge that has not yet been -- released. Contains the amount of time until release. | AoCReleaseError NominalDiffTime @@ -229,14 +228,6 @@ -- | Throttle delay, in milliseconds. Minimum is 1000000. Default -- is 3000000 (3 seconds). , _aThrottle :: Int - -- | (Low-level usage) Extra 'CurlOption' options to feed to the - -- libcurl bindings. Meant for things like proxy options and custom - -- SSL certificates. You should normally not have to add anything - -- here, since the library manages cookies, request methods, etc. for - -- you. Anything other than tweaking low-level network options (like - -- the ones mentioned previously) will likely break everything. - -- Default is @[]@. - , _aCurlOpts :: [CurlOption] } deriving (Show, Typeable, Generic) @@ -254,34 +245,22 @@ , _aCache = Nothing , _aForce = False , _aThrottle = 3000000 - , _aCurlOpts = [] } --- | API endpoint for a given command. -apiUrl :: Integer -> AoC a -> FilePath -apiUrl y = \case - AoCPrompt i -> printf "https://adventofcode.com/%04d/day/%d" y (dayInt i) - AoCInput i -> printf "https://adventofcode.com/%04d/day/%d/input" y (dayInt i) - AoCSubmit i _ _ -> printf "https://adventofcode.com/%04d/day/%d/answer" y (dayInt i) +-- | HTTPS base of Advent of Code API. +aocBase :: BaseUrl +aocBase = BaseUrl Https "adventofcode.com" 443 "" --- | Create a cookie option from a session key. -sessionKeyCookie :: String -> CurlOption -sessionKeyCookie = CurlCookie . printf "session=%s" +-- | 'ClientM' request for a given 'AoC' API call. +aocReq :: Integer -> AoC a -> ClientM a +aocReq yr = \case + AoCPrompt i -> let r :<|> _ = adventAPIPuzzleClient yr i in r + AoCInput i -> let _ :<|> r :<|> _ = adventAPIPuzzleClient yr i in r + AoCSubmit i p ans -> let _ :<|> _ :<|> r = adventAPIPuzzleClient yr i + in r (SubmitInfo p ans) <&> \(x :<|> y) -> (x, y) + AoCLeaderboard c -> let _ :<|> r = adventAPIClient yr + in r (PublicCode c) -apiCurl :: String -> AoC a -> [CurlOption] -apiCurl sess = \case - AoCPrompt _ -> sessionKeyCookie sess - : method_GET - AoCInput _ -> sessionKeyCookie sess - : method_GET - AoCSubmit _ p ans -> sessionKeyCookie sess - : CurlPostFields [ printf "level=%d" (partInt p) - , printf "answer=%s" (enc ans ) - ] - : CurlHttpHeaders ["Content-Type: application/x-www-form-urlencoded"] - : method_POST - where - enc = URI.encode . strip -- | Cache file for a given 'AoC' command apiCache @@ -290,9 +269,10 @@ -> 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 + 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 where keyDir = case sess of Nothing -> "" @@ -317,97 +297,41 @@ then noCache else saverLoader a - cacher . withCurlDo . runExceptT $ do - rel <- liftIO $ timeToRelease _aYear (aocDay a) - when (rel > 0) $ - throwError $ AoCReleaseError rel - - (cc, r) <- (maybe (throwError AoCThrottleError) pure =<<) - . liftIO - . throttling aocThrottler (max 1000000 _aThrottle) - $ curlGetString u (apiCurl _aSessionKey a ++ _aCurlOpts) - case cc of - CurlOK -> return () - _ -> throwError $ AoCCurlError cc r - pure $ processAoC a r - where - u = apiUrl _aYear a + cacher . runExceptT $ do + forM_ (aocDay a) $ \d -> do + rel <- liftIO $ timeToRelease _aYear d + when (rel > 0) $ + throwError $ AoCReleaseError rel --- | Process a string response into the type desired. -processAoC :: AoC a -> String -> a -processAoC = \case - AoCPrompt _ -> M.fromList - . zip [Part1 ..] - . processHTML - AoCInput{} -> T.pack - AoCSubmit{} -> (\o -> (o, parseSubmitRes o)) - . fromMaybe "" - . listToMaybe - . processHTML + mtr <- liftIO + . throttling aocThrottler (max 1000000 _aThrottle) + $ runClientM (aocReq _aYear a) =<< aocClientEnv _aSessionKey + mcr <- maybe (throwError AoCThrottleError) pure mtr + either (throwError . AoCClientError) pure mcr --- | Process an HTML webpage into a list of all contents in
s -processHTML :: String -> [Text] -processHTML = map H.renderTree - . mapMaybe isArticle - . H.universeTree - . H.parseTree - . T.pack +aocClientEnv :: String -> IO ClientEnv +aocClientEnv s = do + t <- getCurrentTime + v <- atomically . newTVar $ createCookieJar [c t] + mgr <- newTlsManager + pure $ ClientEnv mgr aocBase (Just v) where - isArticle :: TagTree Text -> Maybe [TagTree Text] - isArticle (TagBranch n _ ts) = ts <$ guard (n == "article") - isArticle _ = Nothing + 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 --- | Parse 'Text' into a 'SubmitRes'. -parseSubmitRes :: Text -> SubmitRes -parseSubmitRes = either SubUnknown id - . P.parseOnly choices - . mconcat - . mapMaybe deTag - . H.parseTags - where - deTag (H.TagText t) = Just t - deTag _ = Nothing - choices = asum [ parseCorrect P. "Correct" - , parseIncorrect P. "Incorrect" - , parseWait P. "Wait" - , parseInvalid P. "Invalid" - ] - parseCorrect = do - _ <- P.manyTill P.anyChar (P.asciiCI "that's the right answer") P. "Right answer" - r <- optional . (P. "Rank") $ do - P.manyTill P.anyChar (P.asciiCI "rank") - *> P.skipMany (P.satisfy (not . isDigit)) - P.decimal - pure $ SubCorrect r - parseIncorrect = do - _ <- P.manyTill P.anyChar (P.asciiCI "that's not the right answer") P. "Not the right answer" - hint <- optional . (P. "Hint") $ do - P.manyTill P.anyChar "your answer is" *> P.skipSpace - P.takeWhile1 (/= '.') - P.manyTill P.anyChar (P.asciiCI "wait") *> P.skipSpace - waitAmt <- (1 <$ P.asciiCI "one") <|> P.decimal - pure $ SubIncorrect (waitAmt * 60) (T.unpack <$> hint) - parseWait = do - _ <- P.manyTill P.anyChar (P.asciiCI "an answer too recently") P. "An answer too recently" - P.skipMany (P.satisfy (not . isDigit)) - m <- optional . (P. "Delay minutes") $ - P.decimal <* P.char 'm' <* P.skipSpace - s <- P.decimal <* P.char 's' P. "Delay seconds" - pure . SubWait $ maybe 0 (* 60) m + s - parseInvalid = SubInvalid <$ P.manyTill P.anyChar (P.asciiCI "solving the right level") --- | Pretty-print a 'SubmitRes' -showSubmitRes :: SubmitRes -> String -showSubmitRes = \case - SubCorrect Nothing -> "Correct" - SubCorrect (Just r) -> printf "Correct (Rank %d)" r - SubIncorrect i Nothing -> printf "Incorrect (%d minute wait)" (i `div` 60) - SubIncorrect i (Just h) -> printf "Incorrect (%s) (%d minute wait)" h (i `div` 60) - SubWait i -> let (m,s) = i `divMod` 60 - in printf "Wait (%d min %d sec wait)" m s - SubInvalid -> "Invalid" - SubUnknown r -> printf "Unknown (%s)" r - saverLoader :: AoC a -> SaverLoader (Either AoCError a) saverLoader = \case AoCPrompt d -> SL { _slSave = either (const Nothing) (Just . encodeMap) @@ -420,11 +344,12 @@ , _slLoad = Just . Right } AoCSubmit{} -> noCache + AoCLeaderboard{} -> noCache where - expectedParts :: Finite 25 -> Set Part - expectedParts n - | n == 24 = S.singleton Part1 - | otherwise = S.fromDistinctAscList [Part1 ..] + expectedParts :: Day -> Set Part + expectedParts d + | d == maxBound = S.singleton Part1 + | otherwise = S.fromDistinctAscList [Part1 ..] sep = ">>>>>>>>>" encodeMap mp = T.intercalate "\n" . concat $ [ maybeToList $ M.lookup Part1 mp @@ -438,61 +363,27 @@ | T.null (T.strip ln) = M.empty | otherwise = M.singleton p ln --- | Construct a @'Finite' 25@ (the type of a Day) from a day --- integer (1 - 25). If input is out of range, 'Nothing' is returned. See --- 'mkDay_' for an unsafe version useful for literals. --- --- Inverse of 'dayInt'. -mkDay :: Integer -> Maybe (Finite 25) -mkDay = packFinite . subtract 1 - --- | Construct a @'Finite' 25@ (the type of a Day) from a day --- integer (1 - 25). Is undefined if input is out of range. Can be useful --- for compile-time literals, like @'mkDay_' 4@ --- --- Inverse of 'dayInt'. -mkDay_ :: Integer -> Finite 25 -mkDay_ = fromMaybe e . mkDay - where - e = errorWithoutStackTrace "Advent.mkDay_: Date out of range (1 - 25)" - -- | Get time until release of a given challenge. timeToRelease :: Integer -- ^ year - -> Finite 25 -- ^ day + -> Day -- ^ day -> IO NominalDiffTime timeToRelease y d = (challengeReleaseTime y d `diffUTCTime`) <$> getCurrentTime -- | Check if a challenge has been released yet. challengeReleased :: Integer -- ^ year - -> Finite 25 -- ^ day + -> Day -- ^ day -> IO Bool challengeReleased y = fmap (<= 0) . timeToRelease y -- | Prompt release time challengeReleaseTime :: Integer -- ^ year - -> Finite 25 -- ^ day + -> Day -- ^ day -> UTCTime challengeReleaseTime y d = UTCTime (fromGregorian y 12 (fromIntegral (dayInt d))) (5 * 60 * 60) - --- | Convert a @'Finite' 25@ day into a day integer (1 - 25). Inverse of --- 'mkDay'. -dayInt :: Finite 25 -> Integer -dayInt = (+ 1) . getFinite - --- | Convert a 'Part' to an 'Int'. -partInt :: Part -> Int -partInt Part1 = 1 -partInt Part2 = 2 - --- | A character associated with a given part. 'Part1' is associated with --- @\'a\'@, and 'Part2' is associated with @\'b\'@ -partChar :: Part -> Char -partChar Part1 = 'a' -partChar Part2 = 'b' strip :: String -> String strip = T.unpack . T.strip . T.pack diff --git a/src/Advent/API.hs b/src/Advent/API.hs new file mode 100644 --- /dev/null +++ b/src/Advent/API.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Advent.API +-- Copyright : (c) Justin Le 2019 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Raw Servant API for Advent of Code. Can be useful for building mock +-- servers, generating documentation and other servanty things, or +-- low-level raw requests. +-- +-- If you use this to make requests directly, please use responsibly: do +-- not make automated requests more than once per day and throttle all +-- manual requestes. See notes in "Advent". +-- +-- @since 0.2.0.0 +-- + +module Advent.API ( + -- * Types + Day(..) + , Part(..) + , SubmitInfo(..) + , SubmitRes(..), showSubmitRes + , PublicCode(..) + , Leaderboard(..) + , LeaderboardMember(..) + -- * Servant API + , AdventAPI + , adventAPI + , adventAPIClient + , adventAPIPuzzleClient + -- * Util + , mkDay, mkDay_, dayInt + , partInt + , partChar + -- * Internal + , processHTML + , parseSubmitRes + , Articles + , FromArticles(..) + , RawText + ) where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import Data.Bifunctor +import Data.Char +import Data.Finite +import Data.Foldable +import Data.Functor.Classes +import Data.Map (Map) +import Data.Maybe +import Data.Proxy +import Data.Text (Text) +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Typeable +import GHC.Generics +import Servant.API +import Servant.Client +import Text.HTML.TagSoup.Tree (TagTree(..)) +import Text.Printf +import Text.Read (readMaybe) +import qualified Data.Attoparsec.Text as P +import qualified Data.ByteString.Lazy as BSL +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 qualified Text.HTML.TagSoup.Tree as H +import qualified Web.FormUrlEncoded as WF + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif + +-- | Describes the day: a number between 1 and 25 inclusive. +-- +-- Represented by a 'Finite' ranging from 0 to 24 inclusive; you should +-- probably make one using the smart constructor 'mkDay'. +newtype Day = Day { dayFinite :: Finite 25 } + deriving (Eq, Ord, Enum, Bounded, Typeable, Generic) + +instance Show Day where + showsPrec = showsUnaryWith (\d -> showsPrec d . dayInt) "mkDay" + +-- | A given part of a problem. All Advent of Code challenges are +-- two-parts. +-- +-- You can usually get 'Part1' (if it is already released) with a nonsense +-- session key, but 'Part2' always requires a valid session key. +-- +-- Note also that Challenge #25 typically only has a single part. +data Part = Part1 | Part2 + deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic) + +-- | Info required to submit an answer for a part. +data SubmitInfo = SubmitInfo + { siLevel :: Part + , siAnswer :: String + } + deriving (Show, Read, Eq, Ord, Typeable, Generic) + +-- | The result of a submission. +data SubmitRes + -- | Correct submission, including global rank (if reported, which + -- usually happens if rank is under 1000) + = SubCorrect (Maybe Integer) + -- | Incorrect submission. Contains the number of /seconds/ you must + -- wait before trying again. The 'Maybe' contains possible hints given + -- by the server (usually "too low" or "too high"). + | SubIncorrect Int (Maybe String) + -- | Submission was rejected because an incorrect submission was + -- recently submitted. Contains the number of /seconds/ you must wait + -- before trying again. + | SubWait Int + -- | Submission was rejected because it was sent to an invalid question + -- or part. Usually happens if you submit to a part you have already + -- answered or have not yet unlocked. + | SubInvalid + -- | Could not parse server response. Contains parse error. + | SubUnknown String + deriving (Show, Read, Eq, Ord, Typeable, Generic) + +-- | Member ID of public leaderboard (the first part of the registration +-- code, before the hyphen). It can be found as the number in the URL: +-- +-- > https://adventofcode.com/2019/leaderboard/private/view/12345 +-- +-- (the @12345@ above) +newtype PublicCode = PublicCode { getPublicCode :: Integer } + deriving (Show, Read, Eq, Ord, Typeable, Generic) + +-- | Leaderboard type, representing private leaderboard information. +data Leaderboard = LB + { lbEvent :: Integer -- ^ The year of the event + , lbOwnerId :: Integer -- ^ The Member ID of the owner, or the public code + , lbMembers :: Map Integer LeaderboardMember -- ^ A map from member IDs to their leaderboard info + } + deriving (Show, Eq, Ord, Typeable, Generic) + +-- | Leaderboard position for a given member. +data LeaderboardMember = LBM + { lbmGlobalScore :: Integer -- ^ Global leaderboard score + , lbmName :: Maybe Text -- ^ Username, if user specifies one + , lbmLocalScore :: Integer -- ^ Score for this leaderboard + , lbmId :: Integer -- ^ Member ID + , lbmLastStarTS :: Maybe UTCTime -- ^ Time of last puzzle solved, if any + , lbmStars :: Int -- ^ Number of stars (puzzle parts) solved + , lbmCompletion :: Map Day (Map Part UTCTime) -- ^ Completion times of each day and puzzle part + } + deriving (Show, Eq, Ord, Typeable, Generic) + +instance ToHttpApiData Part where + toUrlPiece = T.pack . show . partInt + toQueryParam = toUrlPiece + +instance ToHttpApiData Day where + toUrlPiece = T.pack . show . dayInt + toQueryParam = toUrlPiece + +instance ToHttpApiData PublicCode where + toUrlPiece = (<> ".json") . T.pack . show . getPublicCode + toQueryParam = toUrlPiece + +instance WF.ToForm SubmitInfo where + toForm = WF.genericToForm WF.FormOptions + { WF.fieldLabelModifier = camelTo2 '-' . drop 2 } + +-- | Raw "text/plain" MIME type +data RawText + +instance Accept RawText where + contentType _ = "text" M.// "plain" + +instance MimeUnrender RawText Text where + mimeUnrender _ = first show . T.decodeUtf8' . BSL.toStrict + +-- | Interpret repsonse as a list of HTML 'Text' in @
@ tags. +data Articles + +-- | Class for interpreting a list of 'Text' in article tags to some +-- desired output. +class FromArticles a where + fromArticles :: [Text] -> a + +instance Accept Articles where + contentType _ = "text" M.// "html" + +instance FromArticles a => MimeUnrender Articles a where + mimeUnrender _ = fmap fromArticles + . bimap show processHTML + . T.decodeUtf8' + . BSL.toStrict + +instance FromArticles [Text] where + fromArticles = id + +instance FromArticles Text where + fromArticles = T.unlines + +instance (Ord a, Enum a, Bounded a) => FromArticles (Map a Text) where + fromArticles = M.fromList . zip [minBound ..] + +instance (FromArticles a, FromArticles b) => FromArticles (a :<|> b) where + fromArticles xs = fromArticles xs :<|> fromArticles xs + +instance FromArticles SubmitRes where + fromArticles = parseSubmitRes . fold . listToMaybe + +instance FromJSON Leaderboard where + parseJSON = withObject "Leaderboard" $ \o -> + LB <$> (strInt =<< (o .: "event")) + <*> (strInt =<< (o .: "owner_id")) + <*> o .: "members" + where + strInt t = case readMaybe t of + Nothing -> fail "bad int" + Just i -> pure i + +instance FromJSON LeaderboardMember where + parseJSON = withObject "LeaderboardMember" $ \o -> + LBM <$> o .: "global_score" + <*> optional (o .: "name") + <*> o .: "local_score" + <*> (strInt =<< (o .: "id")) + <*> optional (fromEpoch =<< (o .: "last_star_ts")) + <*> o .: "stars" + <*> (do cdl <- o .: "completion_day_level" + (traverse . traverse) ((fromEpoch =<<) . (.: "get_star_ts")) cdl + ) + where + strInt t = case readMaybe t of + Nothing -> fail "bad int" + Just i -> pure i + fromEpoch t = case readMaybe t of + Nothing -> fail "bad stamp" + Just i -> pure . posixSecondsToUTCTime $ fromInteger i + +instance FromJSONKey Day where + fromJSONKey = FromJSONKeyTextParser (parseJSON . String) +instance FromJSONKey Part where + fromJSONKey = FromJSONKeyTextParser (parseJSON . String) + +instance FromJSON Part where + parseJSON = withText "Part" $ \case + "1" -> pure Part1 + "2" -> pure Part2 + _ -> fail "Bad part" +instance FromJSON Day where + parseJSON = withText "Day" $ \t -> + case readMaybe (T.unpack t) of + Nothing -> fail "No read day" + Just i -> case mkDay i of + Nothing -> fail "Day out of range" + Just d -> pure d + + + +-- | REST API of Advent of Code. +-- +-- Note that most of these requests assume a "session=" cookie. +type AdventAPI = + Capture "year" Integer + :> ("day" :> Capture "day" Day + :> (Get '[Articles] (Map Part Text) + :<|> "input" :> Get '[RawText] Text + :<|> "answer" + :> ReqBody '[FormUrlEncoded] SubmitInfo + :> Post '[Articles] (Text :<|> SubmitRes) + ) + :<|> "leaderboard" :> "private" :> "view" + :> Capture "code" PublicCode + :> Get '[JSON] Leaderboard + ) + +-- | 'Proxy' used for /servant/ functions. +adventAPI :: Proxy AdventAPI +adventAPI = Proxy + +-- | 'ClientM' requests based on 'AdventAPI', generated by servant. +adventAPIClient + :: Integer + -> (Day -> ClientM (Map Part Text) :<|> ClientM Text :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes)) ) + :<|> (PublicCode -> ClientM Leaderboard) +adventAPIClient = client adventAPI + +-- | A subset of 'adventAPIClient' for only puzzle-related API routes, not +-- leaderboard ones. +adventAPIPuzzleClient + :: Integer + -> Day + -> ClientM (Map Part Text) :<|> ClientM Text :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes)) +adventAPIPuzzleClient y = pis + where + pis :<|> _ = adventAPIClient y + +-- | Process an HTML webpage into a list of all contents in
s +processHTML :: Text -> [Text] +processHTML = map H.renderTree + . mapMaybe isArticle + . H.universeTree + . H.parseTree + where + isArticle :: TagTree Text -> Maybe [TagTree Text] + isArticle (TagBranch n _ ts) = ts <$ guard (n == "article") + isArticle _ = Nothing + +-- | Parse 'Text' into a 'SubmitRes'. +parseSubmitRes :: Text -> SubmitRes +parseSubmitRes = either SubUnknown id + . P.parseOnly choices + . mconcat + . mapMaybe deTag + . H.parseTags + where + deTag (H.TagText t) = Just t + deTag _ = Nothing + choices = asum [ parseCorrect P. "Correct" + , parseIncorrect P. "Incorrect" + , parseWait P. "Wait" + , parseInvalid P. "Invalid" + , fail "No option recognized" + ] + parseCorrect = do + _ <- P.manyTill P.anyChar (P.asciiCI "that's the right answer") P. "Right answer" + r <- optional . (P. "Rank") $ do + P.manyTill P.anyChar (P.asciiCI "rank") + *> P.skipMany (P.satisfy (not . isDigit)) + P.decimal + pure $ SubCorrect r + parseIncorrect = do + _ <- P.manyTill P.anyChar (P.asciiCI "that's not the right answer") P. "Not the right answer" + hint <- optional . (P. "Hint") $ do + P.manyTill P.anyChar "your answer is" *> P.skipSpace + P.takeWhile1 (/= '.') + P.manyTill P.anyChar (P.asciiCI "wait") *> P.skipSpace + waitAmt <- (1 <$ P.asciiCI "one") <|> P.decimal + pure $ SubIncorrect (waitAmt * 60) (T.unpack <$> hint) + parseWait = do + _ <- P.manyTill P.anyChar (P.asciiCI "an answer too recently") P. "An answer too recently" + P.skipMany (P.satisfy (not . isDigit)) + m <- optional . (P. "Delay minutes") $ + P.decimal <* P.char 'm' <* P.skipSpace + s <- P.decimal <* P.char 's' P. "Delay seconds" + pure . SubWait $ maybe 0 (* 60) m + s + parseInvalid = SubInvalid <$ P.manyTill P.anyChar (P.asciiCI "solving the right level") + +-- | Pretty-print a 'SubmitRes' +showSubmitRes :: SubmitRes -> String +showSubmitRes = \case + SubCorrect Nothing -> "Correct" + SubCorrect (Just r) -> printf "Correct (Rank %d)" r + SubIncorrect i Nothing -> printf "Incorrect (%d minute wait)" (i `div` 60) + SubIncorrect i (Just h) -> printf "Incorrect (%s) (%d minute wait)" h (i `div` 60) + SubWait i -> let (m,s) = i `divMod` 60 + in printf "Wait (%d min %d sec wait)" m s + SubInvalid -> "Invalid" + SubUnknown r -> printf "Unknown (%s)" r + +-- | Convert a @'Finite' 25@ day into a day integer (1 - 25). Inverse of +-- 'mkDay'. +dayInt :: Day -> Integer +dayInt = (+ 1) . getFinite . dayFinite + +-- | Convert a 'Part' to an 'Int'. +partInt :: Part -> Int +partInt Part1 = 1 +partInt Part2 = 2 + +-- | Construct a 'Day' from a day integer (1 - 25). If input is out of +-- range, 'Nothing' is returned. See 'mkDay_' for an unsafe version useful +-- for literals. +-- +-- Inverse of 'dayInt'. +mkDay :: Integer -> Maybe Day +mkDay = fmap Day . packFinite . subtract 1 + +-- | Construct a @'Finite' 25@ (the type of a Day) from a day +-- integer (1 - 25). Is undefined if input is out of range. Can be useful +-- for compile-time literals, like @'mkDay_' 4@ +-- +-- Inverse of 'dayInt'. +mkDay_ :: Integer -> Day +mkDay_ = fromMaybe e . mkDay + where + e = errorWithoutStackTrace "Advent.mkDay_: Date out of range (1 - 25)" + +-- | A character associated with a given part. 'Part1' is associated with +-- @\'a\'@, and 'Part2' is associated with @\'b\'@ +partChar :: Part -> Char +partChar Part1 = 'a' +partChar Part2 = 'b' + diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ViewPatterns #-} -import Advent +import Advent.API import Control.Monad import Data.List import System.Directory