Add debug route and refactor some code

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

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

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)
-import Control.Monad.IO.Class (MonadIO, liftIO)
 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 (SpockM, ActionCtxT, get, lazyBytes, param, readSession, request, root, setHeader, var, (<//>))
-import Web.Spock (SpockAction, SpockM, ActionCtxT, get, getState, lazyBytes, param, 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
+    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
+        documents <- Squeak.getDocumentsByLectureId lid
-        blaze $ either Views.viewSqueakError (Views.viewLecture id) documents
+        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

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,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

src/Lisa/Views.hs

@@ -1,20 +1,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Lisa.Views
+module Lisa.Views where
-    ( viewIndex
-    , viewLecture
-    , viewLectures
-    , viewSqueakError
-    ) 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
+viewLecture lecture documents = do
-    h1 $ text ("Vorlesung " <> id)
+    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