You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
102 lines
3.2 KiB
Haskell
102 lines
3.2 KiB
Haskell
2 years ago
|
{-# LANGUAGE DataKinds #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE TypeOperators #-}
|
||
|
|
|
||
|
|
module AOC.API (
|
||
|
|
mkAocClient,
|
||
|
|
) where
|
||
|
|
|
||
|
|
import AOC.Types
|
||
|
|
import Control.Monad ((>=>))
|
||
|
|
import Data.ByteString qualified as BS
|
||
|
|
import Data.Proxy (Proxy (..))
|
||
|
|
import Data.Text qualified as T
|
||
|
|
import Data.Text.Encoding qualified as T
|
||
|
|
import Data.Time.Clock (addUTCTime, getCurrentTime)
|
||
|
|
import GHC.Conc (atomically, newTVar)
|
||
|
|
import Network.HTTP.Client (Cookie (..), createCookieJar)
|
||
|
|
import Network.HTTP.Client.TLS (newTlsManager)
|
||
|
|
import Network.HTTP.Media ((//), (/:))
|
||
|
|
import Servant.API
|
||
|
|
import Servant.Client hiding ((//), (/:))
|
||
|
|
|
||
|
|
mkAocClient :: String -> Int -> Int -> IO (IO T.Text, Submission -> IO Answer)
|
||
|
|
mkAocClient session year day = do
|
||
|
|
env <- mkAocEnv session
|
||
|
|
let aocInput :<|> aocSubmit = aocClient year day
|
||
|
|
f = flip runClientM env >=> pure . either (error . show) id
|
||
|
|
aocInput' = f aocInput
|
||
|
|
aocSubmit' = f . aocSubmit
|
||
|
|
return (aocInput', aocSubmit')
|
||
|
|
|
||
|
|
mkAocEnv :: String -> IO ClientEnv
|
||
|
|
mkAocEnv session = do
|
||
|
|
current <- getCurrentTime
|
||
|
|
manager <- newTlsManager
|
||
|
|
let
|
||
|
|
base = BaseUrl Https "adventofcode.com" 443 ""
|
||
|
|
env = mkClientEnv manager base
|
||
|
|
year = 60 * 60 * 24 * 365
|
||
|
|
expiry = addUTCTime year current
|
||
|
|
cookie =
|
||
|
|
Cookie
|
||
|
|
{ cookie_name = "session",
|
||
|
|
cookie_value = T.encodeUtf8 . T.pack $ session,
|
||
|
|
cookie_expiry_time = expiry,
|
||
|
|
cookie_domain = T.encodeUtf8 . T.pack $ baseUrlHost base,
|
||
|
|
cookie_path = "/",
|
||
|
|
cookie_creation_time = current,
|
||
|
|
cookie_last_access_time = current,
|
||
|
|
cookie_persistent = True,
|
||
|
|
cookie_host_only = True,
|
||
|
|
cookie_secure_only = True,
|
||
|
|
cookie_http_only = True
|
||
|
|
}
|
||
|
|
cookies <- atomically $ newTVar (createCookieJar [cookie])
|
||
|
|
return $ env {cookieJar = Just cookies}
|
||
|
|
|
||
|
|
aocClient :: Int -> Int -> (ClientM T.Text :<|> (Submission -> ClientM Answer))
|
||
|
|
aocClient = client (Proxy @API)
|
||
|
|
|
||
|
|
type API =
|
||
|
|
Capture "year" Int :>
|
||
|
|
("day" :> Capture "day" Int :>
|
||
|
|
(
|
||
|
|
-- GET /:year/day/:day/input
|
||
|
|
("input" :> Get '[RawPlainText] T.Text) :<|>
|
||
|
|
-- POST /:year/day/:day/answer level=<1|2>&answer=_
|
||
|
|
("answer" :> ReqBody '[FormUrlEncoded] Submission :> Post '[HTML] Answer)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
|
||
|
|
-- This is silly: https://github.com/haskell-servant/servant/issues/1002
|
||
|
|
data RawPlainText
|
||
|
|
|
||
|
|
instance Accept RawPlainText where
|
||
|
|
contentType _ = "text" // "plain"
|
||
|
|
|
||
|
|
instance MimeUnrender RawPlainText T.Text where
|
||
|
|
mimeUnrender _ = Right . T.decodeUtf8 . BS.toStrict
|
||
|
|
|
||
|
|
-- TODO implement marshalling from HTML to 'Day', 'Year', and 'Answer'
|
||
|
|
-- types which extracts yearly calendars, day prompts, and
|
||
|
|
-- pre-existing correct answer submissions via scraping the received
|
||
|
|
-- HTML.
|
||
|
|
|
||
|
|
data HTML
|
||
|
|
|
||
|
|
instance Accept HTML where
|
||
|
|
contentType _ = "text" // "html" /: ("charset", "utf-8")
|
||
|
|
|
||
|
|
data Answer = Correct | Low | High | Empty
|
||
|
|
|
||
|
|
instance MimeUnrender HTML Answer where
|
||
|
|
mimeUnrender _ bs
|
||
|
|
| "correct" `BS.isInfixOf` bs' = Right Correct
|
||
|
|
| "low" `BS.isInfixOf` bs' = Right Low
|
||
|
|
| "high" `BS.isInfixOf` bs' = Right High
|
||
|
|
| "provide an answer" `BS.isInfixOf` bs' = Right Empty
|
||
|
|
| otherwise = Left "Unknown answer response"
|
||
|
|
where
|
||
|
|
bs' = BS.toStrict bs
|