Add label to indexed files, implement rudimentary server

app/Main.hs

@@ -1,12 +1,86 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main (main) where
 
-import qualified Data.Text.IO as TextIO
+import Control.Concurrent (getNumCapabilities)
+import Control.Exception (Exception, throwIO)
+import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
+import Data.Proxy (Proxy (..))
+import Data.Text (Text)
+import Network.HTTP.Media ((//), (/:))
+import Network.HTTP.Types (status200)
+import Servant (Accept (..), Get, Server, serve, MimeRender (..), (:<|>) (..), (:>), Raw, Capture, Tagged (..))
+import System.FilePath ((</>))
+import Text.Blaze.Html5 ((!))
+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
+import Text.Printf (printf)
 
-import Yore.Repl (getToday)
+import qualified Data.Text as Text
+import qualified Database.PostgreSQL.Opium as Opium
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+import Network.Wai (responseFile)
+
+import Yore.DB (DayFile (..))
+import Yore.Time (addYears, getCurrentDay)
+
+import qualified Yore.DB as DB
+
+instance Exception Opium.ConnectionError
 
 main :: IO ()
 main = do
-  putStrLn "* Getting URLs for today..."
-  urls <- getToday
-  putStrLn "* Done:"
-  mapM_ TextIO.putStrLn urls
+  capabilities <- getNumCapabilities
+  let maxResources = capabilities
+  connPool <- newPool $ defaultPoolConfig
+    (unsafeConnect "host=localhost port=5433 user=yore-test dbname=yore-test")
+    Opium.close
+    10
+    maxResources
+  Warp.run 3000 $ serve (Proxy :: Proxy API) $ server connPool
+
+  where
+    unsafeConnect s = either throwIO pure =<< Opium.connect s
+
+type API
+  = Get '[HTML] RootModel
+  :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel
+  :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> Raw
+
+server :: Pool Opium.Connection -> Server API
+server connPool = rootR :<|> todayR :<|> apiTodayR
+  where
+    rootR =
+      pure $ RootModel "/api/today/issue/0/fz.pdf"
+
+    todayR issue =
+      pure $ RootModel $ Text.pack $ printf "/api/today/issue/%d/fz.pdf" issue
+
+    apiTodayR issue =
+      Tagged $ \_ respond -> do
+        dateNow <- getCurrentDay
+        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
+
+instance MimeRender HTML RootModel where
+  mimeRender _ (RootModel url) = renderHtml $ do
+    H.docTypeHtml $ do
+      H.body ! A.style "margin: 0" $ do
+        H.iframe ! A.src (H.toValue url) ! A.style "width: 100vw; height: 100vh; border: 0;" $ mempty
+
+-- Utils
+
+data HTML
+
+instance Accept HTML where
+  contentType _ = "text" // "html" /: ("charset", "utf-8")