{-# LANGUAGE CPP #-}
{-# 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(..)
, Day(..)
, AoCOpts(..)
, SubmitRes(..), showSubmitRes
, Leaderboard(..), LeaderboardMember(..)
, runAoC
, defaultAoCOpts
, AoCError(..)
, challengeReleaseTime
, timeToRelease
, challengeReleased
, mkDay, mkDay_, dayInt
, aocDay
, partChar, partInt
, setAoCThrottleLimit, getAoCThrottleLimit
, aocReq
, aocBase
) where
import Advent.API
import Advent.Cache
import Advent.Throttle
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.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)
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
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
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)
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
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 _aYear a of
Nothing -> id
Just fp -> cacheing (cacheDir </> fp) $
if _aForce
then noCache
else saverLoader 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
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 :: 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
AoCLeaderboard{} -> noCache
where
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
, [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)
strip :: String -> String
strip = T.unpack . T.strip . T.pack