{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}

-- |
-- Module      : Advent.API
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Raw Servant API for Advent of Code.  Can be useful for building mock
-- servers, generating documentation and other servanty things, or
-- low-level raw requests.
--
-- If you use this to make requests directly, please use responsibly: do
-- not make automated requests more than once per day and throttle all
-- manual requestes.  See notes in "Advent".
--
-- @since 0.2.0.0
--

module Advent.API (
  -- * Servant API
    AdventAPI
  , adventAPI
  , adventAPIClient
  , adventAPIPuzzleClient
  -- * Types
  , HTMLTags
  , FromTags(..)
  , Articles
  , Divs
  , Scripts
  , RawText
  -- * Internal
  , processHTML
  ) where

import           Advent.Types
import           Control.Applicative
import           Control.Monad
import           Control.Monad.State
import           Data.Bifunctor
import           Data.Char
import           Data.Finite
import           Data.Foldable
import           Data.List.NonEmpty     (NonEmpty(..))
import           Data.Map               (Map)
import           Data.Maybe
import           Data.Ord
import           Data.Proxy
import           Data.Text              (Text)
import           Data.Time hiding       (Day)
import           GHC.TypeLits
import           Servant.API
import           Servant.Client
import           Text.HTML.TagSoup.Tree (TagTree(..))
import           Text.Read              (readMaybe)
import qualified Data.ByteString.Lazy   as BSL
import qualified Data.List.NonEmpty     as NE
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

#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup ((<>))
#endif

#if !MIN_VERSION_time(1,9,0)
import           Data.Time.LocalTime.Compat
#endif

-- | Raw "text/plain" MIME type
data RawText

instance Accept RawText where
    contentType :: Proxy RawText -> MediaType
contentType Proxy RawText
_ = ByteString
"text" ByteString -> ByteString -> MediaType
M.// ByteString
"plain"

instance MimeUnrender RawText Text where
    mimeUnrender :: Proxy RawText -> ByteString -> Either String Text
mimeUnrender Proxy RawText
_ = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict

-- | Interpret repsonse as a list of HTML 'T.Text' found in the given type of
-- tag
--
-- @since 0.2.3.0
data HTMLTags (tag :: Symbol)

-- | Interpret a response as a list of HTML 'T.Text' found in @<article>@ tags.
type Articles = HTMLTags "article"

-- | Interpret a response as a list of HTML 'T.Text' found in @<div>@ tags.
--
-- @since 0.2.3.0
type Divs     = HTMLTags "div"

-- | Interpret a response as a list of HTML 'T.Text' found in @<script>@ tags.
type Scripts = HTMLTags "script"

-- | Class for interpreting a list of 'T.Text' in tags to some desired
-- output.
--
-- @since 0.2.3.0
class FromTags tag a where
    fromTags :: p tag -> [Text] -> Maybe a

instance Accept (HTMLTags cls) where
    contentType :: Proxy (HTMLTags cls) -> MediaType
contentType Proxy (HTMLTags cls)
_ = ByteString
"text" ByteString -> ByteString -> MediaType
M.// ByteString
"html"

instance (FromTags tag a, KnownSymbol tag) => MimeUnrender (HTMLTags tag) a where
    mimeUnrender :: Proxy (HTMLTags tag) -> ByteString -> Either String a
mimeUnrender Proxy (HTMLTags tag)
_ ByteString
str = do
      Text
x <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$ ByteString
str
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left String
"No parse") forall (f :: * -> *) a. Applicative f => a -> f a
pure
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (tag :: k) a (p :: k -> *).
FromTags tag a =>
p tag -> [Text] -> Maybe a
fromTags (forall {k} (t :: k). Proxy t
Proxy @tag)
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> [Text]
processHTML (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @tag))
         forall a b. (a -> b) -> a -> b
$ Text
x

instance FromTags cls [Text] where
    fromTags :: forall (p :: k -> *). p cls -> [Text] -> Maybe [Text]
fromTags p cls
_ = forall a. a -> Maybe a
Just

instance FromTags cls Text where
    fromTags :: forall (p :: k -> *). p cls -> [Text] -> Maybe Text
fromTags p cls
_ = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines

