" "> "
> . T.replace "" "\n\n"
> . T.replace "" ""
> . T.replace "
" "\n"
> . T.replace "
" "\n"
> . T.replace "
" "\n"
> -- | First `Text` lying strictly between `open` and the next `close`
> -- in the haystack. Returns empty if either marker is missing.
> --
> -- >>> textBetween "" "" "x hi y"
> -- "hi"
> --
> -- >>> textBetween "" "" "no markers here"
> -- ""
> textBetween :: T.Text -> T.Text -> T.Text -> T.Text
> textBetween open close hay =
> let (_, a) = T.breakOn open hay
> afterOpen = T.drop (T.length open) a
> (inside, _) = T.breakOn close afterOpen
> in if T.null a then T.empty else inside
HTTP helpers (via curl subprocess)
----------------------------------
Curl is invoked as a subprocess to keep the dependency surface flat
--- same posture as the rest of the applets. `curlGet` / `curlGetWithCookies` return
the body as `Text`; `curlGetBytes` returns raw `ByteString` (for the
GIF). `curlPostMultipart` POSTs a list of name/value pairs as
multipart/form-data with `--form-string`, which prevents `@file` and
` curlGet :: T.Text -> IO (Either T.Text T.Text)
> curlGet url = do
> r <- try $ readProcessWithExitCode "curl"
> ["-s", "--compressed", "--max-time", "20", T.unpack url] ""
> case r of
> Left e -> pure (Left ("curl failed: " <> T.pack (show (e :: IOException))))
> Right (ExitSuccess, out, _) -> pure (Right (T.pack out))
> Right (_, _, err) -> pure (Left ("curl error: " <> T.strip (T.pack err)))
> -- | GET binary into `out`, saving cookies to `jar`. The body is
> -- written by curl, so we never funnel bytes through `String` (which
> -- the system locale would re-decode and corrupt for non-text
> -- responses).
> curlGetToFileWithJar :: FilePath -> FilePath -> T.Text -> IO (Either T.Text ())
> curlGetToFileWithJar jar out url = do
> r <- try $ readProcessWithExitCode "curl"
> ["-s", "--compressed", "--max-time", "20", "-c", jar, "-o", out, T.unpack url] ""
> case r of
> Left e -> pure (Left ("curl failed: " <> T.pack (show (e :: IOException))))
> Right (ExitSuccess, _, _) -> pure (Right ())
> Right (_, _, err) -> pure (Left ("curl error: " <> T.strip (T.pack err)))
`curlPostMultipart` calls curl with `--form-string name=value` for
each pair, plus `-b jar` to attach the captcha cookie. We capture
the response body and follow no redirects --- a successful Kareha
post answers `302` with a `Location` we don't actually need (the
thread URL we already know), and an error post answers `200` with an
HTML body we want to parse.
> curlPostMultipart :: FilePath -> T.Text -> [(T.Text, T.Text)] -> IO (Either T.Text T.Text)
> curlPostMultipart jar url fields = do
> let formArgs = concatMap (\(k,v) -> ["--form-string", T.unpack k <> "=" <> T.unpack v]) fields
> args = ["-s", "-i", "--compressed", "--max-time", "30",
> "-b", jar, "-X", "POST", T.unpack url] ++ formArgs
> r <- try $ readProcessWithExitCode "curl" args ""
> case r of
> Left e -> pure (Left ("curl failed: " <> T.pack (show (e :: IOException))))
> Right (ExitSuccess, out, _) -> pure (Right (T.pack out))
> Right (_, _, err) -> pure (Left ("curl error: " <> T.strip (T.pack err)))
Pages
=====
Board picker
------------
Fetch `https://4-ch.net/side.html`, harvest every `Name` it lists, render as type-1
menu items pointing back into this applet.
> emitBoards :: Ctx -> IO ()
> emitBoards ctx = do
> r <- curlGet (upstream <> "/side.html")
> case r of
> Left e -> mapM_ putLine [ errorItem e, terminator ]
> Right html -> do
> let bs = parseBoards html
> if null bs
> then mapM_ putLine [ errorItem "Could not parse the board list.", terminator ]
> else mapM_ putLine $
> [ infoLine "4-ch.net via gopher — pick a board."
> , infoLine ""
> ] ++
> [ menuLine (name <> " (/" <> slug <> "/)") (link ctx slug) (ctxHost ctx) (ctxPort ctx)
> | (slug, name) <- bs
> ] ++
> [ infoLine ""
> , httpLine "Open 4-ch.net in a web browser" (upstream <> "/") (ctxHost ctx) (ctxPort ctx)
> , terminator
> ]
> -- | Pull every board (slug, display name) out of side.html.
> -- Tolerant of inline `style=` and `title=` attributes.
> --
> -- >>> parseBoards "Technology"
> -- [("tech","Technology")]
> --
> -- >>> parseBoards "DQN"
> -- [("dqn","DQN")]
> parseBoards :: T.Text -> [(T.Text, T.Text)]
> parseBoards = uniq . go . T.replace "\r" "" . T.replace "\n" " "
> where
> go t = case T.breakOn "https://4-ch.net/" t of
> (_, rest) | T.null rest -> []
> | otherwise ->
> let after = T.drop (T.length "https://4-ch.net/") rest
> (slug, after') = T.span (\c -> isAlphaNum c) after
> isClose = T.isPrefixOf "/\"" after'
> in if not isClose || T.null slug
> then go (T.drop 1 rest)
> else
> let (_, txt0) = T.breakOn ">" after'
> txt1 = T.drop 1 txt0
> (label, _) = T.breakOn " cleaned = T.strip (decodeEntities (stripTags label))
> in if T.null cleaned
> then go (T.drop 1 rest)
> else (slug, cleaned) : go (T.drop (T.length "https://4-ch.net/" + T.length slug) rest)
> uniq = go' []
> where
> go' _ [] = []
> go' seen ((s,n):xs)
> | s `elem` seen = go' seen xs
> | otherwise = (s,n) : go' (s:seen) xs
Thread index
------------
Per-board page; each `