advent-of-code-api 0.2.2.1 → 0.2.3.0

raw patch · 7 files changed

+658/−310 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• README.md +3/−2
• advent-of-code-api.cabal +3/−2
• src/Advent.hs +71/−6
• src/Advent/API.hs +175/−299
• src/Advent/Types.hs +392/−0
• test/Spec.hs +1/−1

@@ -1,6 +1,19 @@ Changelog ========= +Version 0.2.3.0+---------------++*November 21, 2019*++<https://github.com/mstksg/advent-of-code-api/releases/tag/v0.2.3.0>++*   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 --------------- 

@@ -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

@@ -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

@@ -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

@@ -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 @<article>@ 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 @<article>@ tags.+type Articles = HTMLTags "article" -instance Accept Articles where+-- | Interpret a response as a list of HTML 'Text' found in @<div>@ 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 <article>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 `<span>...</title>` tag that     -- causes tagsoup to choke.  this converts all </title> except for the     -- first one to be <span>.@@ -332,90 +294,4 @@     cleanDoubleTitle t = case T.splitOn "</title>" t of         x:xs -> x <> "</title>" <> T.intercalate "</span>" 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' 

@@ -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'+

@@ -1,6 +1,6 @@ {-# LANGUAGE ViewPatterns #-} -import           Advent.API+import           Advent.Types import           Control.Monad import           Data.List import           System.Directory