instance (Ord a, Enum a, Bounded a) => FromTags cls (Map a Text) where
    fromTags :: forall (p :: k -> *). p cls -> [Text] -> Maybe (Map a Text)
fromTags p cls
_ = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [forall a. Bounded a => a
minBound ..]

instance (FromTags cls a, FromTags cls b) => FromTags cls (a :<|> b) where
    fromTags :: forall (p :: k -> *). p cls -> [Text] -> Maybe (a :<|> b)
fromTags p cls
p [Text]
xs = forall a b. a -> b -> a :<|> b
(:<|>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (tag :: k) a (p :: k -> *).
FromTags tag a =>
p tag -> [Text] -> Maybe a
fromTags p cls
p [Text]
xs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {k} (tag :: k) a (p :: k -> *).
FromTags tag a =>
p tag -> [Text] -> Maybe a
fromTags p cls
p [Text]
xs

instance FromTags "article" SubmitRes where
    fromTags :: forall (p :: Symbol -> *). p "article" -> [Text] -> Maybe SubmitRes
fromTags p "article"
_ = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SubmitRes
parseSubmitRes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe

instance FromTags "div" DailyLeaderboard where
    fromTags :: forall (p :: Symbol -> *).
p "div" -> [Text] -> Maybe DailyLeaderboard
fromTags p "div"
_ = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DailyLeaderboardMember] -> DailyLeaderboard
assembleDLB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe DailyLeaderboardMember
parseMember
      where
        parseMember :: Text -> Maybe DailyLeaderboardMember
        parseMember :: Text -> Maybe DailyLeaderboardMember
parseMember Text
contents = do
            Rank
dlbmRank <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Finite 100 -> Rank
Rank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). KnownNat n => Integer -> Maybe (Finite n)
packFinite forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Integer
1
                    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
                    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"span" (forall a. a -> Maybe a
Just Text
"leaderboard-position")
            NominalDiffTime
dlbmDecTime <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalTime -> NominalDiffTime
mkDiff
                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%b %d  %H:%M:%S"
                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
                       forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"span" (forall a. a -> Maybe a
Just Text
"leaderboard-time")
            Either Integer Text
dlbmUser <- [TagTree Text] -> Maybe (Either Integer Text)
eitherUser [TagTree Text]
tr
            forall (f :: * -> *) a. Applicative f => a -> f a
pure DLBM{Bool
Maybe Text
Either Integer Text
NominalDiffTime
Rank
dlbmSupporter :: Bool
dlbmImage :: Maybe Text
dlbmLink :: Maybe Text
dlbmUser :: Either Integer Text
dlbmDecTime :: NominalDiffTime
dlbmRank :: Rank
dlbmImage :: Maybe Text
dlbmSupporter :: Bool
dlbmLink :: Maybe Text
dlbmUser :: Either Integer Text
dlbmDecTime :: NominalDiffTime
dlbmRank :: Rank
..}
          where
            dlbmLink :: Maybe Text
dlbmLink      = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"href" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"a" forall a. Maybe a
Nothing
            dlbmSupporter :: Bool
dlbmSupporter = Text
"AoC++" Text -> Text -> Bool
`T.isInfixOf` Text
contents
            dlbmImage :: Maybe Text
dlbmImage     = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"src" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"img" forall a. Maybe a
Nothing
            tr :: [TagTree Text]
tr  = forall str. StringLike str => str -> [TagTree str]
H.parseTree Text
contents
            uni :: [TagTree Text]
uni = forall str. [TagTree str] -> [TagTree str]
H.universeTree [TagTree Text]
tr
        assembleDLB :: [DailyLeaderboardMember] -> DailyLeaderboard
assembleDLB = DailyLeaderboard -> DailyLeaderboard
flipper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe (Maybe Rank)
-> DailyLeaderboard
-> DailyLeaderboardMember
-> (Maybe (Maybe Rank), DailyLeaderboard)
go) (forall a. Maybe a
Nothing, Map Rank DailyLeaderboardMember
-> Map Rank DailyLeaderboardMember -> DailyLeaderboard
DLB forall k a. Map k a
M.empty forall k a. Map k a
M.empty)
          where
            flipper :: DailyLeaderboard -> DailyLeaderboard
