From 738247fb6cbe58a2f33cb69a663c8fd2ed96ff9b Mon Sep 17 00:00:00 2001 From: nick hansen Date: Thu, 15 Apr 2021 22:26:53 -0700 Subject: [PATCH] hacky lax-mode parsing --- src/LogParser/Parse.hs | 21 ++++++++++++++++++--- src/LogParser/Server.hs | 25 ++++++++++++++----------- src/LogParser/Views.hs | 4 ++-- templates/parse-error.hamlet | 10 +++++++++- test/ParseSpec.hs | 31 ++++++++++++++++++++++++++++++- test/ProcessSpec.hs | 8 ++++---- 6 files changed, 77 insertions(+), 22 deletions(-) diff --git a/src/LogParser/Parse.hs b/src/LogParser/Parse.hs index 43fe54b..4b20791 100644 --- a/src/LogParser/Parse.hs +++ b/src/LogParser/Parse.hs @@ -22,10 +22,13 @@ module LogParser.Parse , logEntry , parseLogEntries , parseLogEntries' + , runLaxParser + , runStrictParser ) where import Control.Applicative +import Control.Monad.Reader import Control.Monad.State.Strict import qualified Data.Char as C import Data.Foldable @@ -50,6 +53,8 @@ data ParserState = PSt { seenPlayers :: Set Player , currencyType :: Maybe CurrencyType } +data ParseMode = ParseStrict | ParseLax + data CurrencyType = PrefixCurrency Text | SuffixCurrency Text deriving (Eq,Show) @@ -58,17 +63,23 @@ knownCurrencyPrefixes,knownCurrencySuffixes :: [Text] knownCurrencyPrefixes = ["$", "¥", "£"] knownCurrencySuffixes = [" F", "₽"] -parseLogEntries :: Monad m => Pipe Text LogEntry m (Either LogParserError a) +parseLogEntries :: (MonadReader ParseMode m, Monad m) + => Pipe Text LogEntry m (Either LogParserError a) parseLogEntries = parseLogEntries' emptyParseState -parseLogEntries' :: Monad m => ParserState -> Pipe Text LogEntry m (Either LogParserError a) +parseLogEntries' :: (MonadReader ParseMode m, Monad m) + => ParserState -> Pipe Text LogEntry m (Either LogParserError a) parseLogEntries' = go 1 where go lineNum st = do txt <- await case P.parse (runStateT logEntry st) "" txt of Right (entry, st') -> yield entry >> go (lineNum+1) st' - Left err -> pure $ Left $ ParseError $ updateLineNum lineNum err + Left err -> do + parseMode <- ask + case parseMode of + ParseStrict -> pure $ Left $ ParseError $ updateLineNum lineNum err + ParseLax -> go (lineNum+1) st updateLineNum lineNum (P.ParseErrorBundle errs posState) = P.ParseErrorBundle errs $ @@ -77,6 +88,10 @@ parseLogEntries' = go 1 P.SourcePos sn (P.mkPos lineNum) sc } +runLaxParser, runStrictParser :: ReaderT ParseMode m a -> m a +runLaxParser = flip runReaderT ParseLax +runStrictParser = flip runReaderT ParseStrict + parseWithState :: ParserState -> Parser a -> Text -> Either (P.ParseErrorBundle Text Void) a parseWithState st = flip P.parse "" . flip evalStateT st diff --git a/src/LogParser/Server.hs b/src/LogParser/Server.hs index ee42124..a5ec62b 100644 --- a/src/LogParser/Server.hs +++ b/src/LogParser/Server.hs @@ -65,14 +65,15 @@ routes cache = do S.post "/submit" $ do gameLog <- S.param "log" - case processLog gameLog of + lax <- S.param "lax" `S.rescue` const (pure False) + case processLog lax gameLog of ( Right (), dataColl ) | dataColl /= mempty -> do gid <- liftIO $ cacheInsert dataColl cache S.redirect $ "/game/" <> encodeId gid ( Right (), emptyDataColl ) -> do - renderErrorPage $ RenderError "No transaction data generated." + renderErrorPage Nothing $ RenderError "No transaction data generated." ( Left err, _ ) -> - renderErrorPage err + renderErrorPage (if lax then Nothing else Just gameLog) err S.get "/game/:gameId" $ do maybeData <- runMaybeT $ do @@ -106,18 +107,18 @@ routes cache = do ix <- S.param "testId" case lookup ix testList of Just file -> do - dataColl <- liftIO $ processLog <$> LTIO.readFile file + dataColl <- liftIO $ processLog False <$> LTIO.readFile file html $ reportPage $ snd dataColl Nothing -> - renderErrorPage $ RenderError "Bad game id" + renderErrorPage Nothing $ RenderError "Bad game id" html :: Html -> S.ActionM () html = S.html . renderHtml -renderErrorPage :: LogParserError -> S.ActionM () -renderErrorPage err = do +renderErrorPage :: Maybe LT.Text -> LogParserError -> S.ActionM () +renderErrorPage retryableData err = do S.status status400 - html $ errorPage err + html $ errorPage (LT.toStrict <$> retryableData) err staticFiles :: [(String,LT.Text)] staticFiles = do @@ -146,13 +147,15 @@ decodeId = ( Binary.decodeOrFail <=< first (const (mempty,0,mempty)) . decodeBase32 ) -processLog :: LT.Text -> (Either LogParserError (), TidyDataCollection) -processLog gameLog = +processLog :: Bool -> LT.Text -> (Either LogParserError (), TidyDataCollection) +processLog lax gameLog = (fmap Right . each . fmap LT.strip . LT.lines $ gameLog) >-> P.map LT.toStrict >-> parseLogEntries >-> fullPipeline - & runEffect & runWriter + & runEffect + & (if lax then runLaxParser else runStrictParser) + & runWriter testList :: [(Int,FilePath)] testList = diff --git a/src/LogParser/Views.hs b/src/LogParser/Views.hs index fd82dcd..d0830af 100644 --- a/src/LogParser/Views.hs +++ b/src/LogParser/Views.hs @@ -38,8 +38,8 @@ submitPage = $(shamletFile "templates/submit.hamlet") aboutPage :: Html aboutPage = $(shamletFile "templates/about.hamlet") -errorPage :: LogParserError -> Html -errorPage err = $(shamletFile "templates/parse-error.hamlet") +errorPage :: Maybe Text -> LogParserError -> Html +errorPage retryableData err = $(shamletFile "templates/parse-error.hamlet") where formattedParseError = case err of diff --git a/templates/parse-error.hamlet b/templates/parse-error.hamlet index 232c39b..57d07dc 100644 --- a/templates/parse-error.hamlet +++ b/templates/parse-error.hamlet @@ -8,9 +8,17 @@ $doctype 5

Log parse error

Something went wrong processing the game log. + $maybe retryData <- retryableData +

+