diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,19 @@ Changelog ========= +Version 0.2.3.0 +--------------- + +*November 21, 2019* + + + +* Add API commands for daily and global leaderboards. +* In the process, the Servant API is reshuffled a bit: `Articles` has been + generalized to `HTMLTags "article"`, to also support `HTMLTags "div"`. + `FromArticle` is now `FromTags "article"`. +* Move some of the data types to be in their own module, *Advent.Types*. + Version 0.2.2.1 --------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -35,8 +35,9 @@ Session Keys ------------ -Session keys are required for all commands, but if you enter a bogus key -you should be able to get at least Part 1 from `AoCPrompt`. +Session keys are required for most commands, but if you enter a bogus key +you should be able to get at least Part 1 from `AoCPrompt`. Session keys are +also not needed for daily and global leaderboards. 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 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 @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: bc9fa15aa4120fc135cccf4203d4b3e26d035a13f3ade163809aee30e14ebc42 +-- hash: d17a4d7274081d52248b30e3b0ad9dec6be3dc449140e6d4cfd85f442966d604 name: advent-of-code-api -version: 0.2.2.1 +version: 0.2.3.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 @@ -43,6 +43,7 @@ exposed-modules: Advent Advent.API + Advent.Types other-modules: Advent.Throttle Advent.Cache diff --git a/src/Advent.hs b/src/Advent.hs --- a/src/Advent.hs +++ b/src/Advent.hs @@ -50,7 +50,6 @@ , Day(..) , AoCOpts(..) , SubmitRes(..), showSubmitRes - , Leaderboard(..), LeaderboardMember(..) , runAoC , defaultAoCOpts , AoCError(..) @@ -74,6 +73,7 @@ import Advent.API import Advent.Cache import Advent.Throttle +import Advent.Types import Control.Concurrent.STM import Control.Exception import Control.Monad.Except @@ -92,10 +92,13 @@ 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 qualified Data.Text.Lazy.Encoding as TL import qualified System.IO.Unsafe as Unsafe #if MIN_VERSION_base(4,11,0) @@ -172,6 +175,33 @@ :: 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. + -- + -- Calls to this 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. + -- + -- Calls to this will be cached if fetched after each event ends. + -- + -- @since 0.2.3.0 + AoCGlobalLeaderboard + :: AoC GlobalLeaderboard + deriving instance Show (AoC a) deriving instance Typeable (AoC a) @@ -181,6 +211,8 @@ aocDay (AoCInput d ) = Just d aocDay (AoCSubmit d _ _ ) = Just d aocDay (AoCLeaderboard _) = Nothing +aocDay (AoCDailyLeaderboard d) = Just d +aocDay AoCGlobalLeaderboard = Nothing -- | A possible (syncronous, logical, pure) error returnable from 'runAoC'. -- Does not cover any asynchronous or IO errors. @@ -259,8 +291,12 @@ 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 + AoCLeaderboard c -> let _ :<|> _ :<|> _ :<|> r = adventAPIClient yr in r (PublicCode c) + AoCDailyLeaderboard d -> let _ :<|> _ :<|> r :<|> _ = adventAPIClient yr + in r d + AoCGlobalLeaderboard -> let _ :<|> r :<|> _ :<|> _ = adventAPIClient yr + in r -- | Cache file for a given 'AoC' command @@ -274,6 +310,8 @@ 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 where keyDir = case sess of Nothing -> "" @@ -291,12 +329,18 @@ Just c -> pure (Nothing, c) Nothing -> (Just _aSessionKey,) . ( "advent-of-code-api") <$> getTemporaryDirectory - let cacher = case apiCache keyMayb _aYear a of + (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 a + else saverLoader (not eventOver) a cacher . runExceptT $ do forM_ (aocDay a) $ \d -> do @@ -333,8 +377,11 @@ oneYear = 60 * 60 * 24 * 356.25 -saverLoader :: AoC a -> SaverLoader (Either AoCError a) -saverLoader = \case +saverLoader + :: Bool -- ^ is the event ongoing (True) or over (False)? + -> AoC a + -> SaverLoader (Either AoCError a) +saverLoader evt = \case AoCPrompt d -> SL { _slSave = either (const Nothing) (Just . encodeMap) , _slLoad = \str -> let mp = decodeMap str @@ -346,11 +393,29 @@ } AoCSubmit{} -> noCache AoCLeaderboard{} -> noCache + AoCDailyLeaderboard d -> SL + { _slSave = either (const Nothing) (Just . TL.toStrict . TL.decodeUtf8 . A.encode) + , _slLoad = \str -> do + r <- A.decode . TL.encodeUtf8 . TL.fromStrict $ str + let l = M.size (dlbStar1 r) + M.size (dlbStar2 r) + guard $ l >= fullLength d + pure $ Right r + } + AoCGlobalLeaderboard{} + | evt -> noCache + | otherwise -> SL + { _slSave = either (const Nothing) (Just . TL.toStrict . TL.decodeUtf8 . A.encode) + , _slLoad = fmap Right . A.decode . TL.encodeUtf8 . TL.fromStrict + } where expectedParts :: Day -> Set Part expectedParts d | d == maxBound = S.singleton Part1 | otherwise = S.fromDistinctAscList [Part1 ..] + fullLength :: Day -> Int + fullLength d + | d == maxBound = 100 + | otherwise = 200 sep = ">>>>>>>>>" encodeMap mp = T.intercalate "\n" . concat $ [ maybeToList $ M.lookup Part1 mp diff --git a/src/Advent/API.hs b/src/Advent/API.hs --- a/src/Advent/API.hs +++ b/src/Advent/API.hs @@ -1,12 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Advent.API @@ -29,163 +36,54 @@ -- module Advent.API ( - -- * Types - Day(..) - , Part(..) - , SubmitInfo(..) - , SubmitRes(..), showSubmitRes - , PublicCode(..) - , Leaderboard(..) - , LeaderboardMember(..) -- * Servant API - , AdventAPI + AdventAPI , adventAPI , adventAPIClient , adventAPIPuzzleClient - -- * Util - , mkDay, mkDay_, dayInt - , partInt - , partChar - -- * Internal - , processHTML - , parseSubmitRes + -- * Types + , HTMLTags + , FromTags(..) , Articles - , FromArticles(..) + , Divs , RawText + -- * Internal + , processHTML ) where --- import qualified Data.Attoparsec.Text as P -import Control.Applicative +import Advent.Types import Control.Monad -import Data.Aeson +import Control.Monad.State import Data.Bifunctor import Data.Char import Data.Finite import Data.Foldable -import Data.Functor.Classes -import Data.Map (Map) +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.Clock -import Data.Time.Clock.POSIX -import Data.Typeable -import Data.Void -import GHC.Generics +import Data.Text (Text) +import Data.Time.Format +import Data.Time.LocalTime +import GHC.TypeLits import Servant.API import Servant.Client -import Text.HTML.TagSoup.Tree (TagTree(..)) -import Text.Printf -import Text.Read (readMaybe) -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 Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P -import qualified Text.Megaparsec.Char.Lexer as P -import qualified Web.FormUrlEncoded as WF +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 qualified Text.HTML.TagSoup.Tree as H #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 @@ -195,84 +93,116 @@ instance MimeUnrender RawText Text where mimeUnrender _ = first show . T.decodeUtf8' . BSL.toStrict --- | Interpret repsonse as a list of HTML 'Text' in @
@ tags. -data Articles +-- | Interpret repsonse as a list of HTML 'Text' found in the given type of +-- tag +-- +-- @since 0.2.3.0 +data HTMLTags (tag :: Symbol) --- | Class for interpreting a list of 'Text' in article tags to some --- desired output. -class FromArticles a where - fromArticles :: [Text] -> a +-- | Interpret a response as a list of HTML 'Text' found in @
@ tags. +type Articles = HTMLTags "article" -instance Accept Articles where +-- | Interpret a response as a list of HTML 'Text' found in @
@ tags. +-- +-- @since 0.2.3.0 +type Divs = HTMLTags "div" + +-- | Class for interpreting a list of 'Text' in tags to some desired +-- output. +-- +-- @since 0.2.3.0 +class FromTags tag a where + fromTags :: p tag -> [Text] -> Maybe a + +instance Accept (HTMLTags cls) where contentType _ = "text" M.// "html" -instance FromArticles a => MimeUnrender Articles a where - mimeUnrender _ = fmap fromArticles - . bimap show processHTML - . T.decodeUtf8' - . BSL.toStrict +instance (FromTags tag a, KnownSymbol tag) => MimeUnrender (HTMLTags tag) a where + mimeUnrender _ str = do + x <- first show . T.decodeUtf8' . BSL.toStrict $ str + maybe (Left "No parse") pure + . fromTags (Proxy @tag) + . processHTML (symbolVal (Proxy @tag)) + $ x -instance FromArticles [Text] where - fromArticles = id +instance FromTags cls [Text] where + fromTags _ = Just -instance FromArticles Text where - fromArticles = T.unlines +instance FromTags cls Text where + fromTags _ = Just . T.unlines -instance (Ord a, Enum a, Bounded a) => FromArticles (Map a Text) where - fromArticles = M.fromList . zip [minBound ..] +instance (Ord a, Enum a, Bounded a) => FromTags cls (Map a Text) where + fromTags _ = Just . M.fromList . zip [minBound ..] -instance (FromArticles a, FromArticles b) => FromArticles (a :<|> b) where - fromArticles xs = fromArticles xs :<|> fromArticles xs +instance (FromTags cls a, FromTags cls b) => FromTags cls (a :<|> b) where + fromTags p xs = (:<|>) <$> fromTags p xs <*> fromTags p xs -instance FromArticles SubmitRes where - fromArticles = parseSubmitRes . fold . listToMaybe +instance FromTags "article" SubmitRes where + fromTags _ = Just . parseSubmitRes . fold . listToMaybe -instance FromJSON Leaderboard where - parseJSON = withObject "Leaderboard" $ \o -> - LB <$> (strInt =<< (o .: "event")) - <*> (strInt =<< (o .: "owner_id")) - <*> o .: "members" +instance FromTags "div" DailyLeaderboard where + fromTags _ = Just . assembleDLB . mapMaybe parseMember where - strInt t = case readMaybe t of - Nothing -> fail "bad int" - Just i -> pure i + parseMember :: Text -> Maybe DailyLeaderboardMember + parseMember contents = do + dlbmRank <- fmap Rank . packFinite . subtract 1 + =<< readMaybe . filter isDigit . T.unpack . fst + =<< findTag uni "span" (Just "leaderboard-position") + dlbmTime <- fmap (localTimeToUTC (read "EST")) + . parseTimeM True defaultTimeLocale "%b %d %H:%M:%S" + . T.unpack . fst + =<< findTag uni "span" (Just "leaderboard-time") + dlbmUser <- eitherUser tr + pure DLBM{..} + where + dlbmLink = lookup "href" . snd =<< findTag uni "a" Nothing + dlbmSupporter = "AoC++" `T.isInfixOf` contents + dlbmImage = lookup "src" . snd =<< findTag uni "img" Nothing + tr = H.parseTree contents + uni = H.universeTree tr + assembleDLB = flipper . snd . foldl' (uncurry go) (Nothing, DLB M.empty M.empty) + where + flipper dlb@(DLB a b) + | M.null a = DLB b a + | otherwise = dlb + go counter dlb m@DLBM{..} = case counter of + Nothing -> dlb2 + Just Nothing -> dlb1 + Just (Just i) + | dlbmRank <= i -> dlb1 + | otherwise -> dlb2 + where + dlb1 = (Just Nothing , dlb { dlbStar1 = M.insert dlbmRank m (dlbStar1 dlb) }) + dlb2 = (Just (Just dlbmRank), dlb { dlbStar2 = M.insert dlbmRank m (dlbStar2 dlb) }) -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 - ) +instance FromTags "div" GlobalLeaderboard where + fromTags _ = Just . GLB . reScore . M.fromListWith (<>) + . map (\x -> (Down (glbmScore x), x :| [])) + . mapMaybe parseMember 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 + parseMember :: Text -> Maybe GlobalLeaderboardMember + parseMember contents = do + glbmScore <- readMaybe . filter isDigit . T.unpack . fst + =<< findTag uni "span" (Just "leaderboard-totalscore") + glbmUser <- eitherUser tr + pure GLBM{..} + where + glbmRank = Rank 0 + glbmLink = lookup "href" . snd =<< findTag uni "a" Nothing + glbmSupporter = "AoC++" `T.isInfixOf` contents + glbmImage = lookup "src" . snd =<< findTag uni "img" Nothing + tr = H.parseTree contents + uni = H.universeTree tr + reScore = fmap (\xs -> (glbmScore (NE.head xs), xs)) + . M.fromList + . flip evalState 0 + . traverse go + . toList + where + go xs = do + currScore <- get + xs' <- forM xs $ \x -> x { glbmRank = Rank currScore } <$ modify succ + pure (Rank currScore, xs') @@ -288,9 +218,14 @@ :> ReqBody '[FormUrlEncoded] SubmitInfo :> Post '[Articles] (Text :<|> SubmitRes) ) - :<|> "leaderboard" :> "private" :> "view" - :> Capture "code" PublicCode - :> Get '[JSON] Leaderboard + :<|> "leaderboard" + :> (Get '[Divs] GlobalLeaderboard + :<|> "day" :> Capture "day" Day :> Get '[Divs] DailyLeaderboard + :<|> "private" :> "view" + :> Capture "code" PublicCode + :> Get '[JSON] Leaderboard + + ) ) -- | 'Proxy' used for /servant/ functions. @@ -301,6 +236,8 @@ adventAPIClient :: Integer -> (Day -> ClientM (Map Part Text) :<|> ClientM Text :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes)) ) + :<|> ClientM GlobalLeaderboard + :<|> (Day -> ClientM DailyLeaderboard) :<|> (PublicCode -> ClientM Leaderboard) adventAPIClient = client adventAPI @@ -314,17 +251,42 @@ 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 - . cleanDoubleTitle +userNameNaked :: [TagTree Text] -> Maybe Text +userNameNaked = (listToMaybe .) . mapMaybe $ \x -> do + TagLeaf (H.TagText (T.strip->u)) <- Just x + guard . not $ T.null u + pure u +findTag :: [TagTree Text] -> Text -> Maybe Text -> Maybe (Text, [H.Attribute Text]) +findTag uni tag cls = listToMaybe . flip mapMaybe uni $ \x -> do + TagBranch tag' attr cld <- Just x + guard $ tag' == tag + forM_ cls $ \c -> guard $ ("class", c) `elem` attr + pure (H.renderTree cld, attr) +eitherUser :: [TagTree Text] -> Maybe (Either Integer Text) +eitherUser tr = asum [ + Right <$> userNameNaked tr + , fmap Right $ userNameNaked . H.parseTree . fst + =<< findTag uni "a" Nothing + , fmap Left $ readMaybe . filter isDigit . T.unpack . fst + =<< findTag uni "span" (Just "leaderboard-anon") + ] where - isArticle :: TagTree Text -> Maybe [TagTree Text] - isArticle (TagBranch n _ ts) = ts <$ guard (n == "article") - isArticle _ = Nothing + uni = H.universeTree tr + +-- | Process an HTML webpage into a list of all contents in the given tag +-- type +processHTML + :: String -- ^ tag type + -> Text -- ^ html + -> [Text] +processHTML tag = mapMaybe getTag + . H.universeTree + . H.parseTree + . cleanDoubleTitle + where + getTag :: TagTree Text -> Maybe Text + getTag (TagBranch n _ ts) = H.renderTree ts <$ guard (n == T.pack tag) + getTag _ = Nothing -- 2016 Day 2 Part 2 has a malformed `...` tag that -- causes tagsoup to choke. this converts all except for the -- first one to be . @@ -332,90 +294,4 @@ cleanDoubleTitle t = case T.splitOn "" t of x:xs -> x <> "" <> T.intercalate "" xs [] -> "" -- this shouldn't ever happen because splitOn is always non-empty - --- | Parse 'Text' into a 'SubmitRes'. -parseSubmitRes :: Text -> SubmitRes -parseSubmitRes = either (SubUnknown . P.errorBundlePretty) id - . P.runParser choices "Submission Response" - . mconcat - . mapMaybe deTag - . H.parseTags - where - deTag (H.TagText t) = Just t - deTag _ = Nothing - choices = asum [ P.try parseCorrect P. "Correct" - , P.try parseIncorrect P. "Incorrect" - , P.try parseWait P. "Wait" - , parseInvalid P. "Invalid" - ] - parseCorrect :: P.Parsec Void Text SubmitRes - parseCorrect = do - _ <- P.manyTill P.anySingle (P.string' "that's the right answer") P. "Right answer" - r <- optional . (P. "Rank") . P.try $ do - P.manyTill P.anySingle (P.string' "rank") - *> P.skipMany (P.satisfy (not . isDigit)) - P.decimal - pure $ SubCorrect r - parseIncorrect = do - _ <- P.manyTill P.anySingle (P.string' "that's not the right answer") P. "Not the right answer" - hint <- optional . (P. "Hint") . P.try $ do - P.manyTill P.anySingle "your answer is" *> P.space1 - P.takeWhile1P (Just "dot") (/= '.') - P.manyTill P.anySingle (P.string' "wait") *> P.space1 - waitAmt <- (1 <$ P.string' "one") <|> P.decimal - pure $ SubIncorrect (waitAmt * 60) (T.unpack <$> hint) - parseWait = do - _ <- P.manyTill P.anySingle (P.string' "an answer too recently") P. "An answer too recently" - P.skipMany (P.satisfy (not . isDigit)) - m <- optional . (P. "Delay minutes") . P.try $ - P.decimal <* P.char 'm' <* P.space1 - s <- P.decimal <* P.char 's' P. "Delay seconds" - pure . SubWait $ maybe 0 (* 60) m + s - parseInvalid = SubInvalid <$ P.manyTill P.anySingle (P.string' "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/src/Advent/Types.hs b/src/Advent/Types.hs new file mode 100644 --- /dev/null +++ b/src/Advent/Types.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : Advent.Types +-- Copyright : (c) Justin Le 2019 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Data types used for the underlying API. +-- +-- @since 0.2.3.0 +-- + +module Advent.Types ( + -- * Types + Day(..) + , Part(..) + , SubmitInfo(..) + , SubmitRes(..), showSubmitRes + , PublicCode(..) + , Leaderboard(..) + , LeaderboardMember(..) + , Rank(..) + , DailyLeaderboard(..) + , DailyLeaderboardMember(..) + , GlobalLeaderboard(..) + , GlobalLeaderboardMember(..) + -- * Util + , mkDay, mkDay_, dayInt + , partInt + , partChar + -- * Internal + , parseSubmitRes + ) where + +import Control.Applicative +import Data.Aeson +import Data.Aeson.Types +import Data.Char +import Data.Finite +import Data.Foldable +import Data.Functor.Classes +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map (Map) +import Data.Maybe +import Data.Text (Text) +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Typeable +import Data.Void +import GHC.Generics +import Servant.API +import Text.Printf +import Text.Read (readMaybe) +import qualified Data.Text as T +import qualified Text.HTML.TagSoup as H +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as P +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) + +-- | Ranking between 1 to 100, for daily and global leaderboards +newtype Rank = Rank { getRank :: Finite 100 } + deriving (Show, Eq, Ord, Typeable, Generic) + +-- | Single daily leaderboard position +data DailyLeaderboardMember = DLBM + { dlbmRank :: Rank + , dlbmTime :: UTCTime + , dlbmUser :: Either Integer Text + , dlbmLink :: Maybe Text + , dlbmImage :: Maybe Text + , dlbmSupporter :: Bool + } + deriving (Show, Eq, Ord, Typeable, Generic) + +-- | Daily leaderboard, containing Star 1 and Star 2 completions +data DailyLeaderboard = DLB { + dlbStar1 :: Map Rank DailyLeaderboardMember + , dlbStar2 :: Map Rank DailyLeaderboardMember + } + deriving (Show, Eq, Ord, Typeable, Generic) + +-- | Single global leaderboard position +data GlobalLeaderboardMember = GLBM + { glbmRank :: Rank + , glbmScore :: Integer + , glbmUser :: Either Integer Text + , glbmLink :: Maybe Text + , glbmImage :: Maybe Text + , glbmSupporter :: Bool + } + deriving (Show, Eq, Ord, Typeable, Generic) + +-- | Global leaderboard for the entire event +newtype GlobalLeaderboard = GLB { + glbMap :: Map Rank (Integer, NonEmpty GlobalLeaderboardMember) + } + 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 } + +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 + +instance ToJSONKey Rank where + toJSONKey = toJSONKeyText $ T.pack . show . (+ 1) . getFinite . getRank +instance FromJSONKey Rank where + fromJSONKey = FromJSONKeyTextParser (parseJSON . String) + +instance ToJSON Rank where + toJSON = String . T.pack . show . (+ 1) . getFinite . getRank +instance FromJSON Rank where + parseJSON = withText "Rank" $ \t -> + case readMaybe (T.unpack t) of + Nothing -> fail "No read rank" + Just i -> case packFinite (i - 1) of + Nothing -> fail "Rank out of range" + Just d -> pure $ Rank d + +instance ToJSON DailyLeaderboard where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = camelTo2 '-' . drop 3 } +instance FromJSON DailyLeaderboard where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelTo2 '-' . drop 3 } + +instance ToJSON GlobalLeaderboard where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = camelTo2 '-' . drop 3 } +instance FromJSON GlobalLeaderboard where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelTo2 '-' . drop 3 } + +instance ToJSON DailyLeaderboardMember where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = camelTo2 '-' . drop 4 } +instance FromJSON DailyLeaderboardMember where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelTo2 '-' . drop 4 } + +instance ToJSON GlobalLeaderboardMember where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = camelTo2 '-' . drop 4 } +instance FromJSON GlobalLeaderboardMember where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelTo2 '-' . drop 4 } + +-- | Parse 'Text' into a 'SubmitRes'. +parseSubmitRes :: Text -> SubmitRes +parseSubmitRes = either (SubUnknown . P.errorBundlePretty) id + . P.runParser choices "Submission Response" + . mconcat + . mapMaybe deTag + . H.parseTags + where + deTag (H.TagText t) = Just t + deTag _ = Nothing + choices = asum [ P.try parseCorrect P. "Correct" + , P.try parseIncorrect P. "Incorrect" + , P.try parseWait P. "Wait" + , parseInvalid P. "Invalid" + ] + parseCorrect :: P.Parsec Void Text SubmitRes + parseCorrect = do + _ <- P.manyTill P.anySingle (P.string' "that's the right answer") P. "Right answer" + r <- optional . (P. "Rank") . P.try $ do + P.manyTill P.anySingle (P.string' "rank") + *> P.skipMany (P.satisfy (not . isDigit)) + P.decimal + pure $ SubCorrect r + parseIncorrect = do + _ <- P.manyTill P.anySingle (P.string' "that's not the right answer") P. "Not the right answer" + hint <- optional . (P. "Hint") . P.try $ do + P.manyTill P.anySingle "your answer is" *> P.space1 + P.takeWhile1P (Just "dot") (/= '.') + P.manyTill P.anySingle (P.string' "wait") *> P.space1 + waitAmt <- (1 <$ P.string' "one") <|> P.decimal + pure $ SubIncorrect (waitAmt * 60) (T.unpack <$> hint) + parseWait = do + _ <- P.manyTill P.anySingle (P.string' "an answer too recently") P. "An answer too recently" + P.skipMany (P.satisfy (not . isDigit)) + m <- optional . (P. "Delay minutes") . P.try $ + P.decimal <* P.char 'm' <* P.space1 + s <- P.decimal <* P.char 's' P. "Delay seconds" + pure . SubWait $ maybe 0 (* 60) m + s + parseInvalid = SubInvalid <$ P.manyTill P.anySingle (P.string' "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.API +import Advent.Types import Control.Monad import Data.List import System.Directory