{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
module Advent.API (
Day(..)
, Part(..)
, SubmitInfo(..)
, SubmitRes(..), showSubmitRes
, PublicCode(..)
, Leaderboard(..)
, LeaderboardMember(..)
, AdventAPI
, adventAPI
, adventAPIClient
, adventAPIPuzzleClient
, mkDay, mkDay_, dayInt
, partInt
, partChar
, processHTML
, parseSubmitRes
, Articles
, FromArticles(..)
, RawText
) where
import Control.Applicative
import Control.Monad
import Data.Aeson
import Data.Bifunctor
import Data.Char
import Data.Finite
import Data.Foldable
import Data.Functor.Classes
import Data.Map (Map)
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Typeable
import GHC.Generics
import Servant.API
import Servant.Client
import Text.HTML.TagSoup.Tree (TagTree(..))
import Text.Printf
import Text.Read (readMaybe)
import qualified Data.Attoparsec.Text as P
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Media as M
import qualified Text.HTML.TagSoup as H
import qualified Text.HTML.TagSoup.Tree as H
import qualified Web.FormUrlEncoded as WF
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup ((<>))
#endif
newtype Day = Day { dayFinite :: Finite 25 }
deriving (Eq, Ord, Enum, Bounded, Typeable, Generic)
instance Show Day where
showsPrec = showsUnaryWith (\d -> showsPrec d . dayInt) "mkDay"
data Part = Part1 | Part2
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)
data SubmitInfo = SubmitInfo
{ siLevel :: Part
, siAnswer :: String
}
deriving (Show, Read, Eq, Ord, Typeable, Generic)
data SubmitRes
= SubCorrect (Maybe Integer)
| SubIncorrect Int (Maybe String)
| SubWait Int
| SubInvalid
| SubUnknown String
deriving (Show, Read, Eq, Ord, Typeable, Generic)
newtype PublicCode = PublicCode { getPublicCode :: Integer }
deriving (Show, Read, Eq, Ord, Typeable, Generic)
data Leaderboard = LB
{ lbEvent :: Integer
, lbOwnerId :: Integer
, lbMembers :: Map Integer LeaderboardMember
}
deriving (Show, Eq, Ord, Typeable, Generic)
data LeaderboardMember = LBM
{ lbmGlobalScore :: Integer
, lbmName :: Maybe Text
, lbmLocalScore :: Integer
, lbmId :: Integer
, lbmLastStarTS :: Maybe UTCTime
, lbmStars :: Int
, lbmCompletion :: Map Day (Map Part UTCTime)
}
deriving (Show, Eq, Ord, Typeable, Generic)
instance ToHttpApiData Part where
toUrlPiece = T.pack . show . partInt
toQueryParam = toUrlPiece
instance ToHttpApiData Day where
toUrlPiece = T.pack . show . dayInt
toQueryParam = toUrlPiece
instance ToHttpApiData PublicCode where
toUrlPiece = (<> ".json") . T.pack . show . getPublicCode
toQueryParam = toUrlPiece
instance WF.ToForm SubmitInfo where
toForm = WF.genericToForm WF.FormOptions
{ WF.fieldLabelModifier = camelTo2 '-' . drop 2 }
data RawText
instance Accept RawText where
contentType _ = "text" M.// "plain"
instance MimeUnrender RawText Text where
mimeUnrender _ = first show . T.decodeUtf8' . BSL.toStrict
data Articles
class FromArticles a where
fromArticles :: [Text] -> a
instance Accept Articles where
contentType _ = "text" M.// "html"
instance FromArticles a => MimeUnrender Articles a where
mimeUnrender _ = fmap fromArticles
. bimap show processHTML
. T.decodeUtf8'
. BSL.toStrict
instance FromArticles [Text] where
fromArticles = id
instance FromArticles Text where
fromArticles = T.unlines
instance (Ord a, Enum a, Bounded a) => FromArticles (Map a Text) where
fromArticles = M.fromList . zip [minBound ..]
instance (FromArticles a, FromArticles b) => FromArticles (a :<|> b) where
fromArticles xs = fromArticles xs :<|> fromArticles xs
instance FromArticles SubmitRes where
fromArticles = parseSubmitRes . fold . listToMaybe
instance FromJSON Leaderboard where
parseJSON = withObject "Leaderboard" $ \o ->
LB <$> (strInt =<< (o .: "event"))
<*> (strInt =<< (o .: "owner_id"))
<*> o .: "members"
where
strInt t = case readMaybe t of
Nothing -> fail "bad int"
Just i -> pure i
instance FromJSON LeaderboardMember where
parseJSON = withObject "LeaderboardMember" $ \o ->
LBM <$> o .: "global_score"
<*> optional (o .: "name")
<*> o .: "local_score"
<*> (strInt =<< (o .: "id"))
<*> optional (fromEpoch =<< (o .: "last_star_ts"))
<*> o .: "stars"
<*> (do cdl <- o .: "completion_day_level"
(traverse . traverse) ((fromEpoch =<<) . (.: "get_star_ts")) cdl
)
where
strInt t = case readMaybe t of
Nothing -> fail "bad int"
Just i -> pure i
fromEpoch t = case readMaybe t of
Nothing -> fail "bad stamp"
Just i -> pure . posixSecondsToUTCTime $ fromInteger i
instance FromJSONKey Day where
fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
instance FromJSONKey Part where
fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
instance FromJSON Part where
parseJSON = withText "Part" $ \case
"1" -> pure Part1
"2" -> pure Part2
_ -> fail "Bad part"
instance FromJSON Day where
parseJSON = withText "Day" $ \t ->
case readMaybe (T.unpack t) of
Nothing -> fail "No read day"
Just i -> case mkDay i of
Nothing -> fail "Day out of range"
Just d -> pure d
type AdventAPI =
Capture "year" Integer
:> ("day" :> Capture "day" Day
:> (Get '[Articles] (Map Part Text)
:<|> "input" :> Get '[RawText] Text
:<|> "answer"
:> ReqBody '[FormUrlEncoded] SubmitInfo
:> Post '[Articles] (Text :<|> SubmitRes)
)
:<|> "leaderboard" :> "private" :> "view"
:> Capture "code" PublicCode
:> Get '[JSON] Leaderboard
)
adventAPI :: Proxy AdventAPI
adventAPI = Proxy
adventAPIClient
:: Integer
-> (Day -> ClientM (Map Part Text) :<|> ClientM Text :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes)) )
:<|> (PublicCode -> ClientM Leaderboard)
adventAPIClient = client adventAPI
adventAPIPuzzleClient
:: Integer
-> Day
-> ClientM (Map Part Text) :<|> ClientM Text :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes))
adventAPIPuzzleClient y = pis
where
pis :<|> _ = adventAPIClient y
processHTML :: Text -> [Text]
processHTML = map H.renderTree
. mapMaybe isArticle
. H.universeTree
. H.parseTree
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"
, fail "No option recognized"
]
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
dayInt :: Day -> Integer
dayInt = (+ 1) . getFinite . dayFinite
partInt :: Part -> Int
partInt Part1 = 1
partInt Part2 = 2
mkDay :: Integer -> Maybe Day
mkDay = fmap Day . packFinite . subtract 1
mkDay_ :: Integer -> Day
mkDay_ = fromMaybe e . mkDay
where
e = errorWithoutStackTrace "Advent.mkDay_: Date out of range (1 - 25)"
partChar :: Part -> Char
partChar Part1 = 'a'
partChar Part2 = 'b'