flipper dlb :: DailyLeaderboard
dlb@(DLB Map Rank DailyLeaderboardMember
a Map Rank DailyLeaderboardMember
b)
              | forall k a. Map k a -> Bool
M.null Map Rank DailyLeaderboardMember
a  = Map Rank DailyLeaderboardMember
-> Map Rank DailyLeaderboardMember -> DailyLeaderboard
DLB Map Rank DailyLeaderboardMember
b Map Rank DailyLeaderboardMember
a
              | Bool
otherwise = DailyLeaderboard
dlb
            go :: Maybe (Maybe Rank)
-> DailyLeaderboard
-> DailyLeaderboardMember
-> (Maybe (Maybe Rank), DailyLeaderboard)
go Maybe (Maybe Rank)
counter DailyLeaderboard
dlb m :: DailyLeaderboardMember
m@DLBM{Bool
Maybe Text
Either Integer Text
NominalDiffTime
Rank
dlbmSupporter :: Bool
dlbmImage :: Maybe Text
dlbmLink :: Maybe Text
dlbmUser :: Either Integer Text
dlbmDecTime :: NominalDiffTime
dlbmRank :: Rank
dlbmSupporter :: DailyLeaderboardMember -> Bool
dlbmImage :: DailyLeaderboardMember -> Maybe Text
dlbmLink :: DailyLeaderboardMember -> Maybe Text
dlbmUser :: DailyLeaderboardMember -> Either Integer Text
dlbmDecTime :: DailyLeaderboardMember -> NominalDiffTime
dlbmRank :: DailyLeaderboardMember -> Rank
..} = case Maybe (Maybe Rank)
counter of
                Maybe (Maybe Rank)
Nothing      -> (Maybe (Maybe Rank), DailyLeaderboard)
dlb2
                Just Maybe Rank
Nothing -> forall {a}. (Maybe (Maybe a), DailyLeaderboard)
dlb1
                Just (Just Rank
i)
                  | Rank
dlbmRank forall a. Ord a => a -> a -> Bool
<= Rank
i -> forall {a}. (Maybe (Maybe a), DailyLeaderboard)
dlb1
                  | Bool
otherwise     -> (Maybe (Maybe Rank), DailyLeaderboard)
dlb2
              where
                dlb1 :: (Maybe (Maybe a), DailyLeaderboard)
dlb1 = (forall a. a -> Maybe a
Just forall a. Maybe a
Nothing        , DailyLeaderboard
dlb { dlbStar1 :: Map Rank DailyLeaderboardMember
dlbStar1 = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Rank
dlbmRank DailyLeaderboardMember
m (DailyLeaderboard -> Map Rank DailyLeaderboardMember
dlbStar1 DailyLeaderboard
dlb) })
                dlb2 :: (Maybe (Maybe Rank), DailyLeaderboard)
dlb2 = (forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just Rank
dlbmRank), DailyLeaderboard
dlb { dlbStar2 :: Map Rank DailyLeaderboardMember
dlbStar2 = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Rank
dlbmRank DailyLeaderboardMember
m (DailyLeaderboard -> Map Rank DailyLeaderboardMember
dlbStar2 DailyLeaderboard
dlb) })
        mkDiff :: LocalTime -> NominalDiffTime
mkDiff LocalTime
t = LocalTime
t LocalTime -> LocalTime -> NominalDiffTime
`diffLocalTime` LocalTime
decemberFirst
        decemberFirst :: LocalTime
decemberFirst = Day -> TimeOfDay -> LocalTime
LocalTime (Integer -> MonthOfYear -> MonthOfYear -> Day
fromGregorian Integer
1970 MonthOfYear
12 MonthOfYear
1) TimeOfDay
midnight

instance FromTags "div" GlobalLeaderboard where
    fromTags :: forall (p :: Symbol -> *).
