diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,17 @@ Changelog ========= +Version 0.1.2.0 +--------------- + +*December 7, 2018* + + + +* Fixed cache to store prompts at `.html` instead of `.yaml` +* `SubIncorrect` and `SubWait` now include fields for wait times. +* Re-implemented submission result parsers using *attoparsec* + Version 0.1.1.0 --------------- 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: f03eec5006d16762ac8fed0ec107a02d10becc827816ae9aff936b1c94e41493 +-- hash: 65e4e6828d9edc4bd8f8bb184773083c933cec327f7b7bcfaac1f90e763cf296 name: advent-of-code-api -version: 0.1.1.0 +version: 0.1.2.0 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. @@ -26,6 +26,15 @@ extra-source-files: README.md CHANGELOG.md + test-data/correct-rank.txt + test-data/correct.txt + test-data/incorrect-high.txt + test-data/incorrect-low.txt + test-data/incorrect-wait.txt + test-data/incorrect.txt + test-data/invalid.txt + test-data/wait.txt + test-data/wait2.txt source-repository head type: git @@ -42,7 +51,8 @@ src ghc-options: -Wall -Wcompat -Werror=incomplete-patterns build-depends: - base >=4.9 && <5 + attoparsec + , base >=4.9 && <5 , containers , curl , deepseq @@ -54,4 +64,21 @@ , text , time , uri-encode + default-language: Haskell2010 + +test-suite advent-of-code-api-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_advent_of_code_api + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit + , advent-of-code-api + , base >=4.9 && <5 + , directory + , filepath + , text default-language: Haskell2010 diff --git a/src/Advent.hs b/src/Advent.hs --- a/src/Advent.hs +++ b/src/Advent.hs @@ -71,31 +71,33 @@ import Advent.Cache import Advent.Throttle +import Control.Applicative 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.Semigroup -import Data.Set (Set) -import Data.Text (Text) +import Data.Set (Set) +import Data.Text (Text) import Data.Time import Data.Typeable -import GHC.Generics (Generic) +import GHC.Generics (Generic) import Network.Curl import System.Directory import System.FilePath import Text.Printf -import Text.Read (readMaybe) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Network.URI.Encode as URI -import qualified System.IO.Unsafe as Unsafe -import qualified Text.Taggy as H +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 Data.Text.Lazy as TL +import qualified Network.URI.Encode as URI +import qualified System.IO.Unsafe as Unsafe +import qualified Text.Taggy as H initialThrottleLimit :: Int initialThrottleLimit = 100 @@ -117,21 +119,21 @@ -- | Correct submission, including global rank (if reported, which -- usually happens if rank is under 1000) = SubCorrect (Maybe Integer) - -- | Incorrect submission. The 'Maybe' contains possible hints given - -- by the server (usually "too low" or "too high"). Check response - -- text for hints that the parser didn't catch, and also for the wait - -- time required before the next submission. - | SubIncorrect (Maybe String) + -- | 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. Check response text for wait time. - | SubWait + -- 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. - | SubUnknown - deriving (Show, Eq, Ord, Typeable, Generic) + -- | 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. @@ -281,7 +283,7 @@ -> AoC a -> Maybe FilePath apiCache sess = \case - AoCPrompt d -> Just $ printf "prompt/%02d.yaml" (dayInt d) + AoCPrompt d -> Just $ printf "prompt/%02d.html" (dayInt d) AoCInput d -> Just $ printf "input/%s%02d.txt" keyDir (dayInt d) AoCSubmit{} -> Nothing where @@ -345,41 +347,62 @@ . H.parseDOM True . TL.pack where - isArticle (H.NodeElement (H.Element{..})) + isArticle (H.NodeElement H.Element{..}) = eltChildren <$ guard (eltName == "article") isArticle _ = Nothing -- | Parse 'Text' into a 'SubmitRes'. parseSubmitRes :: Text -> SubmitRes -parseSubmitRes t - | "the right answer!" `T.isInfixOf` t = SubCorrect $ findRank t - | "too high" `T.isInfixOf` t = SubIncorrect $ Just "too high" - | "too low" `T.isInfixOf` t = SubIncorrect $ Just "too low" - | "not the right answer" `T.isInfixOf` t = SubIncorrect Nothing - | "an answer too recently" `T.isInfixOf` t = SubWait - | "solving the right level" `T.isInfixOf` t = SubInvalid - | otherwise = SubUnknown +parseSubmitRes = either SubUnknown id + . P.parseOnly choices + . mconcat + . mapMaybe deTag + . H.taggyWith True + . TL.fromStrict where - findRank = go . T.words . T.map onlyAlphaNum . T.toLower - where - go ("rank":n:_) = readMaybe $ T.unpack n - go (_ :ws ) = go ws - go [] = Nothing - onlyAlphaNum c - | isAlphaNum c = c - | otherwise = ' ' + 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 Nothing -> "Incorrect" - SubIncorrect (Just h) -> printf "Incorrect (%s)" h - SubWait -> "Wait" + 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 -> "Unknown" + SubUnknown r -> printf "Unknown (%s)" r saverLoader :: AoC a -> SaverLoader (Either AoCError a) saverLoader = \case diff --git a/test-data/correct-rank.txt b/test-data/correct-rank.txt new file mode 100644 --- /dev/null +++ b/test-data/correct-rank.txt @@ -0,0 +1,3 @@ +SubCorrect (Just 259) +That's the right answer! You are one gold star closer to fixing the time +stream. You got rank 259 on this star's leaderboard. diff --git a/test-data/correct.txt b/test-data/correct.txt new file mode 100644 --- /dev/null +++ b/test-data/correct.txt @@ -0,0 +1,3 @@ +SubCorrect Nothing +That's the right answer! You are one gold star closer to fixing the time +stream. diff --git a/test-data/incorrect-high.txt b/test-data/incorrect-high.txt new file mode 100644 --- /dev/null +++ b/test-data/incorrect-high.txt @@ -0,0 +1,4 @@ +SubIncorrect 60 (Just "too high") +That's not the right answer; your answer is too high. If you're stuck, there +are some general tips on the about page, or you can ask for hints on the +subreddit. Please wait one minute before trying again. (You guessed 218.) diff --git a/test-data/incorrect-low.txt b/test-data/incorrect-low.txt new file mode 100644 --- /dev/null +++ b/test-data/incorrect-low.txt @@ -0,0 +1,4 @@ +SubIncorrect 60 (Just "too low") +That's not the right answer; your answer is too low. If you're stuck, there +are some general tips on the about page, or you can ask for hints on the +subreddit. Please wait one minute before trying again. (You guessed 218.) diff --git a/test-data/incorrect-wait.txt b/test-data/incorrect-wait.txt new file mode 100644 --- /dev/null +++ b/test-data/incorrect-wait.txt @@ -0,0 +1,5 @@ +SubIncorrect 300 Nothing +That's not the right answer. If you're stuck, there are some general +tips on the about page, or you can ask for hints on the subreddit. +Because you have guessed incorrectly 4 times on this puzzle, please wait +5 minutes before trying again. (You guessed BAFNRWXHEKSQLUYGMIO.) diff --git a/test-data/incorrect.txt b/test-data/incorrect.txt new file mode 100644 --- /dev/null +++ b/test-data/incorrect.txt @@ -0,0 +1,7 @@ +SubIncorrect 60 Nothing +

