{-# 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
) where
import Advent.Cache
import Advent.Throttle
import Control.Exception
import Control.Monad.Except
import Data.Char
import Data.Finite
import Data.Kind
import Data.Map (Map)
import Data.Maybe
import Data.Semigroup
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.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
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 (Maybe String)
| SubWait
| SubInvalid
| SubUnknown
deriving (Show, 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.yaml" (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 -> [T.Text]
processHTML = map (TL.toStrict . TL.intercalate "\n" . map H.render)
. mapMaybe isArticle
. foldMap universe
. listToMaybe
. H.parseDOM True
. TL.pack
where
isArticle (H.NodeElement (H.Element{..}))
= eltChildren <$ guard (eltName == "article")
isArticle _
= Nothing
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
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 = ' '
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"
SubInvalid -> "Invalid"
SubUnknown -> "Unknown"
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)"
universe :: H.Node -> [H.Node]
universe = ($ []) . appEndo . go
where
go :: H.Node -> Endo [H.Node]
go (H.NodeElement (H.Element{..})) = Endo (eltChildren ++)
<> foldMap go eltChildren
go (H.NodeContent _ ) = mempty
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