p "div" -> [Text] -> Maybe GlobalLeaderboard
fromTags p "div"
_ = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Rank (Integer, NonEmpty GlobalLeaderboardMember)
-> GlobalLeaderboard
GLB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Down Integer) (NonEmpty GlobalLeaderboardMember)
-> Map Rank (Integer, NonEmpty GlobalLeaderboardMember)
reScore forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Semigroup a => a -> a -> a
(<>)
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\GlobalLeaderboardMember
x -> (forall a. a -> Down a
Down (GlobalLeaderboardMember -> Integer
glbmScore GlobalLeaderboardMember
x), GlobalLeaderboardMember
x forall a. a -> [a] -> NonEmpty a
:| []))
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe GlobalLeaderboardMember
parseMember
      where
        parseMember :: Text -> Maybe GlobalLeaderboardMember
        parseMember :: Text -> Maybe GlobalLeaderboardMember
parseMember Text
contents = do
            Integer
glbmScore <- forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
                     forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"span" (forall a. a -> Maybe a
Just Text
"leaderboard-totalscore")
            Either Integer Text
glbmUser <- [TagTree Text] -> Maybe (Either Integer Text)
eitherUser [TagTree Text]
tr
            forall (f :: * -> *) a. Applicative f => a -> f a
pure GLBM{Bool
Integer
Maybe Text
Either Integer Text
Rank
glbmSupporter :: Bool
glbmImage :: Maybe Text
glbmLink :: Maybe Text
glbmUser :: Either Integer Text
glbmRank :: Rank
glbmImage :: Maybe Text
glbmSupporter :: Bool
glbmLink :: Maybe Text
glbmRank :: Rank
glbmUser :: Either Integer Text
glbmScore :: Integer
glbmScore :: Integer
..}
          where
            glbmRank :: Rank
glbmRank      = Finite 100 -> Rank
Rank Finite 100
0
            glbmLink :: Maybe Text
glbmLink      = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"href" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"a" forall a. Maybe a
Nothing
            glbmSupporter :: Bool
glbmSupporter = Text
"AoC++" Text -> Text -> Bool
`T.isInfixOf` Text
contents
            glbmImage :: Maybe Text
glbmImage     = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"src" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"img" forall a. Maybe a
Nothing
            tr :: [TagTree Text]
tr  = forall str. StringLike str => str -> [TagTree str]
H.parseTree Text
contents
            uni :: [TagTree Text]
uni = forall str. [TagTree str] -> [TagTree str]
H.universeTree [TagTree Text]
tr
        reScore :: Map (Down Integer) (NonEmpty GlobalLeaderboardMember)
-> Map Rank (Integer, NonEmpty GlobalLeaderboardMember)
reScore = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NonEmpty GlobalLeaderboardMember
xs -> (GlobalLeaderboardMember -> Integer
glbmScore (forall a. NonEmpty a -> a
NE.head NonEmpty GlobalLeaderboardMember
xs), NonEmpty GlobalLeaderboardMember
xs))
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState Finite 100
0
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *} {t :: * -> *}.
(MonadState (Finite 100) m, Traversable t) =>
t GlobalLeaderboardMember -> m (Rank, t GlobalLeaderboardMember)
go
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
          where
            go :: t GlobalLeaderboardMember -> m (Rank, t GlobalLeaderboardMember)
go t GlobalLeaderboardMember
xs = do
              Finite 100
currScore <- forall s (m :: * -> *). MonadState s m => m s
get
              t GlobalLeaderboardMember
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t GlobalLeaderboardMember
xs forall a b. (a -> b) -> a -> b
$ \GlobalLeaderboardMember
x -> GlobalLeaderboardMember
x { glbmRank :: Rank
glbmRank = Finite 100 -> Rank
Rank Finite 100
currScore } forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a. Enum a => a -> a
succ
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (Finite 100 -> Rank
Rank Finite 100
currScore, t GlobalLeaderboardMember
xs')

instance FromTags "script" NextDayTime where
    fromTags :: forall (p :: Symbol -> *).
p "script" -> [Text] -> Maybe NextDayTime
fromTags p "script"
_ = (forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just NextDayTime
NoNextDayTime) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe NextDayTime
findNDT
      where
        -- var server_eta = 25112;
        -- var key = "2020-15-"+server_eta;
        findNDT :: Text -> Maybe NextDayTime
findNDT Text
body = do
          String
eta    <- Text -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
grabKey Text
"server_eta" Text
body
          Text
yd     <- Text -> Text -> Maybe Text
grabKey Text
"key" Text
body
          MonthOfYear
sec    <- forall a. Read a => String -> Maybe a
readMaybe String
eta
          Text
dayStr <- forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MonthOfYear -> [a] -> [a]
drop MonthOfYear
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"-" forall a b. (a -> b) -> a -> b
$ Text
yd
          Day
dy     <- Integer -> Maybe Day
mkDay forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
dayStr)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Day -> MonthOfYear -> NextDayTime
NextDayTime Day
dy MonthOfYear
sec
        grabKey :: Text -> Text -> Maybe Text
