#!/usr/bin/env runghc {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} import System.Process (readProcessWithExitCode) import System.Exit (ExitCode(..)) import System.Environment (lookupEnv) import System.IO (stderr, hPutStrLn) import Data.Char (isSpace, toLower) import Data.List (isPrefixOf, isSuffixOf, isInfixOf, dropWhileEnd) import Data.Maybe (listToMaybe, fromMaybe) -- tiny helpers dbg :: String -> IO () dbg s = lookupEnv "DEBUG" >>= \d -> case d of Just "1" -> hPutStrLn stderr ("[dbg] " ++ s); _ -> pure () trim :: String -> String trim = dropWhile isSpace . dropWhileEnd isSpace lower :: String -> String lower = map toLower short :: Int -> String -> String short n s = let t = unwords (words s) in if length t > n then take (n-1) t ++ "…" else t section :: String -> IO () section t = putStrLn $ "\n===== " ++ t ++ " =====" -- curl / fetch / jq curlBody :: String -> IO (Maybe String) curlBody u = do ik <- lookupEnv "INSECURE" let k = if ik == Just "1" && ("someodd.zip" `isInfixOf` u) && ("http" `isPrefixOf` u) then ["-k"] else [] a = ["-fsSL","--location","--connect-timeout","3","--max-time","8","-A","someodd-digest/hs","--"] ++ k ++ [u] dbg $ "curl " ++ unwords a readProcessWithExitCode "curl" a "" >>= \case (ExitSuccess, out, _) -> pure (Just out) _ -> pure Nothing fetch :: String -> IO (Maybe String) fetch u | "gopher://" `isPrefixOf` u = curlBody u | "https://" `isPrefixOf` u = curlBody u >>= \case { Just x -> pure (Just x); _ -> curlBody ("http://" ++ drop 8 u) } | otherwise = curlBody u jq :: String -> String -> IO (Maybe String) jq e s = readProcessWithExitCode "jq" ["-r", e] s >>= \case (ExitSuccess, o, _) -> let t = trim o in pure $ if t == "" || t == "null" then Nothing else Just t _ -> pure Nothing -- 1) latest toot toot :: IO () toot = do section "Toot" fetch "https://fosstodon.org/api/v1/accounts/lookup?acct=someodd" >>= \case Nothing -> putStrLn "(couldn't resolve account)" Just js -> jq ".id" js >>= \case Nothing -> putStrLn "(couldn't resolve account)" Just aid -> fetch ("https://fosstodon.org/api/v1/accounts/" ++ aid ++ "/statuses?limit=1&exclude_replies=true&exclude_reblogs=true") >>= \case Nothing -> putStrLn "(unreachable)" Just s -> jq ".[0] | select(.!=null) | [.created_at, (.content//\"\")] | @tsv" s >>= \case Nothing -> putStrLn "(none found)" Just tsv -> let (ts, rest) = span (/= '\t') tsv body = stripHTML (drop 1 rest) in putStrLn (ts ++ " — " ++ short 280 body) where stripHTML = decode . kill kill [] = [] kill ('<':xs) = kill (drop 1 (dropWhile (/= '>') xs)) kill (x:xs) = x : kill xs decode = rep " " " " . rep "&" "&" . rep "<" "<" . rep ">" ">" . rep """ "\"" . rep "'" "'" rep a b = go where go s | a `isPrefixOf` s = b ++ go (drop (length a) s) | otherwise = case s of [] -> []; (c:cs) -> c : go cs -- 2) latest bartleby library accession (via gopher atom feed) bartleby :: IO () bartleby = do section "Bartleby Library" fetch "gopher://gopher.someodd.zip:70/0/library/catalog/feed.xml" >>= \case Nothing -> putStrLn "(unreachable)" Just feed -> do mt <- xpath feed "//a:entry[1]/a:title" ms <- xpath feed "//a:entry[1]/a:summary" let title = stripMd (fromMaybe "" mt) summary = fromMaybe "" ms if null title then putStrLn "(no accessions)" else do putStrLn $ "Latest: " ++ title case summary of "" -> pure () s | s == title -> pure () | otherwise -> putStrLn $ "Summary: " ++ short 280 s where stripMd s = if ".md" `isSuffixOf` s then take (length s - 3) s else s xpath input expr = let args = ["sel", "-N", "a=http://www.w3.org/2005/Atom", "-t", "-v", expr] in readProcessWithExitCode "xmlstarlet" args input >>= \case (ExitSuccess, o, _) -> let t = trim o in pure $ if null t then Nothing else Just t _ -> pure Nothing -- 3) latest phorum (via gopher /menu) phorum :: IO () phorum = do section "Phorum" fetch "gopher://gopher.someodd.zip/1/phorum" >>= \case Nothing -> putStrLn "(unreachable)" Just menu -> do let title = listToMaybe [ drop 1 (takeWhile (/= '\t') l) | l <- lines menu, "i### No." `isPrefixOf` l ] selM = headSel "/phorum/" "/menu" menu selF = headSel "/phorum/" "/file" menu case selM of Just s -> fetch ("gopher://gopher.someodd.zip/1" ++ s) >>= \case Nothing -> out "(unreachable)" title Just t -> out (short 280 $ lastReplyMenu t) title Nothing -> case selF of Just s -> fetch ("gopher://gopher.someodd.zip/0" ++ s) >>= \case Nothing -> out "(unreachable)" title Just t -> out (short 280 $ lastReplyFile t) title _ -> out "(no thread links)" title where out latest mt = putStrLn ("Thread: " ++ fromMaybe "(none)" mt) >> putStrLn ("Latest: " ++ latest) headSel p end m = listToMaybe [ sel | l <- lines m , let sel = takeWhile (/= '\t') (drop 1 $ dropWhile (/= '\t') l) , not (null l), head l /= 'i', p `isPrefixOf` sel, end `isSuffixOf` sel ] disp l = let d = takeWhile (/= '\t') l in if null d then "" else trim (drop 1 d) -- drop gopher type char deco :: String -> Bool deco s = let t = trim s charset :: String charset = "+|#=_- " in t == "" || (all (`elem` charset) t && length t >= 3) isCtrl s = lower (trim s) `elem` ["reply to thread","view as file","view as menu","return to index","return to phorum","reply","view thread"] lastReplyMenu t = go (map disp $ lines t) [] "" False False [] where go [] cur lastR _ _ op = fin cur lastR op go (x:xs) cur lastR inR hdr op | "### Viewing Thread" `isPrefixOf` x = go xs cur lastR inR True op | "---Reply #" `isPrefixOf` x = go xs [] (use cur lastR) True hdr op | inR && ("---Reply #" `isPrefixOf` x || "###" `isPrefixOf` x || isCtrl x) = go (x:xs) [] (use cur lastR) False hdr op | inR && not (deco x || null (trim x) || isCtrl x) = go xs (cur ++ [x]) lastR inR hdr op | hdr && null op && not (deco x) && not (isCtrl x) && not (null (trim x)) = go xs cur lastR inR hdr [x] | otherwise = go xs cur lastR inR hdr op use cur lastR = if null cur then lastR else unwords cur fin cur lastR op = let r = use cur lastR in if r /= "" then r else maybe "(empty)" id (listToMaybe op) lastReplyFile t = lastReplyMenu (unlines $ map ('i':) (lines t)) -- reuse logic -- 4) latest interlog (via gopher) interlog :: IO () interlog = do section "Interlog" fetch "gopher://gopher.someodd.zip/1/interlog" >>= \case Nothing -> putStrLn "(unreachable)" Just m -> case headSel m of Nothing -> putStrLn "(no log files)" Just sel -> fetch ("gopher://gopher.someodd.zip/0" ++ sel) >>= \case Nothing -> putStrLn "(unreachable)" Just t -> putStrLn . short 280 $ betweenContent t where headSel m = listToMaybe [ takeWhile (/= '\t') (drop 1 $ dropWhile (/= '\t') l) | l <- lines m, "/interlog/log/" `isInfixOf` l, not (null l), head l == '0' ] betweenContent :: String -> String betweenContent s = let ls = lines s lastNonEmpty = let nz = [trim l | l <- ls, trim l /= ""] in if null nz then "(empty)" else last nz go :: [String] -> Bool -> Maybe String -> String go [] inC lastL | inC = fromMaybe "(empty)" lastL | otherwise = lastNonEmpty go (x:xs) inC lastL | lower (trim x) == "--- content ---" = go xs True lastL | inC && ( lower (trim x) == "append..." || lower (trim x) == "append…" || "interlog/append/" `isInfixOf` x) = fromMaybe "(empty)" lastL | inC && not (null (trim x)) = go xs inC (Just $ trim x) | otherwise = go xs inC lastL in go ls False Nothing -- 5) radio radio :: IO () radio = do section "Radio" let js = ["https://radio.someodd.zip/status-json.xsl","http://radio.someodd.zip/status-json.xsl"] ht = ["https://radio.someodd.zip/status.xsl","http://radio.someodd.zip/status.xsl"] firstJust (map jsonTitle js) >>= \case Just t -> putStrLn (short 280 t) Nothing -> firstJust (map htmlTitle ht) >>= \case Just t -> putStrLn (short 280 t) _ -> putStrLn "(unknown)" where firstJust [] = pure Nothing firstJust (a:as) = a >>= \case { Just x -> pure (Just x); _ -> firstJust as } jsonTitle u = fetch u >>= \case Nothing -> pure Nothing Just j -> jq "try .icestats.source as $s | if ($s|type)==\"array\" then ([$s[]|select((.title//\"\")!=\"\")][0].title) else ($s.title//empty) end" j htmlTitle u = fetch u >>= \case Nothing -> pure Nothing Just h -> let plain = strip h pick = listToMaybe [ dropWhile isSpace $ drop 1 $ dropWhile (/=':') ln | ln <- lines plain , k <- ["Current Song","Stream Title","Current song","Stream title"] , k `isInfixOf` ln ] in pure (fmap trim pick) strip = decode . kill where kill [] = [] kill ('<':xs) = kill (drop 1 $ dropWhile (/= '>') xs) kill (x:xs) = x : kill xs decode = rep " " " " . rep "&" "&" . rep "<" "<" . rep ">" ">" . rep """ "\"" . rep "'" "'" rep a b = go where go s | a `isPrefixOf` s = b ++ go (drop (length a) s) | otherwise = case s of [] -> []; (c:cs) -> c : go cs -- 6) IRC irc :: IO () irc = do section "IRC Server" readProcessWithExitCode "/usr/local/bin/irc_stats.sh" [] "" >>= \case (ExitSuccess, out, _) -> putStrLn out _ -> putStrLn "There was a problem with the IRC stats script!" -- 7) Counter-Strike 1.6 server status counterStrike :: IO () counterStrike = do section "Counter-Strike 1.6 Server" readProcessWithExitCode "/usr/local/bin/cs_stats.sh" [] "" >>= \case (ExitSuccess, out, _) -> putStrLn out _ -> putStrLn "There was a problem with the stats script!" -- main main :: IO () main = toot >> bartleby >> phorum >> interlog -- >> irc >> counterStrike -- >> radio