{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module AOC.Run.Load (
ChallengePaths(..), challengePaths
, ChallengeData(..), challengeData
, countdownConsole
, timeToRelease
, showNominalDiffTime
, charPart
, showAoCError
, htmlToMarkdown
, TestMeta(..)
, parseMeta
, parseTests
) where
import AOC.Challenge
import AOC.Util
import Advent
import Control.Applicative
import Control.Concurrent
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Control.Monad.Except
import Data.Bifunctor
import Data.Char
import Data.Dynamic
import Data.Finite
import Data.Foldable
import Data.Map (Map)
import Data.Maybe
import Data.Text (Text)
import Data.Time
import Data.Void
import System.Console.ANSI as ANSI
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error
import Text.Printf
import Text.Read (readMaybe)
import qualified Control.Monad.Combinators as MP
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MP
import qualified Text.Pandoc as P
data ChallengePaths = CP { _cpPrompt :: !FilePath
, _cpInput :: !FilePath
, _cpAnswer :: !FilePath
, _cpTests :: !FilePath
, _cpLog :: !FilePath
}
deriving Show
data ChallengeData = CD { _cdPrompt :: !(Either [String] Text )
, _cdInput :: !(Either [String] String)
, _cdAnswer :: !(Maybe String)
, _cdTests :: ![(String, TestMeta)]
}
challengePaths :: Integer -> ChallengeSpec -> ChallengePaths
challengePaths y (CS d p) = CP
{ _cpPrompt = "prompt" </> printf "%02d%c" d' p' <.> "md"
, _cpInput = "data" </> printf "%02d" d' <.> "txt"
, _cpAnswer = "data/ans" </> printf "%02d%c" d' p' <.> "txt"
, _cpTests = "test-data" </> printf "%04d/%02d%c" y d' p' <.> "txt"
, _cpLog = "logs/submission" </> printf "%02d%c" d' p' <.> "txt"
}
where
d' = dayToInt d
p' = partChar p
makeChallengeDirs :: ChallengePaths -> IO ()
makeChallengeDirs CP{..} =
mapM_ (createDirectoryIfMissing True . takeDirectory)
[_cpPrompt, _cpInput, _cpAnswer, _cpTests, _cpLog]
challengeData
:: Maybe String
-> Integer
-> ChallengeSpec
-> IO ChallengeData
challengeData sess yr spec = do
makeChallengeDirs ps
inp <- runExceptT . asum $
[ maybeToEither [printf "Input file not found at %s" _cpInput]
=<< liftIO (readFileMaybe _cpInput)
, fetchInput
]
prompt <- runExceptT . asum $
[ maybeToEither [printf "Prompt file not found at %s" _cpPrompt]
=<< liftIO (fmap T.pack <$> readFileMaybe _cpPrompt)
, fetchPrompt
]
ans <- readFileMaybe _cpAnswer
ts <- readFileMaybe _cpTests >>= \case
Nothing -> pure []
Just str -> case MP.parse parseTests _cpTests str of
Left e -> [] <$ putStrLn (MP.errorBundlePretty e)
Right r -> pure r
return CD
{ _cdPrompt = prompt
, _cdInput = inp
, _cdAnswer = ans
, _cdTests = ts
}
where
ps@CP{..} = challengePaths yr spec
readFileMaybe :: FilePath -> IO (Maybe String)
readFileMaybe =
(traverse (evaluate . force) . eitherToMaybe =<<)
. tryJust (guard . isDoesNotExistError)
. readFile
fetchInput :: ExceptT [String] IO String
fetchInput = do
s <- maybeToEither ["Session key needed to fetch input"]
sess
let opts = defaultAoCOpts yr s
inp <- liftEither . bimap showAoCError T.unpack
=<< liftIO (runAoC opts a)
liftIO $ writeFile _cpInput inp
pure inp
where
a = AoCInput $ _csDay spec
fetchPrompt :: ExceptT [String] IO Text
fetchPrompt = do
prompts <- liftEither . first showAoCError
=<< liftIO (runAoC opts a)
promptH <- maybeToEither [e]
. M.lookup (_csPart spec)
$ prompts
prompt <- liftEither $ htmlToMarkdown True promptH
liftIO $ T.writeFile _cpPrompt prompt
pure prompt
where
opts = defaultAoCOpts yr $ fold sess
a = AoCPrompt $ _csDay spec
e = case sess of
Just _ -> "Part not yet released"
Nothing -> "Part not yet released, or may require session key"
showAoCError :: AoCError -> [String]
showAoCError = \case
AoCCurlError _ r -> [ "Error contacting Advent of Code server to fetch input"
, "Possible invalid session key"
, printf "Server response: %s" r
]
AoCReleaseError t -> [ "Challenge not yet released!"
, printf "Please wait %s" (showNominalDiffTime t)
]
AoCThrottleError -> [ "Too many requests at a time. Please slow down." ]
showNominalDiffTime :: NominalDiffTime -> String
showNominalDiffTime (round @Double @Int . realToFrac -> rawSecs) =
printf "%02dd %02d:%02d:%02d" days hours mins secs
where
(rawMins , secs ) = rawSecs `divMod` 60
(rawHours, mins ) = rawMins `divMod` 60
(days , hours) = rawHours `divMod` 24
countdownConsole
:: MonadIO m
=> Integer
-> Finite 25
-> m a
-> m a
countdownConsole yr d = countdownWith yr d 250000 $ \ttr -> liftIO $ do
ANSI.clearFromCursorToScreenEnd
printf "> Day %d release in: %s" (dayToInt d) (showNominalDiffTime ttr)
ANSI.setCursorColumn 0
hFlush stdout
countdownWith
:: MonadIO m
=> Integer
-> Finite 25
-> Int
-> (NominalDiffTime -> m ())
-> m a
-> m a
countdownWith yr d delay callback release = go
where
go = do
ttr <- liftIO $ timeToRelease yr d
if ttr <= 0
then release
else do
callback ttr
liftIO $ threadDelay delay
go
htmlToMarkdown :: Bool -> Text -> Either [String] T.Text
htmlToMarkdown pretty html = first ((:[]) . show) . P.runPure $ do
p <- P.readHtml (P.def { P.readerExtensions = exts })
html
writer (P.def { P.writerExtensions = exts }) p
where
writer
| pretty = P.writeMarkdown
| otherwise = P.writePlain
exts = P.disableExtension P.Ext_header_attributes
. P.disableExtension P.Ext_smart
$ P.pandocExtensions
type Parser = MP.Parsec Void String
data TestMeta = TM { _tmAnswer :: Maybe String
, _tmData :: Map String Dynamic
}
deriving Show
data MetaLine = MLData String Dynamic
| MLAnswer String
deriving Show
parseTests :: Parser [(String, TestMeta)]
parseTests = MP.many parseTest <* MP.eof
where
parseTest = do
inp <- MP.manyTill MP.anySingle $ MP.lookAhead (MP.string ">>>")
met <- optional (MP.try parseMeta) MP.<?> "Metadata Block"
pure (inp, fromMaybe (TM Nothing M.empty) met)
parseMeta :: Parser TestMeta
parseMeta = do
dats <- MP.many (MP.try parseData) MP.<?> "Data Block"
ans <- optional (MP.try parseAnswer) MP.<?> "Expected Answer"
pure $ TM ans (M.fromList dats)
where
parseAnswer = MP.string ">>>"
*> MP.space1
*> MP.some (MP.try (asum [MP.alphaNumChar, MP.punctuationChar, MP.symbolChar]))
<* MP.newline
parseData = do
MP.string ">>>"
sym <- MP.manyTill (MP.try MP.letterChar) (MP.try (MP.char ':'))
val <- MP.manyTill (MP.try MP.alphaNumChar) (MP.try (MP.char ':'))
typ <- MP.many (MP.try MP.letterChar)
MP.space
case toLower <$> typ of
"int" -> maybe (fail "Could not parse metadata value") (pure . (sym,) . toDyn)
. readMaybe @Int
$ val
"string" -> pure (sym, toDyn val)
_ -> fail $ "Unrecognized type " ++ typ