grabKey Text
t Text
str =
            forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> (Text, Text)
T.breakOn Text
";\n" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
t' (forall a b. (a, b) -> b
snd (Text -> Text -> (Text, Text)
T.breakOn Text
t' Text
str))
          where
            t' :: Text
t' = Text
"var " forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
" = "

-- | REST API of Advent of Code.
--
-- Note that most of these requests assume a "session=" cookie.
type AdventAPI =
      Capture "year" Integer
   :> (Get '[Scripts] NextDayTime
  :<|> "day" :> Capture "day" Day
             :> (Get '[Articles] (Map Part Text)
            :<|> "input" :> Get '[RawText] Text
            :<|> "answer"
                     :> ReqBody '[FormUrlEncoded] SubmitInfo
                     :> Post    '[Articles] (Text :<|> SubmitRes)
                )
  :<|> ("leaderboard"
    :> (Get '[Divs] GlobalLeaderboard
   :<|> "day"     :> Capture "day" Day :> Get '[Divs] DailyLeaderboard
   :<|> "private" :> "view"
                  :> Capture "code" PublicCode
                  :> Get '[JSON] Leaderboard
       ))
      )


-- | 'Proxy' used for /servant/ functions.
adventAPI :: Proxy AdventAPI
adventAPI :: Proxy AdventAPI
adventAPI = forall {k} (t :: k). Proxy t
Proxy

-- | 'ClientM' requests based on 'AdventAPI', generated by servant.
adventAPIClient
    :: Integer
    -> ClientM NextDayTime
  :<|> (Day -> ClientM (Map Part Text) :<|> ClientM Text :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes)) )
  :<|> ClientM GlobalLeaderboard
  :<|> (Day -> ClientM DailyLeaderboard)
  :<|> (PublicCode -> ClientM Leaderboard)
adventAPIClient :: Integer
-> ClientM NextDayTime
   :<|> ((Day
          -> ClientM (Map Part Text)
             :<|> (ClientM Text
                   :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes))))
         :<|> (ClientM GlobalLeaderboard
               :<|> ((Day -> ClientM DailyLeaderboard)
                     :<|> (PublicCode -> ClientM Leaderboard))))
adventAPIClient = forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client Proxy AdventAPI
adventAPI

-- | A subset of 'adventAPIClient' for only puzzle-related API routes, not
-- leaderboard ones.
adventAPIPuzzleClient
    :: Integer
    -> Day
    -> ClientM (Map Part Text) :<|> ClientM Text :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes))
adventAPIPuzzleClient :: Integer
-> Day
-> ClientM (Map Part Text)
   :<|> (ClientM Text
         :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes)))
adventAPIPuzzleClient Integer
y = Day
-> ClientM (Map Part Text)
   :<|> (ClientM Text
         :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes)))
pis
  where
    ClientM NextDayTime
_ :<|> Day
-> ClientM (Map Part Text)
   :<|> (ClientM Text
         :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes)))
pis :<|> ClientM GlobalLeaderboard
:<|> ((Day -> ClientM DailyLeaderboard)
      :<|> (PublicCode -> ClientM Leaderboard))
_ = Integer
-> ClientM NextDayTime
   :<|> ((Day
          -> ClientM (Map Part Text)
             :<|> (ClientM Text
                   :<|> (SubmitInfo -> ClientM (Text :<|> SubmitRes))))
         :<|> (ClientM GlobalLeaderboard
               :<|> ((Day -> ClientM DailyLeaderboard)
                     :<|> (PublicCode -> ClientM Leaderboard))))
adventAPIClient Integer
y

