{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ViewPatterns #-}
module Advent (
AoC(..)
, Part(..)
, Day(..)
, AoCOpts(..)
, SubmitRes(..), showSubmitRes
, runAoC
, runAoC_
, defaultAoCOpts
, AoCError(..)
, challengeReleaseTime
, timeToRelease
, challengeReleased
, mkDay, mkDay_, dayInt, pattern DayInt, _DayInt
, aocDay
, aocServerTime
, partChar, partInt
, fullDailyBoard
, setAoCThrottleLimit, getAoCThrottleLimit
, aocReq
, aocBase
) where
import Advent.API
import Advent.Cache
import Advent.Throttle
import Advent.Types
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Except
import Data.Kind
import Data.Map (Map)
import Data.Maybe
import Data.Set (Set)
import Data.Text (Text)
import Data.Time hiding (Day)
import Data.Typeable
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.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)
import Data.Functor
#else
import Data.Semigroup ((<>))
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap
#endif
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 AoC :: Type -> Type where
AoCPrompt
:: Day
-> AoC (Map Part Text)
AoCInput :: Day -> AoC Text
AoCSubmit
:: Day
-> Part
-> String
-> AoC (Text, SubmitRes)
AoCLeaderboard
:: Integer
-> AoC Leaderboard
AoCDailyLeaderboard
:: Day
-> AoC DailyLeaderboard
AoCGlobalLeaderboard
:: AoC GlobalLeaderboard
deriving instance Show (AoC a)
deriving instance Typeable (AoC a)
aocDay :: AoC a -> Maybe Day
aocDay (AoCPrompt d ) = Just d
aocDay (AoCInput d ) = Just d
aocDay (AoCSubmit d _ _ ) = Just d
aocDay (AoCLeaderboard _) = Nothing
aocDay (AoCDailyLeaderboard d) = Just d
aocDay AoCGlobalLeaderboard = Nothing
data AoCError
#if MIN_VERSION_servant_client_core(0,16,0)
= AoCClientError ClientError
#else
= AoCClientError ServantError
#endif
| AoCReleaseError NominalDiffTime
| AoCThrottleError
deriving (Show, Typeable, Generic)
instance Exception AoCError
data AoCOpts = AoCOpts
{
_aSessionKey :: String
, _aYear :: Integer
, _aCache :: Maybe FilePath
, _aForce :: Bool
, _aThrottle :: Int
}
deriving (Show, Typeable, Generic)
defaultAoCOpts
:: Integer
-> String
-> AoCOpts
defaultAoCOpts y s = AoCOpts
{ _aSessionKey = s
, _aYear = y
, _aCache = Nothing
, _aForce = False
, _aThrottle = 3000000
}
aocBase :: BaseUrl
aocBase = BaseUrl Https "adventofcode.com" 443 ""
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)
AoCDailyLeaderboard d -> let _ :<|> _ :<|> r :<|> _ = adventAPIClient yr
in r d
AoCGlobalLeaderboard -> let _ :<|> r :<|> _ :<|> _ = adventAPIClient yr
in r
apiCache
:: Maybe String
-> Integer
-> 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
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 -> ""
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
(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
(not (null _aSessionKey))
(not eventOver)
a
cacher . runExceptT $ do
forM_ (aocDay a) $ \d -> do
rel <- liftIO $ timeToRelease _aYear d
when (rel > 0) $
throwError $ AoCReleaseError rel
mtr <- liftIO
. throttling aocThrottler (max 1000000 _aThrottle)
$ runClientM (aocReq _aYear a) =<< aocClientEnv _aSessionKey
mcr <- maybe (throwError AoCThrottleError) pure mtr
either (throwError . AoCClientError) pure mcr
runAoC_ :: AoCOpts -> AoC a -> IO a
runAoC_ o = either throwIO pure <=< runAoC o
aocClientEnv :: String -> IO ClientEnv
aocClientEnv s = do
t <- getCurrentTime
v <- atomically . newTVar $ createCookieJar [c t]
mgr <- newTlsManager
pure $ ClientEnv mgr aocBase (Just v)
where
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
saverLoader
:: Bool
-> Bool
-> AoC a
-> SaverLoader (Either AoCError a)
saverLoader validToken evt = \case
AoCPrompt{} -> SL { _slSave = either (const Nothing) (Just . encodeMap)
, _slLoad = \str ->
let mp = decodeMap str
hasAll = S.null (expectedParts `S.difference` M.keysSet mp)
in Right mp <$ guard hasAll
}
AoCInput{} -> SL { _slSave = either (const Nothing) Just
, _slLoad = Just . Right
}
AoCSubmit{} -> noCache
AoCLeaderboard{} -> noCache
AoCDailyLeaderboard{} -> SL
{ _slSave = either (const Nothing) (Just . TL.toStrict . TL.decodeUtf8 . A.encode)
, _slLoad = \str -> do
r <- A.decode . TL.encodeUtf8 . TL.fromStrict $ str
guard $ fullDailyBoard r
pure $ Right r
}
AoCGlobalLeaderboard{} -> SL
{ _slSave = either
(const Nothing)
(Just . TL.toStrict . TL.decodeUtf8 . A.encode @(Bool, GlobalLeaderboard) . (evt,))
, _slLoad = \str -> do
(evt', lb) <- A.decode @(Bool, GlobalLeaderboard) . TL.encodeUtf8 . TL.fromStrict $ str
guard $ not evt'
pure $ Right lb
}
where
expectedParts :: Set Part
expectedParts
| validToken = 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
timeToRelease
:: Integer
-> Day
-> IO NominalDiffTime
timeToRelease y d = (challengeReleaseTime y d `diffUTCTime`) <$> getCurrentTime
challengeReleased
:: Integer
-> Day
-> IO Bool
challengeReleased y = fmap (<= 0) . timeToRelease y
challengeReleaseTime
:: Integer
-> Day
-> UTCTime
challengeReleaseTime y d = UTCTime (fromGregorian y 12 (fromIntegral (dayInt d)))
(5 * 60 * 60)
aocServerTime :: IO LocalTime
aocServerTime = utcToLocalTime (read "EST") <$> getCurrentTime
strip :: String -> String
strip = T.unpack . T.strip . T.pack