From bedd09466954d644289f849728c2c9ae8980bef0 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Thu, 8 Sep 2022 20:10:41 +0200 Subject: [PATCH] Add login page --- lisa.cabal | 6 ++++++ package.yaml | 2 ++ src/Lisa.hs | 29 +++++++++++++++++++++++++++-- src/Lisa/Types.hs | 11 +++++++---- src/Lisa/Views.hs | 38 ++++++++++++++++++++++++++++---------- 5 files changed, 70 insertions(+), 16 deletions(-) diff --git a/lisa.cabal b/lisa.cabal index de93a06..70e98ef 100644 --- a/lisa.cabal +++ b/lisa.cabal @@ -39,6 +39,8 @@ library , aeson >=2.0 , base >=4.7 && <5 , blaze-html >=0.9 + , http-api-data >=0.4 + , http-types >=0.12 , pretty-simple >=4.1 , req >=3.10 , text >=1.0 @@ -58,6 +60,8 @@ executable lisa-exe , aeson >=2.0 , base >=4.7 && <5 , blaze-html >=0.9 + , http-api-data >=0.4 + , http-types >=0.12 , lisa , pretty-simple >=4.1 , req >=3.10 @@ -79,6 +83,8 @@ test-suite lisa-test , aeson >=2.0 , base >=4.7 && <5 , blaze-html >=0.9 + , http-api-data >=0.4 + , http-types >=0.12 , lisa , pretty-simple >=4.1 , req >=3.10 diff --git a/package.yaml b/package.yaml index cf72fd4..8c4addf 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,8 @@ dependencies: - base >= 4.7 && < 5 - aeson >= 2.0 - blaze-html >= 0.9 +- http-api-data >= 0.4 +- http-types >= 0.12 - pretty-simple >= 4.1 - req >= 3.10 - Spock >= 0.14 diff --git a/src/Lisa.hs b/src/Lisa.hs index 61b8b52..73c107a 100644 --- a/src/Lisa.hs +++ b/src/Lisa.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Lisa @@ -7,12 +8,15 @@ module Lisa import Control.Monad.IO.Class (MonadIO) import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Network.HTTP.Types.Status (badRequest400) import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) -import Web.Spock (SpockM, ActionCtxT, get, lazyBytes, param, readSession, request, root, setHeader, var, ()) +import Web.Internal.HttpApiData (FromHttpApiData) +import Web.Spock (ActionCtxT, SpockM, get, lazyBytes, modifySession, param, post, readSession, redirect, request, root, setHeader, setStatus, text, var, ()) import Web.Spock.Config (PoolOrConn(PCNoDatabase), SpockCfg, defaultSpockCfg) -import Lisa.Types (Session, State, emtpySession, mkState, getAllLecturesCached) +import Lisa.Types (Session, State, getAllLecturesCached, emtpySession, mkState, setSessionAuthToken) import qualified Lisa.Squeak as Squeak import qualified Lisa.Views as Views @@ -25,6 +29,15 @@ blaze html = do setHeader "Content-Type" "text/html; charset=utf-8" lazyBytes $ renderHtml html +-- | Like 'Web.Spock.param'', but uses status 400 instead of 500. +requiredParam :: (FromHttpApiData a, MonadIO m) => Text -> ActionCtxT ctx m a +requiredParam k = param k >>= \case + Nothing -> do + setStatus badRequest400 + text $ "Parameter " <> k <> " is required" + Just val -> + pure val + -- Exports mkConfig :: IO (SpockCfg () Session State) @@ -46,6 +59,18 @@ app = do lectures <- getAllLecturesCached blaze $ either Views.viewSqueakError (Views.viewLectures query) lectures + get "login" $ blaze Views.viewLogin + + post "login" $ do + username <- requiredParam "username" + password <- requiredParam "password" + + Squeak.login username password >>= \case + Left err -> blaze $ Views.viewSqueakError err + Right (Squeak.Credentials authToken _user) -> do + modifySession $ setSessionAuthToken authToken + redirect "/" + get "debug" $ do req <- request sess <- readSession diff --git a/src/Lisa/Types.hs b/src/Lisa/Types.hs index 2f98a59..f02804c 100644 --- a/src/Lisa/Types.hs +++ b/src/Lisa/Types.hs @@ -10,7 +10,7 @@ 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 Web.Spock (SpockAction, getState, readSession) import Lisa.Squeak (Lecture, SqueakCtx, SqueakError) @@ -24,6 +24,9 @@ data Session = Session emtpySession :: Session emtpySession = Session Nothing +setSessionAuthToken :: Text -> Session -> Session +setSessionAuthToken authToken session = session { sessionAuthToken = Just authToken } + -- | Global application state. data State = State { stateLectures :: MVar (UTCTime, [Lecture]) -- ^ Cached lectures with cache expiration time. @@ -37,7 +40,7 @@ mkState = do -- | 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 :: SpockAction conn Session State (Either SqueakError [Lecture]) getAllLecturesCached = do lecturesMVar <- stateLectures <$> getState (expirationTime, lectures) <- liftIO $ takeMVar lecturesMVar @@ -58,6 +61,6 @@ getAllLecturesCached = do liftIO $ putMVar lecturesMVar newContents pure result -instance SqueakCtx (SpockAction conn sess State) where +instance SqueakCtx (SpockAction conn Session State) where getLocationInfo = pure $ Right (https "api.squeak-test.fsmi.uni-karlsruhe.de", mempty) - getAuthToken = pure Nothing + getAuthToken = fmap sessionAuthToken readSession diff --git a/src/Lisa/Views.hs b/src/Lisa/Views.hs index 214faab..7f2a38f 100644 --- a/src/Lisa/Views.hs +++ b/src/Lisa/Views.hs @@ -2,14 +2,14 @@ module Lisa.Views where -import Prelude hiding (div) +import Prelude hiding (div, id) import Control.Monad (forM_) import Data.List (intersperse) import Data.Text (Text, isInfixOf) import Network.Wai (Request) import Text.Blaze.Html5 hiding (map, style) -import Text.Blaze.Html5.Attributes hiding (form) +import Text.Blaze.Html5.Attributes hiding (form, label) import Lisa.Types (Session) import Lisa.Squeak (Document(..), Lecture(..), SqueakError(..)) @@ -18,13 +18,14 @@ viewIndex :: Html viewIndex = do h1 "Lisa" ul $ do + li $ a "Login" ! href "/login" li $ a "Vorlesungen" ! href "/lectures" li $ a "Debuginformation" ! href "/debug" viewLectures :: Text -> [Lecture] -> Html viewLectures query lectures = do h1 $ text "Vorlesungen" - form ! action "/lectures" ! method "GET" $ do + form ! method "GET" ! action "/lectures" $ do input ! name "query" ! value (textValue query) button ! type_ "submit" $ text "Filtern" ul $ forM_ (filter matchQuery lectures) $ \(Lecture lid displayName aliases) -> do @@ -48,15 +49,32 @@ viewLecture lecture documents = do td $ text $ documentSemester document td $ string $ show $ documentNumPages document +viewLogin :: Html +viewLogin = do + h1 $ text "FSMI-Login" + form ! method "POST" ! action "/login" $ do + div $ do + label ! for (textValue "username") $ text "Benutzername" + input ! name "username" ! id "username" + div $ do + label ! for (textValue "password") $ text "Passwort" + input ! type_ "password" ! name "password" ! id "password" + button ! type_ "submit" $ text "Einloggen" + viewDebug :: Request -> Session -> Html viewDebug request session = do h1 $ text "Debuginformation" - fieldset $ do - legend "Request" - pre ! style (textValue "white-space: pre-wrap") $ string $ show request - fieldset $ do - legend "Session" - pre ! style (textValue "white-space: pre-wrap") $ string $ show session + snippetCodebox "Request" request + snippetCodebox "Session" session viewSqueakError :: SqueakError -> Html -viewSqueakError err = string $ show err +viewSqueakError err = do + h1 $ text "Ein Fehler ist aufgetreten" + snippetCodebox "Fehler" err + +-- snippets +snippetCodebox :: Show a => Text -> a -> Html +snippetCodebox codeboxLabel x = + fieldset $ do + legend $ text codeboxLabel + pre ! style (textValue "white-space: pre-wrap; word-wrap: anywhere") $ string $ show x