diff --git a/app/Main.hs b/app/Main.hs index 2fc267d..aee600f 100644 --- a/app/Main.hs +++ b/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" @@ -161,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 -> @@ -180,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 @@ -200,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 @@ -277,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 diff --git a/src/Yore/Download.hs b/src/Yore/Download.hs index 4e1aab3..d8eef88 100644 --- a/src/Yore/Download.hs +++ b/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 diff --git a/src/Yore/Servant.hs b/src/Yore/Servant.hs new file mode 100644 index 0000000..eb8a469 --- /dev/null +++ b/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 diff --git a/yore.cabal b/yore.cabal index 26c5c4a..e2e501c 100644 --- a/yore.cabal +++ b/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