Add login page

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

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

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

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

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
+    snippetCodebox "Request" request
-        legend "Request"
+    snippetCodebox "Session" session
-        pre ! style (textValue "white-space: pre-wrap") $ string $ show request
-    fieldset $ do
-        legend "Session"
-        pre ! style (textValue "white-space: pre-wrap") $ string $ show 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