Implement HasServer instead of using Raw

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