fix(live): support custom `Content-Type`

[haskell/literate-web.git] / src / Literate / Web / Semantics / Compiler.hs

diff --git a/src/Literate/Web/Semantics/Compiler.hs b/src/Literate/Web/Semantics/Compiler.hs
index d62b9ba500e129cc9be047bb8f4c55e9576744c6..868936d62731da5b25d502690ec233cce4ef5425 100644 (file)
--- a/src/Literate/Web/Semantics/Compiler.hs
+++ b/src/Literate/Web/Semantics/Compiler.hs
@@ -15,12 +15,12 @@ import Data.ByteString.Builder qualified as BSB
 import Data.Either (Either (..))
 import Data.Eq (Eq)
 import Data.Foldable (toList)
-import Data.Function (id, ($), (.))
+import Data.Function (id, ($), (&), (.))
 import Data.Functor (Functor (..), (<$>))
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
-import Data.Maybe (Maybe (..))
-import Data.Monoid (Monoid (..))
+import Data.Maybe (Maybe (..), fromMaybe)
+import Data.Monoid (Last (..), Monoid (..))
 import Data.Ord (Ord)
 import Data.Proxy (Proxy (..))
 import Data.Semigroup (Semigroup (..))
@@ -88,12 +88,17 @@ siteMap ::
   Monad m =>
   Compiler m a ->
   (a --> m BSB.Builder) ->
-  m (Map.Map OutputPath (m BSB.Builder))
+  m (Map.Map OutputPath (MediaType, m BSB.Builder))
 siteMap router content = do
   outputs <- unCompiler router
   return $
     Map.fromList
-      [ (outputPathRelative out, outputData out content)
+      [ ( outputPathRelative out
+        ,
+          ( outputType out & getLast & fromMaybe (mediaTypeFor (Proxy @HTML))
+          , outputData out content
+          )
+        )
       | out <- outputs
       ]
 
@@ -144,7 +149,12 @@ instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
   optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
     where
       forNothing :: Output (Maybe a)
-      forNothing = Output{outputPath = mempty, outputData = ($ Nothing)}
+      forNothing =
+        Output
+          { outputPath = mempty
+          , outputType = mempty
+          , outputData = ($ Nothing)
+          }
       forJust :: Output a -> Output (Maybe a)
       forJust o = o{outputData = \k -> outputData o $ Sym.tofOffun $ k . Just}
 
@@ -196,6 +206,7 @@ instance Applicative m => PathSegmentable (Compiler m) where
                   { outputPathSegs = [s]
                   , outputPathExts = []
                   }
+            , outputType = mempty
             , outputData = id
             }
         ]
@@ -209,13 +220,14 @@ instance
   response =
     Compiler $
       pure $
-        ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
+        ( \(mediaType_, MimeType (Proxy :: Proxy t)) ->
             Output
               { outputPath =
                   OutputPath
                     { outputPathSegs = []
                     , outputPathExts = [decodePathSegment (fileExtension @t)]
                     }
+              , outputType = Last $ Just mediaType_
               , outputData = \(CompilerEndpoint Refl (Response ma)) ->
                   mimeEncode @_ @t <$> ma
               }
@@ -226,6 +238,7 @@ instance
 
 data Output a = Output
   { outputPath :: OutputPath
+  , outputType :: Last MediaType
   , outputData :: forall next. (a --> next) -> next
   }
 
@@ -265,16 +278,19 @@ instance Sym.ProductFunctor Output where
   a <.> b =
     Output
       { outputPath = outputPath a <> outputPath b
+      , outputType = outputType a <> outputType b
       , outputData = outputData b . outputData a
       }
   a <. b =
     Output
       { outputPath = outputPath a <> outputPath b
+      , outputType = outputType a <> outputType b
       , outputData = outputData b . outputData a
       }
   a .> b =
     Output
       { outputPath = outputPath a <> outputPath b
+      , outputType = outputType a <> outputType b
       , outputData = outputData b . outputData a
       }