README.md

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

package.yaml

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

src/Lisa.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -6,17 +7,18 @@ module Lisa
     , mkConfig
     ) where
 
-import Control.Monad.IO.Class (MonadIO)
+import Control.Concurrent (MVar, newMVar, putMVar, takeMVar)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-import Network.HTTP.Types.Status (badRequest400)
+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 Web.Internal.HttpApiData (FromHttpApiData)
-import Web.Spock (ActionCtxT, SpockM, get, lazyBytes, modifySession, param, post, readSession, redirect, request, root, setHeader, setStatus, text, var, (<//>))
+import Text.Printf (printf)
+import Web.Spock (SpockAction, SpockM, ActionCtxT, get, getState, lazyBytes, param, root, setHeader, var, (<//>))
 import Web.Spock.Config (PoolOrConn(PCNoDatabase), SpockCfg, defaultSpockCfg)
 
-import Lisa.Types (Session, State, getAllLecturesCached, getLectureByIdCached, emtpySession, mkState, setSessionAuthToken)
+import Lisa.Squeak (SqueakCtx, SqueakError, Lecture)
 
 import qualified Lisa.Squeak as Squeak
 import qualified Lisa.Views as Views
@@ -29,50 +31,58 @@ 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
+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 () Session State)
+mkConfig :: IO (SpockCfg () () State)
 mkConfig = do
-    state <- mkState
-    defaultSpockCfg emtpySession PCNoDatabase state
+    now <- getCurrentTime
+    lecturesMVar <- newMVar (now, [])
+    defaultSpockCfg () PCNoDatabase (State lecturesMVar)
 
-app :: SpockM () Session State ()
+app :: SpockM () () State ()
 app = do
     get root $ do
         blaze Views.viewIndex
     
-    get ("lectures" <//> var) $ \lid -> do
-        lecture <- getLectureByIdCached lid
-        documents <- Squeak.getDocumentsByLectureId lid
-        blaze $ either Views.viewSqueakError id $ Views.viewLecture <$> lecture <*> documents
+    get ("lectures" <//> var) $ \id -> do
+        documents <- Squeak.getDocumentsByLectureId id
+        blaze $ either Views.viewSqueakError (Views.viewLecture id) 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,7 +120,6 @@ 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

@@ -1,75 +0,0 @@
-{-# 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,44 +1,45 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Lisa.Views where
+module Lisa.Views
+    ( viewIndex
+    , viewLecture
+    , viewLectures
+    , viewSqueakError
+    ) where
 
-import Prelude hiding (div, id)
+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, style)
-import Text.Blaze.Html5.Attributes hiding (form, label)
+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
 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 ! method "GET" ! action "/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 lid displayName aliases) -> do
+    ul $ forM_ (filter matchQuery lectures) $ \(Lecture id displayName aliases) -> do
         li $ do
-            div $ a ! href (textValue $ "/lectures/" <> lid) $ text displayName
+            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 :: Lecture -> [Document] -> Html
-viewLecture lecture documents = do
-    h1 $ text ("Vorlesung " <> lectureDisplayName lecture)
+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
@@ -49,32 +50,5 @@ 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"
-    snippetCodebox "Request" request
-    snippetCodebox "Session" session
-
 viewSqueakError :: SqueakError -> Html
-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
+viewSqueakError error = string $ show error