Add getLectureByIdCached function

README.md

@@ -3,3 +3,8 @@
 > lightweight squeak access
 
 Webserver that offers an HTML-only interface to Squeak.
+
+## TODO
+
+- Improve error handling: Write functions that turn `Maybe` and `Either` `SpockAction`s that return `4xx` or `5xx`.
+- Document JSON stuff

lisa.cabal

@@ -27,6 +27,7 @@ library
   exposed-modules:
       Lisa
       Lisa.Squeak
+      Lisa.Types
       Lisa.Views
   other-modules:
       Paths_lisa
@@ -38,9 +39,13 @@ 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
-    , time >=1.13
+    , time >=1.11
+    , wai >=3.2
   default-language: Haskell2010
 
 executable lisa-exe
@@ -55,10 +60,14 @@ 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
     , text >=1.0
-    , time >=1.13
+    , time >=1.11
+    , wai >=3.2
   default-language: Haskell2010
 
 test-suite lisa-test
@@ -74,8 +83,12 @@ 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
     , text >=1.0
-    , time >=1.13
+    , time >=1.11
+    , wai >=3.2
   default-language: Haskell2010

package.yaml

@@ -23,10 +23,14 @@ 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
 - text >= 1.0
-- time >= 1.13
+- time >= 1.11
+- wai >= 3.2
 
 library:
   source-dirs: src

src/Lisa.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -7,18 +6,17 @@ module Lisa
     , mkConfig
     ) where
 
-import Control.Concurrent (MVar, newMVar, putMVar, takeMVar)
+import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Maybe (fromMaybe)
-import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime)
+import Data.Text (Text)
-import Network.HTTP.Req (https)
+import Network.HTTP.Types.Status (badRequest400)
 import Text.Blaze.Html (Html)
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
-import Text.Printf (printf)
+import Web.Internal.HttpApiData (FromHttpApiData)
-import Web.Spock (SpockAction, SpockM, ActionCtxT, get, getState, lazyBytes, param, root, setHeader, var, (<//>))
+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.Squeak (SqueakCtx, SqueakError, Lecture)
+import Lisa.Types (Session, State, getAllLecturesCached, getLectureByIdCached, emtpySession, mkState, setSessionAuthToken)
 
 import qualified Lisa.Squeak as Squeak
 import qualified Lisa.Views as Views
@@ -31,58 +29,50 @@ blaze html = do
     setHeader "Content-Type" "text/html; charset=utf-8"
     lazyBytes $ renderHtml html
 
-instance SqueakCtx (SpockAction () () State) where
+-- | Like 'Web.Spock.param'', but uses status 400 instead of 500.
-    getLocationInfo = pure $ Right (https "api.squeak-test.fsmi.uni-karlsruhe.de", mempty)
+requiredParam :: (FromHttpApiData a, MonadIO m) => Text -> ActionCtxT ctx m a
-    getAuthToken = pure Nothing
+requiredParam k = param k >>= \case
-
+    Nothing -> do
--- State
+        setStatus badRequest400
-
+        text $ "Parameter " <> k <> " is required"
-data State = State
+    Just val ->
-    { stateLectures :: MVar (UTCTime, [Lecture]) -- ^ Cached lectures with cache expiration time.
+        pure val
-    }
-
--- | 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
+    state <- mkState
-    lecturesMVar <- newMVar (now, [])
+    defaultSpockCfg emtpySession PCNoDatabase state
-    defaultSpockCfg () PCNoDatabase (State lecturesMVar)
 
-app :: SpockM () () State ()
+app :: SpockM () Session State ()
 app = do
     get root $ do
         blaze Views.viewIndex
     
-    get ("lectures" <//> var) $ \id -> do
+    get ("lectures" <//> var) $ \lid -> do
-        documents <- Squeak.getDocumentsByLectureId id
+        lecture <- getLectureByIdCached lid
-        blaze $ either Views.viewSqueakError (Views.viewLecture id) documents
+        documents <- Squeak.getDocumentsByLectureId lid
+        blaze $ either Views.viewSqueakError id $ Views.viewLecture <$> lecture <*> documents
 
     get "lectures" $ do
         query <- fromMaybe "" <$> param "query"
         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
+        blaze $ Views.viewDebug req sess

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

src/Lisa/Types.hs

@@ -0,0 +1,75 @@
+{-# 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.List (find)
+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, readSession)
+
+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
+
+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.
+    }
+
+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 Session 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
+
+getLectureByIdCached :: Text -> SpockAction conn Session State (Either SqueakError Lecture)
+getLectureByIdCached lid = do
+    lectures <- getAllLecturesCached
+    pure $ lectures >>= findLecture
+    where
+        findLecture =
+            maybe (Left $ SqueakError "LISA" "Lecture does not exist") Right . find ((lid ==) . lectureId)
+
+instance SqueakCtx (SpockAction conn Session State) where
+    getLocationInfo = pure $ Right (https "api.squeak-test.fsmi.uni-karlsruhe.de", mempty)
+    getAuthToken = fmap sessionAuthToken readSession

src/Lisa/Views.hs

@@ -1,45 +1,44 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Lisa.Views
+module Lisa.Views where
-    ( viewIndex
-    , viewLecture
-    , viewLectures
-    , viewSqueakError
-    ) where
 
-import Prelude hiding (div)
+import Prelude hiding (div, id)
 
 import Control.Monad (forM_)
 import Data.List (intersperse)
 import Data.Text (Text, isInfixOf)
-import Text.Blaze.Html5 hiding (map)
+import Network.Wai (Request)
-import Text.Blaze.Html5.Attributes hiding (form)
+import Text.Blaze.Html5 hiding (map, style)
+import Text.Blaze.Html5.Attributes hiding (form, label)
 
+import Lisa.Types (Session)
 import Lisa.Squeak (Document(..), Lecture(..), SqueakError(..))
 
 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 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 :: Lecture -> [Document] -> Html
-viewLecture id documents = do
+viewLecture lecture documents = do
-    h1 $ text ("Vorlesung " <> id)
+    h1 $ text ("Vorlesung " <> lectureDisplayName lecture)
     table $ do
         thead $ tr $ mapM_ th ["Art", "Vorlesungen", "Prüfer", "Datum", "Semester", "Seiten"]
         tbody $ forM_ documents $ \document -> tr $ do
@@ -50,5 +49,32 @@ viewLecture id 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"
+    snippetCodebox "Request" request
+    snippetCodebox "Session" session
+
 viewSqueakError :: SqueakError -> Html
-viewSqueakError error = string $ show error
+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