{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ViewPatterns #-}
module Advent (
AoC(..)
, Part(..)
, AoCOpts(..)
, SubmitRes(..), showSubmitRes
, runAoC
, defaultAoCOpts
, AoCError(..)
, challengeReleaseTime
, timeToRelease
, challengeReleased
, mkDay, mkDay_, dayInt
, aocDay
, partChar, partInt
, setAoCThrottleLimit, getAoCThrottleLimit
, parseSubmitRes
, processHTML
) where
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.Maybe
import Data.Set (Set)
import Data.Text (Text)
import Data.Time
import Data.Typeable
import GHC.Generics (Generic)
import Network.Curl
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
initialThrottleLimit :: Int
initialThrottleLimit = 100
aocThrottler :: Throttler
aocThrottler = Unsafe.unsafePerformIO $ newThrottler initialThrottleLimit
{-# NOINLINE aocThrottler #-}
setAoCThrottleLimit :: Int -> IO ()
setAoCThrottleLimit = setLimit aocThrottler
getAoCThrottleLimit :: IO Int
getAoCThrottleLimit = getLimit aocThrottler
data SubmitRes
= SubCorrect (Maybe Integer)
| SubIncorrect Int (Maybe String)
| SubWait Int
| SubInvalid
| SubUnknown String
deriving (Show, Read, Eq, Ord, Typeable, Generic)
data Part = Part1 | Part2
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)
data AoC :: Type -> Type where
AoCPrompt
:: Finite 25
-> AoC (Map Part Text)
AoCInput :: Finite 25 -> AoC Text
AoCSubmit
:: Finite 25
-> Part
-> String
-> AoC (Text, SubmitRes)
deriving instance Show (AoC a)
deriving instance Typeable (AoC a)
aocDay :: AoC a -> Finite 25
aocDay (AoCPrompt d ) = d
aocDay (AoCInput d ) = d
aocDay (AoCSubmit d _ _) = d
data AoCError
= AoCCurlError CurlCode String
| AoCReleaseError NominalDiffTime
| AoCThrottleError
deriving (Show, Typeable, Generic)
instance Exception AoCError
data AoCOpts = AoCOpts
{
_aSessionKey :: String
, _aYear :: Integer
, _aCache :: Maybe FilePath
, _aForce :: Bool
, _aThrottle :: Int
, _aCurlOpts :: [CurlOption]
}
deriving (Show, Typeable, Generic)
defaultAoCOpts
:: Integer
-> String
-> AoCOpts
defaultAoCOpts y s = AoCOpts
{ _aSessionKey = s
, _aYear = y
, _aCache = Nothing
, _aForce = False
, _aThrottle = 3000000
, _aCurlOpts = []
}
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)
sessionKeyCookie :: String -> CurlOption
sessionKeyCookie = CurlCookie . printf "session=%s"
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
apiCache
:: Maybe String
-> AoC a
-> Maybe FilePath
apiCache sess = \case
AoCPrompt d -> Just $ printf "prompt/%02d.html" (dayInt d)
AoCInput d -> Just $ printf "input/%s%02d.txt" keyDir (dayInt d)
AoCSubmit{} -> Nothing
where
keyDir = case sess of
Nothing -> ""
Just s -> strip s ++ "/"
runAoC :: AoCOpts -> AoC a -> IO (Either AoCError a)
runAoC AoCOpts{..} a = do
(keyMayb, cacheDir) <- case _aCache of
Just c -> pure (Nothing, c)
Nothing -> (Just _aSessionKey,) . (</> "advent-of-code-api") <$> getTemporaryDirectory
let cacher = case apiCache keyMayb a of
Nothing -> id
Just fp -> cacheing (cacheDir </> fp) $
if _aForce
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
processAoC :: AoC a -> String -> a
processAoC = \case
AoCPrompt _ -> M.fromList
. zip [Part1 ..]
. processHTML
AoCInput{} -> T.pack
AoCSubmit{} -> (\o -> (o, parseSubmitRes o))
. fromMaybe ""
. listToMaybe
. processHTML
processHTML :: String -> [Text]
processHTML = map H.renderTree
. mapMaybe isArticle
. H.universeTree
. H.parseTree
. T.pack
where
isArticle :: TagTree Text -> Maybe [TagTree Text]
isArticle (TagBranch n _ ts) = ts <$ guard (n == "article")
isArticle _ = Nothing
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")
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)
, _slLoad = \str ->
let mp = decodeMap str
hasAll = S.null (expectedParts d `S.difference` M.keysSet mp)
in Right mp <$ guard hasAll
}
AoCInput{} -> SL { _slSave = either (const Nothing) Just
, _slLoad = Just . Right
}
AoCSubmit{} -> noCache
where
expectedParts :: Finite 25 -> Set Part
expectedParts n
| n == 24 = S.singleton Part1
| otherwise = S.fromDistinctAscList [Part1 ..]
sep = ">>>>>>>>>"
encodeMap mp = T.intercalate "\n" . concat $
[ maybeToList $ M.lookup Part1 mp
, [sep]
, maybeToList $ M.lookup Part2 mp
]
decodeMap xs = mkMap Part1 part1 <> mkMap Part2 part2
where
(part1, drop 1 -> part2) = span (/= sep) (T.lines xs)
mkMap p (T.intercalate "\n"->ln)
| T.null (T.strip ln) = M.empty
| otherwise = M.singleton p ln
mkDay :: Integer -> Maybe (Finite 25)
mkDay = packFinite . subtract 1
mkDay_ :: Integer -> Finite 25
mkDay_ = fromMaybe e . mkDay
where
e = errorWithoutStackTrace "Advent.mkDay_: Date out of range (1 - 25)"
timeToRelease
:: Integer
-> Finite 25
-> IO NominalDiffTime
timeToRelease y d = (challengeReleaseTime y d `diffUTCTime`) <$> getCurrentTime
challengeReleased
:: Integer
-> Finite 25
-> IO Bool
challengeReleased y = fmap (<= 0) . timeToRelease y
challengeReleaseTime
:: Integer
-> Finite 25
-> UTCTime
challengeReleaseTime y d = UTCTime (fromGregorian y 12 (fromIntegral (dayInt d)))
(5 * 60 * 60)
dayInt :: Finite 25 -> Integer
dayInt = (+ 1) . getFinite
partInt :: Part -> Int
partInt Part1 = 1
partInt Part2 = 2
partChar :: Part -> Char
partChar Part1 = 'a'
partChar Part2 = 'b'
strip :: String -> String
strip = T.unpack . T.strip . T.pack