From bb9a0643f1dfcae8eeda08441a80f3e86e3302a3 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Mon, 5 Sep 2022 16:31:06 +0200 Subject: [PATCH] Add getAllLecturesCached --- lisa.cabal | 4 +++ package.yaml | 1 + src/Lisa.hs | 67 ++++++++++++++++++++++++++++++++++++++++------ src/Lisa/Squeak.hs | 14 +++++++++- src/Lisa/Views.hs | 54 +++++++++++++++++++++++++++++++++++++ 5 files changed, 131 insertions(+), 9 deletions(-) create mode 100644 src/Lisa/Views.hs diff --git a/lisa.cabal b/lisa.cabal index 942e96b..91c981b 100644 --- a/lisa.cabal +++ b/lisa.cabal @@ -27,6 +27,7 @@ library exposed-modules: Lisa Lisa.Squeak + Lisa.Views other-modules: Paths_lisa hs-source-dirs: @@ -36,6 +37,7 @@ library Spock >=0.14 , aeson >=2.0 , base >=4.7 && <5 + , blaze-html >=0.9 , req >=3.10 , text >=1.0 , time @@ -52,6 +54,7 @@ executable lisa-exe Spock >=0.14 , aeson >=2.0 , base >=4.7 && <5 + , blaze-html >=0.9 , lisa , req >=3.10 , text >=1.0 @@ -70,6 +73,7 @@ test-suite lisa-test Spock >=0.14 , aeson >=2.0 , base >=4.7 && <5 + , blaze-html >=0.9 , lisa , req >=3.10 , text >=1.0 diff --git a/package.yaml b/package.yaml index 24adb01..e7a751a 100644 --- a/package.yaml +++ b/package.yaml @@ -22,6 +22,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - aeson >= 2.0 +- blaze-html >= 0.9 - req >= 3.10 - Spock >= 0.14 - text >= 1.0 diff --git a/src/Lisa.hs b/src/Lisa.hs index b361c85..19b172b 100644 --- a/src/Lisa.hs +++ b/src/Lisa.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Lisa @@ -5,19 +7,68 @@ module Lisa , mkConfig ) where +import Control.Concurrent (MVar, newMVar, putMVar, takeMVar) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Maybe (fromMaybe) -import Web.Spock (SpockM, get, html, param, root) +import Network.HTTP.Req (https) +import Text.Blaze.Html (Html) +import Text.Blaze.Html.Renderer.Utf8 (renderHtml) +import Web.Spock (SpockAction, SpockM, ActionCtxT, get, getState, lazyBytes, param, root, setHeader, var, ()) import Web.Spock.Config (PoolOrConn(PCNoDatabase), SpockCfg, defaultSpockCfg) -data Session = Session +import Lisa.Squeak (SqueakCtx, SqueakError, Lecture) -mkConfig :: IO (SpockCfg () Session ()) -mkConfig = defaultSpockCfg Session PCNoDatabase () +import qualified Lisa.Squeak as Squeak +import qualified Lisa.Views as Views -app :: SpockM () Session () () +-- Utilities + +-- From https://github.com/Rockfordal/spockmini/blob/51af99760bbf68c956e906c9633182700a18be9c/src/Web/Utils.hs#L17 +blaze :: MonadIO m => Html -> ActionCtxT ctx m a +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 (Maybe [Lecture]) -- ^ Cached lectures + } + +-- | Get lectures from cache if they've been retrieved before or from Squeak. +getAllLecturesCached :: SpockAction () () State (Either SqueakError [Lecture]) +getAllLecturesCached = do + lecturesMVar <- stateLectures <$> getState + contents <- liftIO $ takeMVar lecturesMVar + lectures' <- case contents of + Just lectures -> pure $ Right lectures + Nothing -> do + liftIO $ putStrLn "Fetching lectures for the first time..." + Squeak.getAllLectures + liftIO $ putMVar lecturesMVar $ either (const Nothing) Just lectures' + pure lectures' + +-- Exports + +mkConfig :: IO (SpockCfg () () State) +mkConfig = do + lecturesMVar <- newMVar Nothing + defaultSpockCfg () PCNoDatabase (State lecturesMVar) + +app :: SpockM () () State () app = do get root $ do - html "

It works!

" - get "/lectures/search" $ do + blaze Views.viewIndex + + get ("lectures" var) $ \id -> do + documents <- Squeak.getDocumentsByLectureId id + blaze $ either Views.viewSqueakError (Views.viewLecture id) documents + + get "lectures" $ do query <- fromMaybe "" <$> param "query" - html $ "

" <> query <> "

" + lectures <- getAllLecturesCached + blaze $ either Views.viewSqueakError (Views.viewLectures query) lectures diff --git a/src/Lisa/Squeak.hs b/src/Lisa/Squeak.hs index 1180b83..5e586ea 100644 --- a/src/Lisa/Squeak.hs +++ b/src/Lisa/Squeak.hs @@ -130,6 +130,8 @@ data Document = Document , documentFaculty :: Faculty , documentLectures :: [Lecture] , documentDownloadable :: Bool + , documentType :: Text + , documentNumPages :: Int } deriving (Show, Generic) @@ -171,7 +173,17 @@ getAllDocuments :: (SqueakCtx m, MonadIO m) => m (Either SqueakError [Document]) getAllDocuments = fmap unDocuments <$> joinErrors <$> mkQuery "{ documents(filters: []) \ \ { results \ - \ { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } } \ + \ { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } type numPages } \ + \ } \ + \}" + +getDocumentsByLectureId :: (SqueakCtx m, MonadIO m) => Text -> m (Either SqueakError [Document]) +getDocumentsByLectureId lecture = fmap unDocuments <$> joinErrors <$> mkQueryWithVars + (object ["lecture" .= lecture]) + "query DocumentsByLectureId($lecture: LectureId!) \ + \ { documents(filters: [{ lectures: [$lecture] }]) \ + \ { results \ + \ { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } type numPages } \ \ } \ \}" diff --git a/src/Lisa/Views.hs b/src/Lisa/Views.hs new file mode 100644 index 0000000..fa560eb --- /dev/null +++ b/src/Lisa/Views.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Lisa.Views + ( viewIndex + , viewLecture + , viewLectures + , viewSqueakError + ) where + +import Prelude hiding (div) + +import Control.Monad (forM_) +import Data.List (intersperse) +import Data.Text (Text, isInfixOf) +import Text.Blaze.Html5 hiding (map) +import Text.Blaze.Html5.Attributes hiding (form) + +import Lisa.Squeak (Document(..), Lecture(..), SqueakError(..)) + +viewIndex :: Html +viewIndex = do + h1 "Lisa" + ul $ do + li $ a "Vorlesungen" ! href "/lectures" + +viewLectures :: Text -> [Lecture] -> Html +viewLectures query lectures = do + h1 $ text "Vorlesungen" + 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 + li $ do + div $ a ! href (textValue $ "/lectures/" <> id) $ 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) + table $ do + thead $ tr $ mapM_ th ["Art", "Vorlesungen", "Prüfer", "Datum", "Semester", "Seiten"] + tbody $ forM_ documents $ \document -> tr $ do + td $ text $ documentType document + td $ text $ mconcat $ intersperse ", " $ map lectureDisplayName $ documentLectures document + td $ text "TBD" + td $ string $ show $ documentDate document + td $ text $ documentSemester document + td $ string $ show $ documentNumPages document + +viewSqueakError :: SqueakError -> Html +viewSqueakError error = string $ show error