{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} module OpenlabTools where import Control.Concurrent.STM hiding (atomically, readTVarIO) import Control.DeepSeq (NFData, deepseq) import Control.Monad.Logger qualified as Logger import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson.BetterErrors qualified as Json import Data.CaseInsensitive qualified as CaseInsensitive import Data.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List import Data.Maybe (listToMaybe) import Data.Text qualified as Text import Data.Time (NominalDiffTime, UTCTime (utctDayTime), diffUTCTime, getCurrentTime) import Data.Time qualified as Time import Data.Time.Clock (addUTCTime) import Data.Time.Format qualified as Time.Format import Debug.Trace import FieldParser (FieldParser' (..)) import FieldParser qualified as Field import GHC.Records (HasField (..)) import GHC.Stack qualified import IHP.HSX.QQ (hsx) import Json qualified import Label import Network.HTTP.Client.Conduit qualified as Http import Network.HTTP.Simple qualified as Http import Network.HTTP.Types import Network.HTTP.Types qualified as Http import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Parse qualified as Wai import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel import Parse (Parse) import Parse qualified import PossehlAnalyticsPrelude import Pretty import System.Environment qualified as Env import System.IO qualified as IO import Text.Blaze.Html.Renderer.Pretty qualified as Html.Pretty import Text.Blaze.Html.Renderer.Utf8 qualified as Html import Text.Blaze.Html5 qualified as Html import Text.HTML.TagSoup qualified as Soup import UnliftIO hiding (Handler, newTVarIO) import Prelude hiding (span, until) mapallSpaceOla :: Text mapallSpaceOla = "https://mapall.space/heatmap/show.php?id=OpenLab+Augsburg" mainPage :: Html.Html mainPage = Html.docTypeHtml [hsx| Openlab Augsburg Tools

Welcome to the OpenLab Augsburg tools thingy. The idea is to provide some services that can be embedded into our other pages.

What’s there

Show me the code/how to contribute

The source code can be found in my user dir in the tvl repo.

To build the server, clone the repository from https://code.tvl.fyi/depot.git. Then cd into users/Profpatsch, run nix-shell.

You can now run the server with cabal repl openlab-tools/` by executing the main function inside the GHC repl. It starts on port 9099.
To try out changes to the code, stop the server with Ctrl+z and type :reload, then main again.
Finally, from within users/Profpatsch you can start a working development environment by installing vscode or vscodium and the Haskell extension. Then run code . from within the directory.

Once you have a patch, contact me on Matrix or DM me at irc/libera, nick Profpatsch.

|] debug :: Bool debug = False runApp :: IO () runApp = withTracer $ \tracer -> do let renderHtml = if debug then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes else Html.renderHtml let runApplication :: (MonadUnliftIO m, MonadLogger m) => ( Wai.Request -> (Wai.Response -> m Wai.ResponseReceived) -> m Wai.ResponseReceived ) -> m () runApplication app = do withRunInIO $ \runInIO -> Warp.run 9099 $ \req respond -> do let catchAppException act = try act >>= \case Right a -> pure a Left (AppException err) -> do runInIO (logError err) respond (Wai.responseLBS Http.status500 [] "") liftIO $ catchAppException (runInIO $ app req (\resp -> liftIO $ respond resp)) let appT :: AppT IO () = do let h extra res = Wai.responseLBS Http.ok200 (("Content-Type", "text/html") : extra) res runHandlers runApplication [ Handler { path = "", body = Body (pure ()) (\((), _) -> pure $ h [] (renderHtml mainPage)) }, Handler { path = "snips/table-opening-hours-last-week", body = Body ((label @"ifModifiedSince" <$> parseIfModifiedSince)) ( \(req', cache) -> do now <- liftIO getCurrentTime <&> mkSecondTime new <- updateCacheIfNewer now cache heatmap let cacheToHeaders = [ ("Last-Modified", new.lastModified & formatHeaderTime), ("Expires", new.until & formatHeaderTime), ( "Cache-Control", let maxAge = new.until `diffSecondTime` now in [fmt|max-age={maxAge & floor @NominalDiffTime @Int & show}, immutable|] ) ] if -- If the last cache update is newer or equal to the requested version, we can tell the browser it’s fine | Just modifiedSince <- req'.ifModifiedSince, modifiedSince >= new.lastModified -> pure $ Wai.responseLBS Http.status304 cacheToHeaders "" | otherwise -> pure $ h cacheToHeaders (new.result & toLazyBytes) ) } ] runReaderT (appT :: AppT IO ()).unAppT Context {..} where -- "https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Last-Modified#syntax" headerFormat = "%a, %d %b %0Y %T GMT" formatHeaderTime (SecondTime t) = t & Time.Format.formatTime @UTCTime Time.Format.defaultTimeLocale headerFormat & stringToText & textToBytesUtf8 parseHeaderTime = Field.utf8 >>> ( FieldParser $ \t -> t & textToString & Time.Format.parseTimeM @Maybe @UTCTime {-no leading whitespace -} False Time.Format.defaultTimeLocale headerFormat & annotate [fmt|Cannot parse header timestamp "{t}"|] ) parseIfModifiedSince :: Parse Wai.Request (Maybe SecondTime) parseIfModifiedSince = lmap ( (.requestHeaders) >>> findMaybe ( \(h, v) -> if "If-Modified-Since" == CaseInsensitive.mk h then Just v else Nothing ) ) (Parse.maybe $ Parse.fieldParser parseHeaderTime) & rmap (fmap mkSecondTime) parseRequest :: (MonadThrow f, MonadIO f) => Otel.Span -> Parse from a -> from -> f a parseRequest span parser req = Parse.runParse "Unable to parse the HTTP request" parser req & assertM span id heatmap :: AppT IO ByteString heatmap = do Http.httpBS [fmt|GET {mapallSpaceOla}|] <&> (.responseBody) <&> Soup.parseTags <&> Soup.canonicalizeTags <&> findHeatmap <&> fromMaybe (htmlToTags [hsx|

Uh oh! could not fetch the table from {mapallSpaceOla}

|]) <&> Soup.renderTags where firstSection f t = t & Soup.sections f & listToMaybe match :: Soup.Tag ByteString -> Soup.Tag ByteString -> Bool match x (t :: Soup.Tag ByteString) = (Soup.~==) @ByteString t x findHeatmap t = t & firstSection (match (Soup.TagOpen ("") [("class", "heatmap")])) >>= firstSection (match (Soup.TagOpen "table" [])) <&> getTable <&> (<> htmlToTags [hsx|
source: mapall.space
|]) <&> wrapTagStream (T2 (label @"el" "figure") (label @"attrs" [])) -- get the table from opening tag to closing tag (allowing nested tables) getTable = go 0 where go _ [] = [] go d (el : els) | match (Soup.TagOpen "table" []) el = el : go (d + 1) els | match (Soup.TagClose "table") el = if d <= 1 then [el] else el : go (traceShowId $ d - 1) els | otherwise = el : go d els htmlToTags :: Html.Html -> [Soup.Tag ByteString] htmlToTags h = h & Html.renderHtml & toStrictBytes & Soup.parseTags -- TODO: this is dog-slow because of the whole list recreation! wrapTagStream :: T2 "el" ByteString "attrs" [Soup.Attribute ByteString] -> [Soup.Tag ByteString] -> [Soup.Tag ByteString] wrapTagStream tag inner = (Soup.TagOpen (tag.el) tag.attrs : inner) <> [Soup.TagClose tag.el] main :: IO () main = runApp -- ( do -- -- todo: trace that to the init functions as well -- Otel.inSpan "whatcd-resolver main function" Otel.defaultSpanArguments $ do -- _ <- runTransaction migrate -- htmlUi -- ) data Handler m = Handler { path :: Text, body :: Body m } data Body m = forall a. Body (Parse Wai.Request a) ((a, TVar (Cache ByteString)) -> m Wai.Response) runHandlers :: (Otel.MonadTracer m, MonadUnliftIO m, MonadThrow m) => -- ( (Wai.Request -> (Wai.Response -> m Wai.ResponseReceived) -> m Wai.ResponseReceived) -> -- m () -- ) -> ( (Wai.Request -> (Wai.Response -> m a) -> m a) -> m () ) -> [Handler m] -> m () runHandlers runApplication handlers = do withCaches :: [ T2 "handler" (Handler m) "cache" (TVar (Cache ByteString)) ] <- handlers & traverse ( \h -> do cache <- liftIO $ newCache h.path "nothing yet" pure $ T2 (label @"handler" h) (label @"cache" cache) ) runApplication $ \req respond -> do let mHandler = withCaches & List.find ( \h -> (h.handler.path) == (req & Wai.pathInfo & Text.intercalate "/") ) case mHandler of Nothing -> respond $ Wai.responseLBS Http.status404 [] "nothing here (yet)" Just handler -> do inSpan' "TODO" $ \span -> do case handler.handler.body of Body parse runHandler -> do req' <- req & parseRequest span parse resp <- runHandler (req', handler.cache) respond resp inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a inSpan name = Otel.inSpan name Otel.defaultSpanArguments inSpan' :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> (Otel.Span -> m a) -> m a -- inSpan' name = Otel.inSpan' name Otel.defaultSpanArguments inSpan' _name act = act (error "todo telemetry disabled") zipT2 :: forall l1 l2 t1 t2. ( HasField l1 (T2 l1 [t1] l2 [t2]) [t1], HasField l2 (T2 l1 [t1] l2 [t2]) [t2] ) => T2 l1 [t1] l2 [t2] -> [T2 l1 t1 l2 t2] zipT2 xs = zipWith (\t1 t2 -> T2 (label @l1 t1) (label @l2 t2)) (getField @l1 xs) (getField @l2 xs) unzipT2 :: forall l1 t1 l2 t2. [T2 l1 t1 l2 t2] -> T2 l1 [t1] l2 [t2] unzipT2 xs = xs <&> toTup & unzip & fromTup where toTup :: forall a b. T2 a t1 b t2 -> (t1, t2) toTup (T2 a b) = (getField @a a, getField @b b) fromTup :: (a, b) -> T2 l1 a l2 b fromTup (t1, t2) = T2 (label @l1 t1) (label @l2 t2) unzipT3 :: forall l1 t1 l2 t2 l3 t3. [T3 l1 t1 l2 t2 l3 t3] -> T3 l1 [t1] l2 [t2] l3 [t3] unzipT3 xs = xs <&> toTup & unzip3 & fromTup where toTup :: forall a b c. T3 a t1 b t2 c t3 -> (t1, t2, t3) toTup (T3 a b c) = (getField @a a, getField @b b, getField @c c) fromTup :: (a, b, c) -> T3 l1 a l2 b l3 c fromTup (t1, t2, t3) = T3 (label @l1 t1) (label @l2 t2) (label @l3 t3) newtype Optional a = OptionalInternal (Maybe a) mkOptional :: a -> Optional a mkOptional defaultValue = OptionalInternal $ Just defaultValue defaults :: Optional a defaults = OptionalInternal Nothing instance HasField "withDefault" (Optional a) (a -> a) where getField (OptionalInternal m) defaultValue = case m of Nothing -> defaultValue Just a -> a httpJson :: ( MonadIO m, MonadThrow m ) => (Optional (Label "contentType" ByteString)) -> Otel.Span -> Json.Parse ErrorTree b -> Http.Request -> m b httpJson opts span parser req = do let opts' = opts.withDefault (label @"contentType" "application/json") Http.httpBS req >>= assertM span ( \resp -> do let statusCode = resp & Http.responseStatus & (.statusCode) contentType = resp & Http.responseHeaders & List.lookup "content-type" <&> Wai.parseContentType <&> (\(ct, _mimeAttributes) -> ct) if | statusCode == 200, Just ct <- contentType, ct == opts'.contentType -> Right $ (resp & Http.responseBody) | statusCode == 200, Just otherType <- contentType -> Left [fmt|Server returned a non-json body, with content-type "{otherType}"|] | statusCode == 200, Nothing <- contentType -> Left [fmt|Server returned a body with unspecified content type|] | code <- statusCode -> Left [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|] ) >>= assertM span ( \body -> Json.parseStrict parser body & first (Json.parseErrorTree "could not parse redacted response") ) assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either ErrorTree a) -> t -> f a assertM span f v = case f v of Right a -> pure a Left err -> appThrowTree span err -- | UTC time that is only specific to the second newtype SecondTime = SecondTime {unSecondTime :: UTCTime} deriving newtype (Show, Eq, Ord) mkSecondTime :: UTCTime -> SecondTime mkSecondTime utcTime = SecondTime utcTime {utctDayTime = Time.secondsToDiffTime $ floor utcTime.utctDayTime} diffSecondTime :: SecondTime -> SecondTime -> NominalDiffTime diffSecondTime (SecondTime a) (SecondTime b) = diffUTCTime a b data Cache a = Cache { name :: !Text, until :: !SecondTime, lastModified :: !SecondTime, result :: !a } deriving (Show) newCache :: Text -> a -> IO (TVar (Cache a)) newCache name result = do let until = mkSecondTime $ Time.UTCTime {utctDay = Time.ModifiedJulianDay 1, utctDayTime = 1} let lastModified = until newTVarIO $ Cache {..} updateCache :: (NFData a, Eq a) => SecondTime -> TVar (Cache a) -> a -> STM (Cache a) updateCache now cache result' = do -- make sure we don’t hold onto the world by deepseq-ing and evaluating to WHNF let !result = deepseq result' result' let until = mkSecondTime $ (5 * 60) `addUTCTime` now.unSecondTime !toWrite <- do old <- readTVar cache let name = old.name -- only update the lastModified time iff the content changed (this is helpful for HTTP caching with If-Modified-Since) if old.result == result then do let lastModified = old.lastModified pure $ Cache {..} else do let lastModified = now pure $ Cache {..} _ <- writeTVar cache $! toWrite pure toWrite -- | Run the given action iff the cache is stale, otherwise just return the item from the cache. updateCacheIfNewer :: (MonadUnliftIO m, NFData b, Eq b) => SecondTime -> TVar (Cache b) -> m b -> m (Cache b) updateCacheIfNewer now cache act = withRunInIO $ \runInIO -> do old <- readTVarIO cache if old.until < now then do res <- runInIO act atomically $ updateCache now cache res else pure old -- pgFormat <- readTools (label @"toolsEnvVar" "OPENLAB_TOOLS_TOOLS") (readTool "pg_format") -- let config = label @"logDatabaseQueries" LogDatabaseQueries -- pgConnPool <- -- Pool.newPool $ -- Pool.defaultPoolConfig -- {- resource init action -} (Postgres.connectPostgreSQL (db & TmpPg.toConnectionString)) -- {- resource destruction -} Postgres.close -- {- unusedResourceOpenTime -} 10 -- {- max resources across all stripes -} 20 -- transmissionSessionId <- newEmptyMVar -- let newAppT = do -- logInfo [fmt|Running with config: {showPretty config}|] -- logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|] -- appT -- runReaderT newAppT.unAppT Context {..} withTracer :: (Otel.Tracer -> IO c) -> IO c withTracer f = do setDefaultEnv "OTEL_SERVICE_NAME" "whatcd-resolver" bracket -- Install the SDK, pulling configuration from the environment Otel.initializeGlobalTracerProvider -- Ensure that any spans that haven't been exported yet are flushed Otel.shutdownTracerProvider -- Get a tracer so you can create spans (\tracerProvider -> f $ Otel.makeTracer tracerProvider "whatcd-resolver" Otel.tracerOptions) setDefaultEnv :: String -> String -> IO () setDefaultEnv envName defaultValue = do Env.lookupEnv envName >>= \case Just _env -> pure () Nothing -> Env.setEnv envName defaultValue data Context = Context { tracer :: Otel.Tracer } newtype AppT m a = AppT {unAppT :: ReaderT Context m a} deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow) data AppException = AppException Text deriving stock (Show) deriving anyclass (Exception) -- | A specialized variant of @addEvent@ that records attributes conforming to -- the OpenTelemetry specification's -- -- -- @since 0.0.1.0 recordException :: ( MonadIO m, HasField "message" r Text, HasField "type_" r Text ) => Otel.Span -> r -> m () recordException span dat = liftIO $ do callStack <- GHC.Stack.whoCreated dat.message newEventTimestamp <- Just <$> Otel.getTimestamp Otel.addEvent span $ Otel.NewEvent { newEventName = "exception", newEventAttributes = HashMap.fromList [ ("exception.type", Otel.toAttribute @Text dat.type_), ("exception.message", Otel.toAttribute @Text dat.message), ("exception.stacktrace", Otel.toAttribute @Text $ Text.unlines $ map stringToText callStack) ], .. } appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a appThrowTree span exc = do let msg = prettyErrorTree exc -- recordException -- span -- ( T2 -- (label @"type_" "AppException") -- (label @"message" msg) -- ) throwM $ AppException msg orAppThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> Either ErrorTree a -> m a orAppThrowTree span = \case Left err -> appThrowTree span err Right a -> pure a instance (MonadIO m) => MonadLogger (AppT m) where monadLoggerLog loc src lvl msg = liftIO $ Logger.defaultOutput IO.stderr loc src lvl (Logger.toLogStr msg) instance (Monad m) => Otel.MonadTracer (AppT m) where getTracer = AppT $ asks (.tracer)