6 files changed, 77 insertions(+), 22 deletions(-)

M src/LogParser/Parse.hs
M src/LogParser/Server.hs
M src/LogParser/Views.hs
M templates/parse-error.hamlet
M test/ParseSpec.hs
M test/ProcessSpec.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

@@ 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 =

@@ 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

@@ 8,9 8,17 @@ $doctype 5
     <div .container>
       <h1>Log parse error
       <p>Something went wrong processing the game log.
+      $maybe retryData <- retryableData
+        <form action="/submit" method=POST .d-flex .flex-row .align-items-baseline>
+          <button .btn .btn-link .py-0 .pl-0 .pr-1 type=submit>
+            Retry with lax parsing
+          <span .font-weight-lighter .font-italic .small>
+            (ignore any entires we don't understand, but no guarantees the result will make sense)
+          <input type=hidden name=log value=#{retryData}>
+          <input type=hidden name=lax value=True>
       <button .btn .btn-link .pl-0 type=button data-toggle=collapse data-target="#err-details" aria-expanded=false aria-controls=err-details>
         Error details
       <div #err-details .collapse>
-        <div .card .card-body>
+        <div .card .card-body .mb-1>
           ^{formattedParseError}
     ^{bootstrapJs}

@@ 793,6 793,32 @@ spec = do
         `shouldParseAsLogEntry`
         CompanyNationalized "globochem international"
 
+  describe "lax parsing" $ do
+    it "should skip malformed entries" $
+      let log = [ "-- 2021-04-02 --"
+                , "[12:11]-- Phase 2 (Operating Rounds: 1 | Train Limit: 4 | Available Tiles: Yellow) --"
+                , "[13:45]Some garbage here......"
+                , "[12:11]Cornelius Vanderbilt comes with the president's share of N&W"
+                , "[12:11]kanye west bids $45 for globochem international"
+                , "more garbage!!"
+                , "[12:27]yang wen-li bids $105 for zombocom"
+                ]
+          parsed = (Right <$> each log)
+                   >-> parseLogEntries
+                   & P.toListM'
+                   & runLaxParser
+                   & runIdentity
+      in parsed
+         `shouldBe`
+         ( [ DateStamp (2021,4,2)
+           , PhaseChange "2"
+           , InformationalMessage
+           , AuctionBid "kanye west" 45 (Just "globochem international")
+           , AuctionBid "yang wen-li" 105 (Just "zombocom")
+           ]
+         , Right ()
+         )
+
   context "full game logs" $ do
     let testGameLog name file =
           context name $ do


@@ 802,11 828,14 @@ spec = do
             it "successfully parses" $
               ( unsafelyUnwrapParseError
                . runIdentity
+               . runStrictParser
                . runEffect)
               (parsed >-> P.drain)
               `shouldParse` ()
             it "parses every line" $
-              (runIdentity . P.length $ () <$ parsed) `shouldBe` length lines
+              (runIdentity . runStrictParser . P.length $ () <$ parsed)
+              `shouldBe`
+              length lines
 
     context "18MEX" $ do
       testGameLog "game 1" "18mex.21482.txt"

@@ 33,7 33,7 @@ spec = do
           (Right <$> each input)
           >-> parseLogEntries' st
           >-> combineTrainEntries
-          & P.toListM' & runIdentity
+          & P.toListM' & runStrictParser & runIdentity
     it "handles withheld income" $
       runPipeline [ "[11:09]CNR runs a 2 train for $80: D8-D6-B6"
                   , "[11:09]CNR runs a 3 train for $90: E5-D6-B6"


@@ 105,7 105,7 @@ spec = do
           (Right <$> each input)
           >-> parseLogEntries
           >-> mergeFloatEvents
-          & P.toListM' & runIdentity
+          & P.toListM' & runStrictParser & runIdentity
     it "merges float-then-recieve" $
       runPipeline [ "[12:34]CHI floats"
                   , "[23:45]CHI receives $800"


@@ 135,7 135,7 @@ spec = do
           (Right <$> each input)
           >-> parseLogEntries' st
           >-> addLogTimestamps
-          & P.toListM' & runIdentity
+          & P.toListM' & runStrictParser & runIdentity
     specify "test case 1" $
       runPipeline [ "[10:35]kanye west has priority deal"
                   , "[10:35]-- Stock Round 1 --"


@@ 154,7 154,7 @@ spec = do
             (Right <$> each input)
             >-> parseLogEntries
             >-> fullPipeline
-            & runEffect & runWriter
+            & runEffect & runStrictParser & runWriter
 
     it "emits game events" $
       runPipeline [ "[13:55]-- Operating Round 3.1 (of 2) --"