Add CI config

.drone.yml

@@ -0,0 +1,9 @@
+---
+kind: pipeline
+type: docker
+name: default
+steps:
+  - name: stack build
+    image: haskell:9.2.4-slim
+    commands:
+      - stack build

README.md

@@ -3,3 +3,9 @@
 > 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
+- Record times: How long did HTTP requests take?

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, liftIO)
+import Control.Monad.IO.Class (MonadIO)
 import Data.Maybe (fromMaybe)
-import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime)
-import Network.HTTP.Req (https)
+import Data.Text (Text)
+import Network.HTTP.Types.Status (Status, badRequest400, internalServerError500)
 import Text.Blaze.Html (Html)
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
-import Text.Printf (printf)
-import Web.Spock (SpockAction, SpockM, ActionCtxT, get, getState, lazyBytes, param, 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.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,66 @@ 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
+-- | 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
 
--- State
+-- TODO: Generalize, introduce some sort of Lisa.Types.Error type
+-- TODO: Make more readable
+onLeft :: MonadIO m => (ActionCtxT ctx m (Either e a)) -> (Status, Text) -> ActionCtxT ctx m a
+onLeft f (status, message) = f >>= (flip either pure $ \_ -> do
+    setStatus status
+    text message)
 
-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
+onLeftBlaze :: MonadIO m => (ActionCtxT ctx m (Either e a)) -> (Status, e -> Html) -> ActionCtxT ctx m a
+onLeftBlaze f (status, view) = f >>= (flip either pure $ \err -> do
+    setStatus status
+    blaze $ view err)
 
 -- Exports
 
-mkConfig :: IO (SpockCfg () () State)
+mkConfig :: IO (SpockCfg () Session State)
 mkConfig = do
-    now <- getCurrentTime
-    lecturesMVar <- newMVar (now, [])
-    defaultSpockCfg () PCNoDatabase (State lecturesMVar)
+    state <- mkState
+    defaultSpockCfg emtpySession PCNoDatabase state
 
-app :: SpockM () () State ()
+app :: SpockM () Session State ()
 app = do
     get root $ do
         blaze Views.viewIndex
     
-    get ("lectures" <//> var) $ \id -> do
-        documents <- Squeak.getDocumentsByLectureId id
-        blaze $ either Views.viewSqueakError (Views.viewLecture id) documents
+    get ("lectures" <//> var) $ \lid -> do
+        lecture <- getLectureByIdCached lid `onLeft` (internalServerError500, "Failed to retrieve lectures")
+        documents <- Squeak.getDocumentsByLectureId lid `onLeft` (internalServerError500, "Failed to retrieve documents")
+        blaze $ Views.viewLecture lecture documents
 
     get "lectures" $ do
         query <- fromMaybe "" <$> param "query"
         lectures <- getAllLecturesCached
         blaze $ either Views.viewSqueakError (Views.viewLectures query) lectures
+    
+    get "orders" $ do
+        orders <- Squeak.getAllPendingOrders `onLeftBlaze` (internalServerError500, Views.viewSqueakError)
+        blaze $ Views.viewOrders orders
+
+    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

@@ -11,6 +11,7 @@ import Data.Aeson (FromJSON(parseJSON), Options(fieldLabelModifier), ToJSON(toJS
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Calendar (Day)
+import Data.Time.LocalTime (ZonedTime)
 import GHC.Generics (Generic)
 import Network.HTTP.Req (Option, Scheme(..), POST(..), ReqBodyJson(..), Url, defaultHttpConfig, header, http, port, jsonResponse, responseBody, req, runReq)
 
@@ -102,6 +103,13 @@ instance FromJSON Documents where
     parseJSON = withObject "Documents" $ \v -> Documents
         <$> ((v .: "documents") >>= (.: "results"))
 
+data Orders = Orders { unOrders :: [Order] }
+    deriving (Show)
+
+instance FromJSON Orders where
+    parseJSON = withObject "Orders" $ \v -> Orders
+        <$> ((v .: "orders") >>= (.: "results"))
+
 -- | Helper for automatically writing 'FromJSON' instances.
 --
 -- >>> removePrefixModifier "document" "documentId"
@@ -120,6 +128,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
@@ -187,6 +196,14 @@ getDocumentsByLectureId lecture = fmap unDocuments <$> joinErrors <$> mkQueryWit
     \  } \
     \}"
 
+getAllPendingOrders :: (SqueakCtx m, MonadIO m) => m (Either SqueakError [Order])
+getAllPendingOrders = fmap unOrders <$> joinErrors <$> mkQuery
+    "{ orders(filters: {state: PENDING}) \
+    \ { results \
+    \   { id created numPages price tag } \
+    \ } \
+    \}"
+
 -- Mutations
 
 data LoginResult = LoginResult { unLoginResult :: SqueakErrorOr Credentials }
@@ -254,8 +271,10 @@ instance (FromJSON CreateOrderResult) where
 
 data Order = Order
     { orderId       :: Text
-    , orderTag      :: Text
+    , orderCreated  :: ZonedTime
     , orderNumPages :: Int
+    , orderPrice    :: Double
+    , orderTag      :: Text
     }
     deriving (Generic, Show)
 

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,45 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Lisa.Views
-    ( viewIndex
-    , viewLecture
-    , viewLectures
-    , viewSqueakError
-    ) where
+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 Text.Blaze.Html5 hiding (map)
-import Text.Blaze.Html5.Attributes hiding (form)
+import Network.Wai (Request)
+import Text.Blaze.Html5 hiding (map, style)
+import Text.Blaze.Html5.Attributes hiding (form, label)
 
-import Lisa.Squeak (Document(..), Lecture(..), SqueakError(..))
+import Lisa.Types (Session)
+import Lisa.Squeak (Document(..), Lecture(..), Order(..), SqueakError(..))
 
 viewIndex :: Html
 viewIndex = do
     h1 "Lisa"
     ul $ do
+        li $ a "Login" ! href "/login"
         li $ a "Vorlesungen" ! href "/lectures"
+        li $ a "Bestellungen" ! href "/orders"
+        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 id documents = do
-    h1 $ text ("Vorlesung " <> id)
+viewLecture :: Lecture -> [Document] -> Html
+viewLecture lecture documents = do
+    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 +50,43 @@ viewLecture id documents = do
             td $ text $ documentSemester document
             td $ string $ show $ documentNumPages document
 
+viewOrders :: [Order] -> Html
+viewOrders orders = do
+    h1 $ text "Bestellungen"
+    table $ do
+        thead $ mapM_ th ["Bezeichner", "Seiten", "Preis", "Erstellt"]
+        tbody $ forM_ orders $ \order -> tr $ do
+            td $ text $ orderTag order
+            td $ string $ show $ orderNumPages order
+            td $ string $ show $ orderPrice order
+            td $ string $ show $ orderCreated order
+
+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