From 48dab033266688eb8b03531b95214ed76415e9d3 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Wed, 7 Sep 2022 22:39:11 +0200 Subject: [PATCH] Add debug route and refactor some code --- lisa.cabal | 7 +++++ package.yaml | 2 ++ src/Lisa.hs | 66 +++++++++++----------------------------------- src/Lisa/Squeak.hs | 1 + src/Lisa/Types.hs | 63 +++++++++++++++++++++++++++++++++++++++++++ src/Lisa/Views.hs | 30 +++++++++++++-------- 6 files changed, 107 insertions(+), 62 deletions(-) create mode 100644 src/Lisa/Types.hs diff --git a/lisa.cabal b/lisa.cabal index 4ef9227..de93a06 100644 --- a/lisa.cabal +++ b/lisa.cabal @@ -27,6 +27,7 @@ library exposed-modules: Lisa Lisa.Squeak + Lisa.Types Lisa.Views other-modules: Paths_lisa @@ -38,9 +39,11 @@ library , aeson >=2.0 , base >=4.7 && <5 , blaze-html >=0.9 + , pretty-simple >=4.1 , req >=3.10 , text >=1.0 , time >=1.11 + , wai >=3.2 default-language: Haskell2010 executable lisa-exe @@ -56,9 +59,11 @@ executable lisa-exe , base >=4.7 && <5 , blaze-html >=0.9 , lisa + , pretty-simple >=4.1 , req >=3.10 , text >=1.0 , time >=1.11 + , wai >=3.2 default-language: Haskell2010 test-suite lisa-test @@ -75,7 +80,9 @@ test-suite lisa-test , base >=4.7 && <5 , blaze-html >=0.9 , lisa + , pretty-simple >=4.1 , req >=3.10 , text >=1.0 , time >=1.11 + , wai >=3.2 default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index d493a45..cf72fd4 100644 --- a/package.yaml +++ b/package.yaml @@ -23,10 +23,12 @@ dependencies: - base >= 4.7 && < 5 - aeson >= 2.0 - blaze-html >= 0.9 +- pretty-simple >= 4.1 - req >= 3.10 - Spock >= 0.14 - text >= 1.0 - time >= 1.11 +- wai >= 3.2 library: source-dirs: src diff --git a/src/Lisa.hs b/src/Lisa.hs index 299356b..61b8b52 100644 --- a/src/Lisa.hs +++ b/src/Lisa.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Lisa @@ -7,18 +5,14 @@ module Lisa , mkConfig ) where -import Control.Concurrent (MVar, newMVar, putMVar, takeMVar) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (MonadIO) import Data.Maybe (fromMaybe) -import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime) -import Network.HTTP.Req (https) import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) -import Text.Printf (printf) -import Web.Spock (SpockAction, SpockM, ActionCtxT, get, getState, lazyBytes, param, root, setHeader, var, ()) +import Web.Spock (SpockM, ActionCtxT, get, lazyBytes, param, readSession, request, root, setHeader, var, ()) import Web.Spock.Config (PoolOrConn(PCNoDatabase), SpockCfg, defaultSpockCfg) -import Lisa.Squeak (SqueakCtx, SqueakError, Lecture) +import Lisa.Types (Session, State, emtpySession, mkState, getAllLecturesCached) import qualified Lisa.Squeak as Squeak import qualified Lisa.Views as Views @@ -31,58 +25,28 @@ blaze html = do setHeader "Content-Type" "text/html; charset=utf-8" lazyBytes $ renderHtml html -instance SqueakCtx (SpockAction () () State) where - getLocationInfo = pure $ Right (https "api.squeak-test.fsmi.uni-karlsruhe.de", mempty) - getAuthToken = pure Nothing - --- State - -data State = State - { stateLectures :: MVar (UTCTime, [Lecture]) -- ^ Cached lectures with cache expiration time. - } - --- | Get lectures from cache if they've been retrieved before or from Squeak. --- Uses 'MVar's for synchronisation: As long as each thread 'takeMVar's before it 'putMVar's, we're in the clear. --- TODO: Evaluate lectures to NF before 'putMVar'ing them. -getAllLecturesCached :: SpockAction () () State (Either SqueakError [Lecture]) -getAllLecturesCached = do - lecturesMVar <- stateLectures <$> getState - (expirationTime, lectures) <- liftIO $ takeMVar lecturesMVar - now <- liftIO getCurrentTime - (newContents, result) <- if now >= expirationTime - then -- Cache expired => fetch lectures again. - Squeak.getAllLectures >>= \case - -- On error: Clear cache. - Left err -> - pure ((now, []), Left err) - -- On success: Cache fetched lectures for 60 seconds. - Right lectures' -> do - let expirationTime' = addUTCTime 60 now - liftIO $ printf "Fetched %d lectures, valid until %s\n" (length lectures') (show expirationTime') - pure ((expirationTime', lectures'), Right lectures') - else -- Cache still valid => return it. - pure ((expirationTime, lectures), Right lectures) - liftIO $ putMVar lecturesMVar newContents - pure result - -- Exports -mkConfig :: IO (SpockCfg () () State) +mkConfig :: IO (SpockCfg () Session State) mkConfig = do - now <- getCurrentTime - lecturesMVar <- newMVar (now, []) - defaultSpockCfg () PCNoDatabase (State lecturesMVar) + state <- mkState + defaultSpockCfg emtpySession PCNoDatabase state -app :: SpockM () () State () +app :: SpockM () Session State () app = do get root $ do blaze Views.viewIndex - get ("lectures" var) $ \id -> do - documents <- Squeak.getDocumentsByLectureId id - blaze $ either Views.viewSqueakError (Views.viewLecture id) documents + get ("lectures" var) $ \lid -> do + documents <- Squeak.getDocumentsByLectureId lid + blaze $ either Views.viewSqueakError (Views.viewLecture lid) documents get "lectures" $ do query <- fromMaybe "" <$> param "query" lectures <- getAllLecturesCached blaze $ either Views.viewSqueakError (Views.viewLectures query) lectures + + get "debug" $ do + req <- request + sess <- readSession + blaze $ Views.viewDebug req sess diff --git a/src/Lisa/Squeak.hs b/src/Lisa/Squeak.hs index 5e586ea..087cd53 100644 --- a/src/Lisa/Squeak.hs +++ b/src/Lisa/Squeak.hs @@ -120,6 +120,7 @@ removePrefixModifier prefix = lowercaseFirst . stripPrefix prefix lowercaseFirst (c:cs) = Char.toLower c : cs lowercaseFirst [] = error $ "Prefix " ++ prefix ++ " ate all my input" +removePrefixOpts :: String -> Options removePrefixOpts prefix = defaultOptions { fieldLabelModifier = removePrefixModifier prefix } data Document = Document diff --git a/src/Lisa/Types.hs b/src/Lisa/Types.hs new file mode 100644 index 0000000..2f98a59 --- /dev/null +++ b/src/Lisa/Types.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Lisa.Types where + +import Control.Concurrent (MVar, newMVar, putMVar, takeMVar) +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) +import Network.HTTP.Req (https) +import Text.Printf (printf) +import Web.Spock (SpockAction, getState) + +import Lisa.Squeak (Lecture, SqueakCtx, SqueakError) + +import qualified Lisa.Squeak as Squeak + +-- | Session data per-client. +data Session = Session + { sessionAuthToken :: Maybe Text + } deriving (Show) + +emtpySession :: Session +emtpySession = Session Nothing + +-- | Global application state. +data State = State + { stateLectures :: MVar (UTCTime, [Lecture]) -- ^ Cached lectures with cache expiration time. + } + +mkState :: IO State +mkState = do + now <- getCurrentTime + State <$> newMVar (now, []) + +-- | Get lectures from cache if they've been retrieved before or from Squeak. +-- Uses 'MVar's for synchronisation: As long as each thread 'takeMVar's before it 'putMVar's, we're in the clear. +-- TODO: Evaluate lectures to NF before 'putMVar'ing them. +getAllLecturesCached :: SpockAction conn sess State (Either SqueakError [Lecture]) +getAllLecturesCached = do + lecturesMVar <- stateLectures <$> getState + (expirationTime, lectures) <- liftIO $ takeMVar lecturesMVar + now <- liftIO getCurrentTime + (newContents, result) <- if now >= expirationTime + then -- Cache expired => fetch lectures again. + Squeak.getAllLectures >>= \case + -- On error: Clear cache. + Left err -> + pure ((now, []), Left err) + -- On success: Cache fetched lectures for 60 seconds. + Right lectures' -> do + let expirationTime' = addUTCTime 60 now + liftIO $ printf "Fetched %d lectures, valid until %s\n" (length lectures') (show expirationTime') + pure ((expirationTime', lectures'), Right lectures') + else -- Cache still valid => return it. + pure ((expirationTime, lectures), Right lectures) + liftIO $ putMVar lecturesMVar newContents + pure result + +instance SqueakCtx (SpockAction conn sess State) where + getLocationInfo = pure $ Right (https "api.squeak-test.fsmi.uni-karlsruhe.de", mempty) + getAuthToken = pure Nothing diff --git a/src/Lisa/Views.hs b/src/Lisa/Views.hs index fa560eb..89c6d8e 100644 --- a/src/Lisa/Views.hs +++ b/src/Lisa/Views.hs @@ -1,20 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -module Lisa.Views - ( viewIndex - , viewLecture - , viewLectures - , viewSqueakError - ) where +module Lisa.Views where import Prelude hiding (div) import Control.Monad (forM_) import Data.List (intersperse) import Data.Text (Text, isInfixOf) +import Network.Wai (Request) import Text.Blaze.Html5 hiding (map) import Text.Blaze.Html5.Attributes hiding (form) +import Lisa.Types (Session) import Lisa.Squeak (Document(..), Lecture(..), SqueakError(..)) viewIndex :: Html @@ -22,6 +19,7 @@ viewIndex = do h1 "Lisa" ul $ do li $ a "Vorlesungen" ! href "/lectures" + li $ a "Debuginformation" ! href "/debug" viewLectures :: Text -> [Lecture] -> Html viewLectures query lectures = do @@ -29,17 +27,17 @@ viewLectures query lectures = do form ! action "/lectures" ! method "GET" $ do input ! name "query" ! value (textValue query) button ! type_ "submit" $ text "Filtern" - ul $ forM_ (filter matchQuery lectures) $ \(Lecture id displayName aliases) -> do + ul $ forM_ (filter matchQuery lectures) $ \(Lecture lid displayName aliases) -> do li $ do - div $ a ! href (textValue $ "/lectures/" <> id) $ text displayName + div $ a ! href (textValue $ "/lectures/" <> lid) $ text displayName div $ text $ mconcat $ intersperse ", " aliases where matchQuery (Lecture _id displayName aliases) = any (query `isInfixOf`) (displayName : aliases) viewLecture :: Text -> [Document] -> Html -viewLecture id documents = do - h1 $ text ("Vorlesung " <> id) +viewLecture lecture documents = do + h1 $ text ("Vorlesung " <> lecture) table $ do thead $ tr $ mapM_ th ["Art", "Vorlesungen", "Prüfer", "Datum", "Semester", "Seiten"] tbody $ forM_ documents $ \document -> tr $ do @@ -50,5 +48,15 @@ viewLecture id documents = do td $ text $ documentSemester document td $ string $ show $ documentNumPages document +viewDebug :: Request -> Session -> Html +viewDebug request session = do + h1 $ text "Debuginformation" + fieldset $ do + legend "Request" + pre $ string $ show request + fieldset $ do + legend "Session" + pre $ string $ show session + viewSqueakError :: SqueakError -> Html -viewSqueakError error = string $ show error +viewSqueakError err = string $ show err