From 650fc2b8cfe2e81198e0a92ec7ae5d8a1f01df17 Mon Sep 17 00:00:00 2001
From: Clemens Schmid <nevromecs@gmail.com>
Date: Mon, 6 Jan 2025 15:41:34 +0100
Subject: [PATCH] decided to switch to a simpler http API interface

---
 src/Poseidon/CLI/Serve.hs  | 29 +++++++++++++++++++-----
 src/Poseidon/ServerHTML.hs | 46 +++++++++++++++++++++-----------------
 2 files changed, 49 insertions(+), 26 deletions(-)

diff --git a/src/Poseidon/CLI/Serve.hs b/src/Poseidon/CLI/Serve.hs
index 98dbb594a..bb3a2e4e5 100644
--- a/src/Poseidon/CLI/Serve.hs
+++ b/src/Poseidon/CLI/Serve.hs
@@ -74,6 +74,13 @@ type ArchiveStore a = [(ArchiveName, a)] -- a generic lookup table from an archi
 getArchiveNames :: ArchiveStore a -> [String]
 getArchiveNames = map fst
 
+getArchiveByName :: ArchiveName -> ArchiveStore a -> Maybe a
+getArchiveByName name store =
+    case filter (\(n, _) -> n == name) store of
+      [] -> Nothing
+      [(_,a)] -> Just a
+      _ -> Nothing
+
 runServerMainThread :: ServeOptions -> PoseidonIO ()
 runServerMainThread opts = do
     -- the MVar is used as a signal from the server to the calling thread that it is ready.
@@ -165,13 +172,25 @@ runServer (ServeOptions archBaseDirs maybeZipPath port ignoreChecksums certFiles
 
         -- landing page
         get "/" $ do
-            pacs <- getItemFromArchiveStore archiveStore
-            currentArchiveName <- param "archive" `rescue` const (return $ head archiveNames)
-            mainPage currentArchiveName archiveNames pacs
+            logRequest logA
+            mainPage archiveNames
+        -- archive pages
+        get "/:archive_name" $ do
+            logRequest logA
+            archiveName <- param "archive_name"
+            let maybePacs = getArchiveByName archiveName archiveStore
+            pacs <- case maybePacs of
+                Nothing -> raise $ "Archive " <> pack archiveName <> "does not exist"
+                Just p -> return p
+            archivePage archiveName pacs
         -- per package pages
-        get "/package/:package_name" $ do
+        get "/:archive_name/:package_name" $ do
             logRequest logA
-            pacs <- getItemFromArchiveStore archiveStore
+            archiveName <- param "archive_name"
+            let maybePacs = getArchiveByName archiveName archiveStore
+            pacs <- case maybePacs of
+               Nothing -> raise $ "Archive " <> pack archiveName <> "does not exist"
+               Just p -> return p
             packageName <- param "package_name"
             maybeVersionString <- (Just <$> param "package_version") `rescue` (\_ -> return Nothing)
             maybeVersion <- case maybeVersionString of
diff --git a/src/Poseidon/ServerHTML.hs b/src/Poseidon/ServerHTML.hs
index 527ce900f..aaf106562 100644
--- a/src/Poseidon/ServerHTML.hs
+++ b/src/Poseidon/ServerHTML.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
-module Poseidon.ServerHTML (mainPage, packagePage) where
+module Poseidon.ServerHTML (mainPage, archivePage, packagePage) where
 
 import Poseidon.Package
 import Poseidon.EntityTypes
@@ -25,31 +25,35 @@ jscript = [text|
 
 |]
 
-mainPage :: String -> [String] -> [PoseidonPackage] -> S.ActionM ()
-mainPage currentArchiveName archiveNames pacs = S.html $ renderMarkup $ do
+mainPage :: [String] -> S.ActionM ()
+mainPage archiveNames = S.html $ renderMarkup $ do
   H.html $ do
     H.head $ do
       H.script ! A.type_ "text/javascript" $ H.text jscript
     H.body $ do
-      H.form ! A.action "/" ! A.method "get" $ do
-          H.select ! A.name "archive" ! A.onchange "this.form.submit()" $ do
-              mapM_ (\archiveName ->
-                  let isSelected = if archiveName == currentArchiveName
-                                   then H.option ! A.selected "selected"
-                                   else H.option
-                  in isSelected $ H.string archiveName
-                  ) archiveNames
-      H.h1 "Poseidon packages"
+      H.h1 "Poseidon public archives"
+      H.ul $ mapM_ (\archiveName -> H.li $ H.div $ do
+              H.a ! A.href ("/" <> H.toValue archiveName) $
+                H.toMarkup archiveName
+          ) archiveNames
+
+archivePage :: String -> [PoseidonPackage] -> S.ActionM ()
+archivePage archiveName pacs = S.html $ renderMarkup $ do
+  H.html $ do
+    H.head $ do
+      H.script ! A.type_ "text/javascript" $ H.text jscript
+    H.body $ do
+      H.h1 $ H.toMarkup archiveName
       H.ul $ mapM_ (\pac -> H.li $ H.div $ do
-              let pacName = getPacName pac
-                  pacVersion = getPacVersion pac
-                  pacNameAndVersion = renderNameWithVersion $ posPacNameAndVersion pac
-              H.a ! A.href ("/package/" <> H.toValue pacName <> "?package_version=" <> renderMaybeVersion pacVersion) $
-                H.toMarkup pacNameAndVersion
-              H.toMarkup (" | " :: String)
-              H.a ! A.href ("/zip_file/" <> H.toValue pacName <> "?package_version=" <> renderMaybeVersion pacVersion) $
-                H.toMarkup ("Download" :: String)
-          ) pacs
+          let pacName = getPacName pac
+              pacVersion = getPacVersion pac
+              pacNameAndVersion = renderNameWithVersion $ posPacNameAndVersion pac
+          H.a ! A.href ("/" <>  H.toValue archiveName <> "/" <> H.toValue pacName <> "?package_version=" <> renderMaybeVersion pacVersion) $
+            H.toMarkup pacNameAndVersion
+          H.toMarkup (" | " :: String)
+          H.a ! A.href ("/zip_file/" <> H.toValue pacName <> "?package_version=" <> renderMaybeVersion pacVersion) $
+            H.toMarkup ("Download" :: String)
+        ) pacs
 
 packagePage :: PoseidonPackage -> S.ActionM ()
 packagePage pac = S.html $ renderMarkup $ do