From 98ef5054539b134bb4e8bf4e98dd1edf79c440c2 Mon Sep 17 00:00:00 2001
From: Paul Brinkmeier <hallo@pbrinkmeier.de>
Date: Wed, 21 Sep 2022 23:40:06 +0200
Subject: [PATCH] Add orders route

---
 src/Lisa.hs        |  9 +++++++++
 src/Lisa/Squeak.hs | 22 ++++++++++++++++++++--
 src/Lisa/Views.hs  | 14 +++++++++++++-
 3 files changed, 42 insertions(+), 3 deletions(-)

diff --git a/src/Lisa.hs b/src/Lisa.hs
index 4a2924f..c6ae1e2 100644
--- a/src/Lisa.hs
+++ b/src/Lisa.hs
@@ -45,6 +45,11 @@ 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)
@@ -66,6 +71,10 @@ app = 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
 
diff --git a/src/Lisa/Squeak.hs b/src/Lisa/Squeak.hs
index 087cd53..75b2b8e 100644
--- a/src/Lisa/Squeak.hs
+++ b/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)
 
diff --git a/src/Lisa/Views.hs b/src/Lisa/Views.hs
index ec44a4b..bb8c5fe 100644
--- a/src/Lisa/Views.hs
+++ b/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"