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

@@ -8,3 +8,4 @@ Webserver that offers an HTML-only interface to Squeak.
 
 - 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?

src/Lisa.hs

@@ -9,7 +9,7 @@ module Lisa
 import Control.Monad.IO.Class (MonadIO)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import Network.HTTP.Types.Status (badRequest400)
+import Network.HTTP.Types.Status (Status, badRequest400, internalServerError500)
 import Text.Blaze.Html (Html)
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
 import Web.Internal.HttpApiData (FromHttpApiData)
@@ -38,6 +38,18 @@ requiredParam k = param k >>= \case
     Just val ->
         pure val
 
+-- 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)
+
+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 () Session State)
@@ -51,14 +63,18 @@ app = 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
+        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
 

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"
@@ -182,12 +190,20 @@ getDocumentsByLectureId :: (SqueakCtx m, MonadIO m) => Text -> m (Either SqueakE
 getDocumentsByLectureId lecture = fmap unDocuments <$> joinErrors <$> mkQueryWithVars
     (object ["lecture" .= lecture])
     "query DocumentsByLectureId($lecture: LectureId!) \
-    \ { documents(filters: [{ lectures: [$lecture] }]) \
+    \{ documents(filters: [{ lectures: [$lecture] }]) \
     \  { results \
     \    { id date semester publicComment downloadable faculty { id displayName } lectures { id displayName aliases } type numPages } \
     \  } \
     \}"
 
+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 }
@@ -255,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/Views.hs

@@ -12,7 +12,7 @@ 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(..))
+import Lisa.Squeak (Document(..), Lecture(..), Order(..), SqueakError(..))
 
 viewIndex :: Html
 viewIndex = do
@@ -20,6 +20,7 @@ viewIndex = do
     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
@@ -49,6 +50,17 @@ viewLecture lecture 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"