advent-of-code-api 0.1.2.3 → 0.2.0.0

raw patch · 6 files changed

+578/−252 lines, 6 filesdep +aesondep +bytestringdep +http-api-datadep −curldep −uri-encodePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, bytestring, http-api-data, http-client, http-client-tls, http-media, servant, servant-client, servant-client-core, stm

Dependencies removed: curl, uri-encode

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• README.md +11/−5
• advent-of-code-api.cabal +21/−14
• src/Advent.hs +123/−232
• src/Advent/API.hs +409/−0
• test/Spec.hs +1/−1

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

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

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

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

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

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