Merge rootR and todayR

app/Main.hs

@@ -5,10 +5,11 @@
 module Main (main) where
 
 import Control.Concurrent (getNumCapabilities)
-import Control.Exception (Exception, throwIO)
+import Control.Exception (ErrorCall (..), Exception, throwIO)
+import Control.Monad.IO.Class (liftIO)
 import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
 import Data.Proxy (Proxy (..))
-import Data.Text (Text)
+import Data.Time (Day, toGregorian)
 import Network.HTTP.Media ((//), (/:))
 import Network.HTTP.Types (status200)
 import Servant
@@ -64,30 +65,51 @@ type API
 server :: Pool Opium.Connection -> Server API
 server connPool = rootR :<|> todayR :<|> apiTodayR
   where
-    rootR =
+    rootR = todayR 0
-      pure $ RootModel "/api/today/issue/0/fz.pdf"
 
-    todayR issue =
+    todayR issue = do
-      pure $ RootModel $ Text.pack $ printf "/api/today/issue/%d/fz.pdf" issue
+      dateThen <- liftIO $ get100YearsAgo
+      Right count <- liftIO $ withResource connPool $ DB.getNumberOfIssues dateThen
+      Right dayFile <- liftIO $ withResource connPool $ DB.getDayFileByIssue dateThen issue
+      pure $ RootModel dateThen dayFile issue count
 
     apiTodayR issue =
       Tagged $ \_ respond -> do
-        dateNow <- getCurrentDay
+        dateThen <- get100YearsAgo
-        let Just dateThen = addYears (-100) dateNow
-        print dateThen
         res <- withResource connPool $ DB.getDayFileByIssue dateThen issue
         dayFile <- either throwIO pure res
         let fullPath = "download" </> dayFile.relative_path
 
         respond $ responseFile status200 [("content-type", "application/pdf")] fullPath Nothing
 
-newtype RootModel = RootModel Text
+data RootModel = RootModel Day DB.DayFile Int Int
 
 instance MimeRender HTML RootModel where
-  mimeRender _ (RootModel url) = renderHtml $ do
+  mimeRender _ (RootModel dateThen dayFile issue count) = renderHtml $ do
     H.docTypeHtml $ do
-      H.body ! A.style "margin: 0" $ do
+      H.head $ do
-        H.iframe ! A.src (H.toValue url) ! A.style "width: 100vw; height: 100vh; border: 0;" $ mempty
+        H.style "body { margin: 0; font-family: Helvetica, sans-serif; } .layout { display: flex; flex-direction: column; width: 100vw; height: 100vh; } .topbar { user-select: none; text-align: center; padding: .5em; } .content { flex: 1; } iframe { border: 0; }"
+      H.body $ do
+        H.div ! A.class_ "layout" $ do
+          H.div ! A.class_ "topbar" $ do
+            let (y, m, d) = toGregorian dateThen
+            H.text $ Text.pack $ printf "Freiburger Zeitung ⊛ %02d.%02d.%04d" d m y
+            H.br
+            buildLink "⟽" (issue - 1)
+            H.text $ " " <> dayFile.label <> " "
+            buildLink "⟾" (issue + 1)
+          H.iframe ! A.src (H.toValue url) ! A.class_ "content" $ mempty
+    where
+      url :: String
+      url = printf "/api/today/issue/%d/fz.pdf" issue
+
+      buildLink label issue'
+        | issue' == 0 =
+          H.a ! A.href "/" $ label
+        | issue' > 0 && issue' < count =
+          H.a ! A.href (H.toValue (printf "/today/issue/%d" issue' :: String)) $ label
+        | otherwise =
+          H.span ! A.style "color: grey;" $ label
 
 -- Utils
 
@@ -95,3 +117,8 @@ data HTML
 
 instance Accept HTML where
   contentType _ = "text" // "html" /: ("charset", "utf-8")
+
+get100YearsAgo :: IO Day
+get100YearsAgo = do
+  dateNow <- getCurrentDay
+  maybe (throwIO $ ErrorCall "cant go back 100 years") pure $ addYears (-100) dateNow

src/Yore/DB.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# OPTIONS_GHC -Wno-deriving-defaults #-}
 
 module Yore.DB
   ( DayIndex (..)
@@ -10,6 +11,7 @@ module Yore.DB
   , readDayIndex
   , readDayPaths
   , getDayFileByIssue
+  , getNumberOfIssues
   , Table (..)
   , getTables
 ) where
@@ -41,6 +43,10 @@ data DayFile = DayFile
   , relative_path :: FilePath
   } deriving (Show, Generic, Opium.FromRow)
 
+newtype CountResult = CountResult
+  { count :: Int
+  } deriving (Show, Generic, Opium.FromRow)
+
 createDayIndex :: Day -> Opium.Connection -> IO (Either Opium.Error DayIndex)
 createDayIndex date = ex runIdentity .
   Opium.fetch
@@ -70,5 +76,11 @@ getDayFileByIssue date issue = ex runIdentity .
     "SELECT yore.day_file.* FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1 ORDER BY day_file_id LIMIT 1 OFFSET $2"
     (date, issue)
 
+getNumberOfIssues :: Day -> Opium.Connection -> IO (Either Opium.Error Int)
+getNumberOfIssues date = ex (count . runIdentity) .
+  Opium.fetch
+    "SELECT count(*) FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1"
+    (Identity date)
+
 ex :: (a -> b) -> IO (Either e a) -> IO (Either e b)
 ex = fmap . fmap