userNameNaked :: [TagTree Text] -> Maybe Text
userNameNaked :: [TagTree Text] -> Maybe Text
userNameNaked = (forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ \TagTree Text
x -> do
  TagLeaf (H.TagText (Text -> Text
T.strip->Text
u)) <- forall a. a -> Maybe a
Just TagTree Text
x
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
u
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
u
findTag :: [TagTree Text] -> Text -> Maybe Text -> Maybe (Text, [H.Attribute Text])
findTag :: [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
tag Maybe Text
cls = forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [TagTree Text]
uni forall a b. (a -> b) -> a -> b
$ \TagTree Text
x -> do
  TagBranch Text
tag' [(Text, Text)]
attr [TagTree Text]
cld <- forall a. a -> Maybe a
Just TagTree Text
x
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text
tag' forall a. Eq a => a -> a -> Bool
== Text
tag
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Text
cls forall a b. (a -> b) -> a -> b
$ \Text
c -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ (Text
"class", Text
c) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Text, Text)]
attr
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall str. StringLike str => [TagTree str] -> str
H.renderTree [TagTree Text]
cld, [(Text, Text)]
attr)
eitherUser :: [TagTree Text] -> Maybe (Either Integer Text)
eitherUser :: [TagTree Text] -> Maybe (Either Integer Text)
eitherUser [TagTree Text]
tr = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [
      forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TagTree Text] -> Maybe Text
userNameNaked [TagTree Text]
tr
    , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [TagTree Text] -> Maybe Text
userNameNaked forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall str. StringLike str => str -> [TagTree str]
H.parseTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
               forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"a" forall a. Maybe a
Nothing
    , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left  forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
               forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TagTree Text]
-> Text -> Maybe Text -> Maybe (Text, [(Text, Text)])
findTag [TagTree Text]
uni Text
"span" (forall a. a -> Maybe a
Just Text
"leaderboard-anon")
    ]
  where
    uni :: [TagTree Text]
uni = forall str. [TagTree str] -> [TagTree str]
H.universeTree [TagTree Text]
tr

-- | Process an HTML webpage into a list of all contents in the given tag
-- type
processHTML
    :: String       -- ^ tag type
    -> Text         -- ^ html
    -> [Text]
processHTML :: String -> Text -> [Text]
processHTML String
tag = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TagTree Text -> Maybe Text
getTag
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall str. [TagTree str] -> [TagTree str]
H.universeTree
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall str. Eq str => [Tag str] -> [TagTree str]
H.tagTree
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall str. [Tag str] -> [Tag str]
cleanTags
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall str. StringLike str => str -> [Tag str]
H.parseTags
  where
    getTag :: TagTree Text -> Maybe Text
    getTag :: TagTree Text -> Maybe Text
getTag (TagBranch Text
n [(Text, Text)]
_ [TagTree Text]
ts) = forall str. StringLike str => [TagTree str] -> str
H.renderTree [TagTree Text]
ts forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
n forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack String
tag)
    getTag TagTree Text
_                  = forall a. Maybe a
Nothing

-- | Some days, including:
--
-- * 2015 Day 6 Part 1
-- * 2016 Day 2 Part 2
--
-- Have malformed HTML tags; the first has @<p></code>@ and the second has
-- @<span></title>@.  This function cleans up all tags so that any closing
-- tags ignore their actual tag type and instead close the last opened tag
-- (if there is any).  If no tag is currently open then it just leaves it
-- unchanged.
cleanTags
    :: [H.Tag str]
    -> [H.Tag str]
cleanTags :: forall str. [Tag str] -> [Tag str]
cleanTags = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {f :: * -> *} {a}. MonadState [a] f => Tag a -> f (Tag a)
go
  where
    go :: Tag a -> f (Tag a)
go Tag a
t = case Tag a
t of
      H.TagOpen a
n [Attribute a]
_ -> Tag a
t forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (a
nforall a. a -> [a] -> [a]
:)
      H.TagClose a
_  -> forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        []   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Tag a
t
        a
m:[a]
ms -> forall str. str -> Tag str
H.TagClose a
m forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *). MonadState s m => s -> m ()
put [a]
ms
      Tag a
_             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Tag a
t