That's not the right answer. If you're stuck, there are some +general tips on the about page, or you can ask for +hints on the subreddit. Please wait one minute before trying again. +(You guessed hello.)[Return to Day 2]

diff --git a/test-data/invalid.txt b/test-data/invalid.txt new file mode 100644 --- /dev/null +++ b/test-data/invalid.txt @@ -0,0 +1,2 @@ +SubInvalid +

You don't seem to be solving the right level. Did you already complete it? [Return to Day 1]

diff --git a/test-data/wait.txt b/test-data/wait.txt new file mode 100644 --- /dev/null +++ b/test-data/wait.txt @@ -0,0 +1,3 @@ +SubWait 136 +You gave an answer too recently; you have to wait after submitting an answer +before trying again. You have 2m 16s left to wait. diff --git a/test-data/wait2.txt b/test-data/wait2.txt new file mode 100644 --- /dev/null +++ b/test-data/wait2.txt @@ -0,0 +1,3 @@ +SubWait 2 +You gave an answer too recently; you have to wait after submitting an answer +before trying again. You have 2s left to wait. diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE ViewPatterns #-} + +import Advent +import Control.Monad +import Data.List +import System.Directory +import System.Exit +import System.FilePath +import Test.HUnit +import Text.Read (readMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T + +fileTest :: FilePath -> IO Test +fileTest fp = do + ls <- T.lines <$> T.readFile ("test-data" fp) + (T.strip->x, T.unlines->xs) <- maybe (fail "Empty test file") pure $ + uncons ls + + r <- maybe (fail "No parse expected result") pure $ + readMaybe (T.unpack x) + + pure . TestLabel fp $ r ~=? parseSubmitRes xs + +main :: IO () +main = do + tests <- fmap TestList + . mapM fileTest + =<< listDirectory "test-data" + c <- runTestTT tests + unless (failures c == 0) $ + exitFailure