Implement HasServer instead of using Raw

app/Main.hs

@@ -20,22 +20,19 @@ import Data.Text (Text)
 import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, toGregorian)
 import GHC.Generics (Generic)
 import Network.HTTP.Media ((//), (/:))
-import Network.HTTP.Types (Status (..), mkStatus, status200)
-import Network.Wai (Application, Request (..), Response, responseFile, responseLBS)
+import Network.HTTP.Types (Status (..))
+import Network.Wai (Request (..))
 import Servant
   ( Accept (..)
   , Capture
   , Get
   , Handler
   , MimeRender (..)
-  , Raw
   , ServerError (..)
   , ServerT
-  , Tagged (..)
   , err404
   , err500
   , hoistServer
-  , runHandler
   , serve
   , (:<|>) (..)
   , (:>)
@@ -62,18 +59,13 @@ import Yore.Download (downloadInto)
 import Yore.Error (Error (..))
 import Yore.Schedule (schedule)
 import Yore.Scrape (Issue (..), getIssuesByDay)
+import Yore.Servant (GetSendfile, Sendfile (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
 
 import qualified Envy
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
 
-newtype ConnectionString = ConnectionString String
-  deriving (Show)
-
-instance Envy.ReadEnvVar ConnectionString where
-  readEnvVar = fmap ConnectionString . Envy.readEnvVar
-
 data ConfigT f = Config
   { yorePort :: f =@@ Int ? 3000
   , yoreDownloadDir :: f =@@ FilePath ? "./download"
@@ -114,12 +106,9 @@ doIndex :: Config -> DB -> ExceptT Error IO ()
 doIndex cfg db =
   catchE
     ( DB.withTransaction db $ \conn -> do
-        dayThen <- getTodayWithOffset (-100) 0
-        indexDay cfg dayThen conn
-        dayThen2 <- getTodayWithOffset (-100) 1
-        indexDay cfg dayThen2 conn
-        dayThen3 <- getTodayWithOffset (-100) 2
-        indexDay cfg dayThen3 conn
+        forM_ [0, 1, 2] $ \i -> do
+          dayThen <- getTodayWithOffset (-100) i
+          indexDay cfg dayThen conn
     )
     (Log.error . show)
 
@@ -144,6 +133,9 @@ runServer cfg db =
           (statusCode status)
           (requestLine req)
 
+    onException mbReq ex = do
+      Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)
+
     requestLine :: Request -> String
     requestLine req =
       printf
@@ -151,9 +143,6 @@ runServer cfg db =
         (BS8.unpack $ requestMethod req)
         (BS8.unpack $ rawPathInfo req <> rawQueryString req)
 
-    onException mbReq ex = do
-      Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)
-
 nt :: ExceptT Error IO a -> Handler a
 nt action = MkHandler $ do
   res <- runExceptT action
@@ -164,11 +153,6 @@ nt action = MkHandler $ do
     Right x ->
       pure $ Right x
 
-type API =
-  Get '[HTML] RootModel
-    :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel
-    :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> Raw
-
 toServerError :: Error -> ServerError
 toServerError = \case
   ConnectionError msg ->
@@ -183,14 +167,10 @@ toServerError = \case
 encodeUtf8LBS :: String -> LBS.ByteString
 encodeUtf8LBS = LBS.fromStrict . Encoding.encodeUtf8 . Text.pack
 
-handlerToRaw :: ExceptT Error IO Response -> Tagged t Application
-handlerToRaw handler = Tagged $ \_ respond -> do
-  r <- runHandler $ nt handler
-  case r of
-    Left e ->
-      respond $ responseLBS (mkStatus e.errHTTPCode $ BS8.pack e.errReasonPhrase) e.errHeaders e.errBody
-    Right response ->
-      respond response
+type API =
+  Get '[HTML] RootModel
+    :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel
+    :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> GetSendfile
 
 server :: Config -> DB -> ServerT API (ExceptT Error IO)
 server cfg db = rootR :<|> todayR :<|> apiTodayR
@@ -203,19 +183,20 @@ server cfg db = rootR :<|> todayR :<|> apiTodayR
       dayFile <- DB.withConn db $ DB.getDayFileByIssue dateThen issue
       pure $ RootModel dateThen dayFile issue count
 
-    apiTodayR issue = handlerToRaw $ do
+    apiTodayR issue = do
       dateThen <- ExceptT get100YearsAgo
       dayFile <- DB.withConn db $ DB.getDayFileByIssue dateThen issue
       let fullPath = cfg.yoreDownloadDir </> dayFile.relative_path
       secondsUntilMidnight <- liftIO getSecondsUntilMidnight
-      pure $
-        responseFile
-          status200
-          [ ("content-type", "application/pdf")
-          , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight)
-          ]
-          fullPath
-          Nothing
+      pure
+        Sendfile
+          { headers =
+              [ ("content-type", "application/pdf")
+              , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight)
+              ]
+          , path =
+              fullPath
+          }
 
 data RootModel = RootModel Day DB.DayFile Int Int
 
@@ -280,7 +261,7 @@ indexDay cfg dayThen conn = do
       issues <- liftIO $ getIssuesByDay dayThen
       paths <- forM issues $ \issue -> do
         Log.info $ printf "downloading %s" issue.url
-        path <- liftIO $ downloadInto cfg.yoreDownloadDir issue.url
+        path <- downloadInto cfg.yoreDownloadDir issue.url
         pure (issue.label, path)
       Log.info "creating DB entries"
       dayIndex <- DB.createDayIndex dayThen conn

db/schema.sql

@@ -1,3 +1,8 @@
+\restrict VcBcXJr0fe2fRf2im7J0PCentZxDeYMChdNcReN5LtHeQrg2nXyh5MelIBAiGsO
+
+-- Dumped from database version 17.6
+-- Dumped by pg_dump version 17.6
+
 SET statement_timeout = 0;
 SET lock_timeout = 0;
 SET idle_in_transaction_session_timeout = 0;
@@ -124,6 +129,8 @@ ALTER TABLE ONLY yore.day_file
 -- PostgreSQL database dump complete
 --
 
+\unrestrict VcBcXJr0fe2fRf2im7J0PCentZxDeYMChdNcReN5LtHeQrg2nXyh5MelIBAiGsO
+
 
 --
 -- Dbmate schema migrations

flake.lock

@@ -40,11 +40,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1752536923,
-        "narHash": "sha256-fdgPZR7VFSSRIQKOJLcs3qCJBWM64Uak0gAGtWTYAd8=",
+        "lastModified": 1758518877,
+        "narHash": "sha256-1K1c6vNr/N1PfM77DqKINXQ/oCxA0W1ZJ80sfNzWu0w=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "c665e4d918eda5d78a175ed8d300809c44932160",
+        "rev": "033cc13ab4c1a60b3527b242755aa625001ff1f9",
         "type": "github"
       },
       "original": {

src/Yore/Download.hs

@@ -2,7 +2,8 @@
 
 module Yore.Download (downloadInto) where
 
-import Control.Monad (guard)
+import Control.Exception (Exception, IOException, catch)
+import Control.Monad.Trans.Except (ExceptT (..))
 import Data.Maybe (fromJust)
 import Data.Text (Text)
 import Network.HTTP.Req hiding (queryParam)
@@ -14,6 +15,8 @@ import qualified Data.Text as Text
 import qualified Data.UUID.V4 as UUID
 import qualified Text.URI as URI
 
+import Yore.Error (Error (..))
+
 -- | Download a URL and save it to a directory.
 -- Returns the path of the downloaded file relative to the directory.
 downloadInto
@@ -21,22 +24,30 @@ downloadInto
   -- ^ Directory where to store the file.
   -> Text
   -- ^ The URL to download.
-  -> IO FilePath
-downloadInto downloadDir textUrl = download >>= save
+  -> ExceptT Error IO FilePath
+downloadInto downloadDir textUrl =
+  download >>= save
   where
-    download :: IO LBS.ByteString
-    download = do
+    download :: ExceptT Error IO LBS.ByteString
+    download = toExceptT (handle @HttpException) $ do
       uri <- URI.mkURI textUrl
       let (url, opts) = fromJust $ useHttpsURI uri
       res <- runReq defaultHttpConfig $ req GET url NoReqBody lbsResponse opts
-      guard $ responseStatusCode res == 200
       pure $ responseBody res
 
-    save :: LBS.ByteString -> IO FilePath
-    save contents = do
+    save :: LBS.ByteString -> ExceptT Error IO FilePath
+    save contents = toExceptT (handle @IOException) $ do
       let suffix = takeExtension $ Text.unpack textUrl
       uuid <- UUID.nextRandom
       let fullPath = downloadDir </> show uuid <.> suffix
       createDirectoryIfMissing True downloadDir
       LBS.writeFile fullPath contents
       pure $ makeRelative downloadDir fullPath
+
+    toExceptT :: (Exception e) => (e -> Error) -> IO a -> ExceptT Error IO a
+    toExceptT showException f =
+      ExceptT $ (Right <$> f) `catch` (pure . Left . showException)
+
+    handle :: (Show e) => e -> Error
+    handle =
+      GenericError . Text.pack . show

src/Yore/Servant.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Yore.Servant (GetSendfile, Sendfile (..)) where
+
+import Network.HTTP.Types (ResponseHeaders, status200)
+import Network.Wai (responseFile)
+import Servant (HasServer (..))
+import Servant.Server.Internal.Delayed (runAction)
+import Servant.Server.Internal.RouteResult (RouteResult (..))
+import Servant.Server.Internal.Router (Router' (..))
+
+-- | Servant route type that responds with a file using @sendfile@.
+data GetSendfile
+
+data Sendfile = Sendfile
+  { headers :: ResponseHeaders
+  -- ^ The headers to send along with the file, e.g. @content-type@ or cache information.
+  , path :: FilePath
+  -- ^ The file to respond with.
+  }
+  deriving (Show)
+
+instance HasServer GetSendfile context where
+  type ServerT GetSendfile m = m Sendfile
+
+  hoistServerWithContext _ _ nt = nt
+
+  route _ _ action = RawRouter $ \env request respond ->
+    runAction action env request respond $ \sendfile ->
+      Route $ responseFile status200 sendfile.headers sendfile.path Nothing

yore.cabal

@@ -41,6 +41,7 @@ library
     , Yore.Schedule
     , Yore.Scrape
     , Yore.Time
+    , Yore.Servant
   hs-source-dirs:
       src
   build-depends:
@@ -49,16 +50,19 @@ library
     , directory
     , filepath
     , html-parse
+    , http-types
     , lens
     , modern-uri
     , mtl
     , opium
     , req
     , resource-pool
+    , servant-server
     , text
     , time
     , transformers
     , uuid
+    , wai
 
 executable yore
   import: shared-options