From: Julien Moutinho <julm@sourcephile.fr>
Date: Mon, 22 Aug 2022 18:06:57 +0000 (+0200)
Subject: wip
X-Git-Url: https://git.sourcephile.fr/webc.git/commitdiff_plain

wip
---

diff --git a/flake.nix b/flake.nix
index 7af77bb..5b6b377 100644
--- a/flake.nix
+++ b/flake.nix
@@ -45,6 +45,7 @@
       checks = forAllSystems (args: with args; {
         pre-commit-check = inputs.pre-commit-hooks.lib.${system}.run {
           src = ./.;
+          #settings.ormolu.cabalDefaultExtensions = true;
           settings.ormolu.defaultExtensions = [
             "ImportQualifiedPost"
             "TypeApplications"
diff --git a/src/Webc/Classes.hs b/src/Webc/Classes.hs
index 727d487..0e732d1 100644
--- a/src/Webc/Classes.hs
+++ b/src/Webc/Classes.hs
@@ -87,6 +87,10 @@ index = literalSlug "index.html"
 
 infixr 4 </>
 
+-- * Class 'ContentTypeable'
+class ContentTypeable fmt a repr where
+  contentType :: repr a
+
 -- * Class 'Capturable'
 class Capturable repr where
   captureSlug :: URI.Slug -> repr URI.Slug
diff --git a/src/Webc/Compiler.hs b/src/Webc/Compiler.hs
new file mode 100644
index 0000000..1162831
--- /dev/null
+++ b/src/Webc/Compiler.hs
@@ -0,0 +1,335 @@
+{-# LANGUAGE DeriveFunctor #-}
+
+module Webc.Compiler where
+
+import Control.Applicative (Applicative (..))
+import Control.Monad (Monad (..), forM_, when)
+import Data.Bool
+import Data.ByteString.Lazy qualified as BSL
+import Data.Either (Either (..))
+import Data.Eq (Eq (..))
+import Data.Foldable (null, toList)
+import Data.Function (($), (.))
+import Data.Functor (Functor (..), (<$>))
+import Data.Maybe (Maybe (..))
+import Data.Ord (Ord (..))
+import Data.Semigroup (Semigroup (..))
+import Data.Text qualified as Text
+import GHC.Base (error)
+import GHC.Stack (HasCallStack)
+import Network.URI.Slug (Slug)
+import Network.URI.Slug qualified as URI
+import Symantic (
+  Optionable (..),
+  ProductFunctor (..),
+  SumFunctor (..),
+ )
+import Symantic.Classes (Iso (..), IsoFunctor (..))
+import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist {-, getCurrentDirectory-})
+import System.FilePath (FilePath, takeDirectory, (</>))
+import System.FilePath qualified as FilePath
+import System.FilePattern.Directory (getDirectoryFiles)
+import System.IO (IO, hPutStrLn, stderr)
+import Text.Show (Show (..))
+import Webc.Classes hiding ((</>))
+import Webc.MIME (PlainText)
+
+-- * The 'Compiler' interpreter
+
+newtype Compiler a = Compiler
+  { unCompiler :: [Comp a]
+  }
+  deriving (Functor, Show)
+
+instance Applicative Compiler where
+  pure = Compiler . pure . pure
+  Compiler f <*> Compiler x = Compiler $ (<*>) <$> f <*> x
+
+-- instance Monad Compiler where
+--   return = pure
+--   Compiler x >>= f = Compiler (x >>=)
+
+data CompilerConf = CompilerConf
+  { compilerConfSource :: FilePath
+  , compilerConfDest :: FilePath
+  }
+
+compile :: Show a => Renderable a => Compiler a -> CompilerConf -> IO ()
+compile comp CompilerConf{..} = do
+  createDirectoryIfMissing True compilerConfDest
+  let routes = unCompiler comp
+  when (null routes) $
+    error "no routes, nothing to compile"
+  forM_ routes $ \c@Comp{..} -> do
+    hPutStrLn stderr $ "route: " <> show c
+    let routePath = pathOfSlugs compSlugs
+     in case render c of
+          Left staticPath ->
+            doesPathExist (compilerConfSource </> staticPath) >>= \case
+              True -> do
+                -- TODO: In current branch, we don't expect this to be a directory.
+                -- Although the user may pass it, but review before merge.
+                hPutStrLn stderr $
+                  "staticCopy: "
+                    <> show
+                      ( (compilerConfSource </> staticPath)
+                      , (compilerConfDest </> staticPath)
+                      )
+                copyDirRecursively
+                  routePath
+                  (compilerConfSource </> staticPath)
+                  (compilerConfDest </> staticPath)
+              False ->
+                return ()
+          -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
+          Right (bs, ext) -> do
+            hPutStrLn stderr $ "mkdir: " <> show (takeDirectory (compilerConfDest </> routePath))
+            createDirectoryIfMissing True (takeDirectory (compilerConfDest </> routePath))
+            hPutStrLn stderr $ "write: " <> show (compilerConfDest </> routePath FilePath.<.> ext)
+            BSL.writeFile (compilerConfDest </> routePath FilePath.<.> ext) bs
+
+-- ** Class 'Renderable'
+class Renderable a where
+  render :: Comp a -> Either FilePath (BSL.ByteString, FilePath)
+instance Renderable () where
+  render Comp{..} = Left $ pathOfSlugs compSlugs
+
+pathOfSlugs :: [Slug] -> FilePath
+pathOfSlugs s = Text.unpack $ Text.intercalate "/" $ URI.encodeSlug <$> s
+
+-- ** Type 'Comp'
+data Comp a = Comp
+  { compSlugs :: [Slug] -- TODO: Endo? Seq?
+  , compValue :: a
+  , compExt :: Maybe FilePath
+  }
+  deriving (Eq, Ord, Show, Functor)
+instance Applicative Comp where
+  pure compValue =
+    Comp
+      { compSlugs = []
+      , compValue
+      , compExt = Nothing
+      }
+  f <*> x =
+    Comp
+      { compSlugs = compSlugs f <> compSlugs x
+      , compValue = compValue f (compValue x)
+      , compExt = compExt f <> compExt x
+      }
+
+instance IsoFunctor Compiler where
+  (<%>) Iso{..} = (a2b <$>)
+instance ProductFunctor Compiler where
+  (<.>) = liftA2 (,)
+  (<.) = (<*)
+  (.>) = (*>)
+instance SumFunctor Compiler where
+  x <+> y =
+    Compiler $
+      (<>)
+        ((Left <$>) <$> unCompiler x)
+        ((Right <$>) <$> unCompiler y)
+instance Optionable Compiler where
+  optional x =
+    Compiler $
+      Comp{compSlugs = [], compValue = Nothing, compExt = Nothing} :
+      ((Just <$>) <$> unCompiler x)
+instance Slugable Compiler where
+  literalSlug s = Compiler [Comp{compSlugs = [s], compValue = (), compExt = Nothing}]
+  chooseSlug ss =
+    Compiler $
+      [ Comp{compSlugs = [s], compValue = s, compExt = Nothing}
+      | s <- toList ss
+      ]
+instance ContentTypeable PlainText () Compiler where
+  contentType =
+    Compiler
+      [ Comp
+          { compSlugs = []
+          , compValue = ()
+          , compExt = Just "txt"
+          }
+      ]
+
+-- instance Repeatable Compiler where
+--   many0 (Compiler x) =
+--     Compiler $
+--       ((\Comp{} -> Comp [] []) <$> x)
+--         <> ((\(Comp s a) -> Comp s [a]) <$> x)
+--         <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
+--   many1 (Compiler x) =
+--     Compiler $
+--       ((\(Comp s a) -> Comp s [a]) <$> x)
+--         <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
+-- instance Endable Compiler where
+--   end = Compiler [Comp [] ()]
+-- instance Capturable Compiler where
+--   captureSlug n = Compiler $ [Comp [n] n]
+-- instance Constantable c Compiler where
+--   constant = pure
+
+{-
+let (staticPaths, generatedPaths) =
+      lefts &&& rights $
+        routes <&> \r ->
+          case render model r of
+            AssetStatic fp -> Left (r, fp)
+            AssetComperated _fmt s -> Right (encodeRoute model r, s)
+paths <- forM generatedPaths $ \(relPath, !s) -> do
+  let fp = dest </> relPath
+  log LevelInfo $ toText $ "W " <> fp
+  liftIO $ do
+    createDirectoryIfMissing True (takeDirectory fp)
+    writeFileLBS fp s
+    pure fp
+forM_ staticPaths $ \(r, staticPath) -> do
+  liftIO (doesPathExist staticPath) >>= \case
+    True ->
+      -- TODO: In current branch, we don't expect this to be a directory.
+      -- Although the user may pass it, but review before merge.
+      copyDirRecursively (encodeRoute model r) staticPath dest
+    False ->
+      log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
+-}
+{-
+instance Slugable Compiler where
+  literalSlug s = Compiler $ return $ Endo (s :)
+  captureSlug _n = Compiler $ MT.ReaderT $ \s -> return $ Endo (s :)
+instance ProductFunctor Compiler where
+  Compiler x <.> Compiler y = Compiler $
+    MT.ReaderT $ \env ->
+      MT.withReaderT (\env -> env{compilerArgs = b2a (compilerArgs env)})
+      return $
+        MT.runReaderT x a
+          <> MT.runReaderT y b
+-}
+
+--deriving stock (Eq, Show, Ord, Comperic)
+
+{-
+
+safeForLarge' :: Int -> IO ()
+safeForLarge' n = flip finally (cleanup tmpfile) $ do
+    cleanup tmpfile
+    lgrset <- newFileLoggerSet defaultBufSize tmpfile
+    let xs = toLogStr $ BS.pack $ take (abs n) (cycle ['a'..'z'])
+        lf = "x"
+    pushLogStr lgrset $ xs <> lf
+    flushLogStr lgrset
+    rmLoggerSet lgrset
+    bs <- BS.readFile tmpfile
+    bs `shouldBe` BS.pack (take (abs n) (cycle ['a'..'z']) <> "x")
+    where
+        tmpfile = "test/temp"
+
+cleanup :: FilePath -> IO ()
+cleanup file = do
+    exist <- doesFileExist file
+    when exist $ removeFile file
+
+logAllMsgs :: IO ()
+logAllMsgs = logAll "LICENSE" `finally` cleanup tmpfile
+  where
+    tmpfile = "test/temp"
+    logAll file = do
+        cleanup tmpfile
+        lgrset <- newFileLoggerSet 512 tmpfile
+        src <- BS.readFile file
+        let bs = (<> "\n") . toLogStr <$> BS.lines src
+        mapM_ (pushLogStr lgrset) bs
+        flushLogStr lgrset
+        rmLoggerSet lgrset
+        dst <- BS.readFile tmpfile
+        dst `shouldBe` src
+
+compile ::
+  forall model m route.
+  ( -- MonadIO m,
+    -- MonadUnliftIO m,
+    -- MonadLoggerIO m,
+    -- Show r,
+    HasCallStack
+  ) =>
+  FilePath ->
+  model ->
+  (model -> route -> Asset BSL.ByteString) ->
+  -- | List of generated files.
+  IO ()
+compile dest model render = do
+  dirExists <- doesDirectoryExist dest
+  when (not dirExists) $ do
+    error $ "Destination does not exist: " <> dest
+  let routes = allRoutes model
+  when (null routes) $
+    error "allRoutes is empty; nothing to compile"
+  -- log LevelInfo $ "Writing " <> show (length routes) <> " routes"
+  let staticPaths =
+          (<$> routes) $ \route ->
+            case render model route of
+              AssetStatic fp -> Left (route, fp)
+              AssetComperated _fmt s -> Right (encodeRoute model route, s)
+  forM_ staticPaths $ \(route, staticPath) -> do
+    (doesPathExist staticPath) >>= \case
+      True ->
+        -- TODO: In current branch, we don't expect this to be a directory.
+        -- Although the user may pass it, but review before merge.
+        copyDirRecursively (encodeRoute model route) staticPath dest
+      False ->
+        return ()
+        -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
+
+log :: MonadLogger m => LogLevel -> Text -> m ()
+log = logWithoutLoc "Comperate"
+
+-- | Disable birdbrained hacks from GitHub to disable surprises like,
+-- https://github.com/jekyll/jekyll/issues/55
+noBirdbrainedJekyll :: (MonadIO m, MonadLoggerIO m) => FilePath -> m ()
+noBirdbrainedJekyll dest = do
+  let nojekyll = dest </> ".nojekyll"
+  liftIO (doesFileExist nojekyll) >>= \case
+    True -> pure ()
+    False -> do
+      log LevelInfo $ "Disabling Jekyll by writing " <> toText nojekyll
+      writeFileLBS nojekyll ""
+
+newtype StaticAssetMissing = StaticAssetMissing FilePath
+  deriving stock (Show)
+  deriving anyclass (Exception)
+
+-}
+copyDirRecursively ::
+  ( --MonadIO m,
+    --MonadUnliftIO m,
+    --MonadLoggerIO m,
+    HasCallStack
+  ) =>
+  -- | Source file path relative to CWD
+  FilePath ->
+  -- | Absolute path to source file to copy.
+  FilePath ->
+  -- | Directory *under* which the source file/dir will be copied
+  FilePath ->
+  IO ()
+copyDirRecursively srcRel srcAbs destParent = do
+  doesFileExist srcAbs >>= \case
+    True -> do
+      let b = destParent </> srcRel
+      --log LevelInfo $ toText $ "C " <> b
+      copyFileCreatingParents srcAbs b
+    False ->
+      doesDirectoryExist srcAbs >>= \case
+        False ->
+          return ()
+        -- throw $ StaticAssetMissing srcAbs
+        True -> do
+          fs <- getDirectoryFiles srcAbs ["**"]
+          forM_ fs $ \fp -> do
+            let a = srcAbs </> fp
+                b = destParent </> srcRel </> fp
+            -- log LevelInfo $ toText $ "C " <> b
+            copyFileCreatingParents a b
+  where
+    copyFileCreatingParents a b = do
+      createDirectoryIfMissing True (takeDirectory b)
+      copyFile a b
diff --git a/src/Webc/Decoder.hs b/src/Webc/Decoder.hs
index 37eecca..1d33d67 100644
--- a/src/Webc/Decoder.hs
+++ b/src/Webc/Decoder.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Webc.Decoder where
 
@@ -24,41 +26,100 @@ import Data.Semigroup (Semigroup (..))
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Text qualified as Text
+import Data.Text.Encoding qualified as Text
+import Data.Text.Encoding.Error qualified as Text
+
+--import Data.Text.Lazy qualified as TextL
+--import Data.Text.Lazy.Encoding qualified as TextL
 import Network.URI.Slug
 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor (..), SumFunctor ((<+>)))
 import System.IO (IO)
-import Text.Show (Show)
+import Text.Show (Show (..))
+
+--import Network.Wai qualified as Wai
 
 -- import Prelude (undefined)
 
 import Webc.Classes
+import Webc.MIME
 
 -- * The 'Decoder' interpreter
 
 -- | A very very basic parser.
 newtype Decoder err a = Decoder
   { unDecoder ::
-      MT.ReaderT [Slug] (MT.StateT [Slug] (MT.ExceptT (DecoderError err) IO)) a
+      MT.ReaderT
+        Request
+        ( MT.StateT
+            DecoderState
+            (MT.ExceptT (DecoderError err) IO)
+        )
+        a
   }
   deriving (Functor, Applicative, Monad)
 
-decode :: Decoder err a -> [Slug] -> IO (Either (DecoderError err) a)
-decode (Decoder dec) slugs =
-  MT.runExceptT (MT.runStateT (MT.runReaderT dec []) slugs) >>= \case
+-- ** Type 'Request'
+data Request = Request
+  { requestSlugs :: [Slug]
+  , requestBody :: BSL.ByteString
+  }
+
+{-
+data Decoders err a = Decoders
+  { decodersPath :: [Slug] -> a
+  , decodersMethod :: [Slug] -> Bool
+  --, decodersBasicAuth ::
+  , decodersAccept :: Bool
+  , decodersContentType :: Bool
+  , decodersQuery :: Bool
+  , decodersHeader :: Bool
+  , decodersBody :: BSL.ByteString -> a
+  }
+-}
+
+data DecoderState = DecoderState
+  { decoderStateSlugs :: [Slug]
+  }
+
+decode :: Decoder err a -> Request -> IO (Either (DecoderError err) a)
+decode (Decoder dec) req =
+  MT.runExceptT (MT.runStateT (MT.runReaderT dec req) st) >>= \case
     Left err -> return $ Left err
-    Right (a, st)
-      | null st -> return $ Right a
-      | otherwise -> return $ Left $ DecoderErrorLeftover st
+    Right (a, DecoderState{..})
+      | null decoderStateSlugs -> return $ Right a
+      | otherwise -> return $ Left $ DecoderErrorPathLeftover decoderStateSlugs
+  where
+    st =
+      DecoderState
+        { decoderStateSlugs = requestSlugs req
+        }
 
 data DecoderError err
-  = DecoderErrorMismatch
+  = -- 1st checks, 404 error
+    DecoderErrorPathMismatch
       { expectedSlugs :: Set Slug
       , gotSlug :: Slug
       }
-  | DecoderErrorMissing
-  | DecoderErrorLeftover [Slug]
-  | DecoderErrorParser err
-  deriving (Eq, Ord, Show)
+  | DecoderErrorPathMissing
+  | DecoderErrorPathLeftover [Slug]
+  | -- 2nd check, 405 error
+    DecoderErrorMethod
+  | -- 3rd check, 401 or 403 error
+    DecoderErrorBasicAuth
+  | -- 4th check, 406 error
+    DecoderErrorAccept
+  | -- 5th check, 415 error
+    DecoderErrorContentType
+  | -- 6th check, 400 error
+    DecoderErrorQuery
+  | -- 7th check, 400 error
+    DecoderErrorHeader
+  | -- 8th check, 400 error
+    DecoderErrorUnicode Text.UnicodeException
+  | -- 9th check, custom
+    DecoderErrorParser err
+  deriving (Eq, Show)
+deriving instance Ord Text.UnicodeException
 
 instance IsoFunctor (Decoder err) where
   (<%>) Iso{..} = (a2b <$>)
@@ -78,9 +139,9 @@ instance SumFunctor (Decoder err) where
             Left err -> MT.throwE err
 instance Endable (Decoder err) where
   end = Decoder do
-    MT.lift MT.get >>= \case
+    MT.lift (MT.gets decoderStateSlugs) >>= \case
       [] -> return ()
-      lo -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorLeftover lo
+      lo -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathLeftover lo
 instance Repeatable (Decoder err) where
   many0 (Decoder x) = Decoder (MT.ReaderT (MT.StateT . go))
     where
@@ -97,56 +158,66 @@ instance Optionable (Decoder err) where
         Right (a, st') -> return (Just a, st')
 instance Slugable (Decoder err) where
   literalSlug expectedSlug = Decoder $ do
-    slugs <- MT.lift MT.get
+    slugs <- MT.lift (MT.gets decoderStateSlugs)
     case slugs of
-      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
+      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
       gotSlug : nextSlugs
         | expectedSlug /= gotSlug ->
-          MT.lift $ MT.lift $ MT.throwE DecoderErrorMismatch{expectedSlugs = Set.singleton expectedSlug, ..}
+          MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMismatch{expectedSlugs = Set.singleton expectedSlug, ..}
         | otherwise ->
-          MT.local (<> [gotSlug]) $
-            MT.lift $ MT.put nextSlugs
+          MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) $
+            MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
   chooseSlug expectedSlugs = Decoder $ do
-    slugs <- MT.lift MT.get
+    slugs <- MT.lift (MT.gets decoderStateSlugs)
     case slugs of
-      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
+      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
       gotSlug : nextSlugs
         | gotSlug `Set.notMember` expectedSlugs ->
-          MT.lift $ MT.lift $ MT.throwE DecoderErrorMismatch{expectedSlugs, ..}
+          MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMismatch{expectedSlugs, ..}
         | otherwise -> do
-          MT.local (<> [gotSlug]) $
-            MT.lift $ MT.put nextSlugs
+          MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) $
+            MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
           return gotSlug
+instance ContentTypeable PlainText BSL.ByteString (Decoder err) where
+  contentType = Decoder do
+    Request{..} <- MT.ask
+    return requestBody
+instance ContentTypeable PlainText Text.Text (Decoder err) where
+  contentType = Decoder do
+    Request{..} <- MT.ask
+    case Text.decodeUtf8' (BSL.toStrict requestBody) of
+      Right a -> return a
+      Left err -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorUnicode err
 
 -- chooseSlugs = undefined
 -- chooseSlugs expectedSlugs = Decoder $ do
 --   slugs <- MT.lift MT.get
 --   case slugs of
---     [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
+--     [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
 --     gotSlug : nextSlugs
 --       | gotSlug `Set.member` expectedSlugs ->
---         MT.lift $ MT.lift $ MT.throwE $ DecoderErrorMismatch{expectedSlugs, ..}
+--         MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathMismatch{expectedSlugs, ..}
 --       | otherwise -> do
 --         MT.local (<> [gotSlug]) $
 --           MT.lift $ MT.put nextSlugs
 --         return gotSlug
 instance Capturable (Decoder err) where
   captureSlug _name = Decoder $ do
-    slugs <- MT.lift MT.get
+    slugs <- MT.lift (MT.gets decoderStateSlugs)
     case slugs of
-      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
+      [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
       gotSlug : nextSlugs ->
-        MT.local (<> [gotSlug]) do
-          MT.lift $ MT.put nextSlugs
+        MT.local (\req -> req{requestSlugs = requestSlugs req <> [gotSlug]}) do
+          MT.lift $ MT.modify' $ \st -> st{decoderStateSlugs = nextSlugs}
           return gotSlug
 
 --chooseSlug expectedSlugs = Decoder $ do
 --  slugs <- MT.lift MT.get
 --  case slugs of
---    [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorMissing
+--    [] -> MT.lift $ MT.lift $ MT.throwE DecoderErrorPathMissing
 --    gotSlug : nextSlugs
 --      | gotSlug `Set.member` expectedSlugs ->
---        MT.lift $ MT.lift $ MT.throwE $ DecoderErrorMismatch{..}
+--        MT.lift $ MT.lift $ MT.throwE $ DecoderErrorPathMismatch{..}
 --      | otherwise -> do
 --        MT.local (<> [gotSlug]) $
 --          MT.lift $ MT.put nextSlugs
@@ -158,11 +229,11 @@ instance Selectable (Decoder err) where
     case Map.lookup a a2bs of
       Nothing ->
         Decoder $ MT.lift $ MT.lift $ MT.throwE
-          DecoderErrorMissing -- FIXME
+          DecoderErrorPathMissing -- FIXME
     where
     go a [] = Decoder $
       MT.lift $ MT.lift $ MT.throwE
-        DecoderErrorMissing -- FIXME
+        DecoderErrorPathMissing -- FIXME
     go a ((ca, x):xs) = Decoder $
       MT.ReaderT $ \env -> MT.StateT $ \st -> do
         MT.lift (MT.runExceptT (MT.runStateT (MT.runReaderT (unDecoder x) env) st)) >>= \case
@@ -175,14 +246,14 @@ instance Fileable (Decoder err) where
   static = Decoder do
     return ()
   dynamic = Decoder do
-    path <- MT.ask
+    Request{..} <- MT.ask
     content <-
       MT.lift $
         MT.lift $
           MT.lift $
             BSL.readFile $
               List.intercalate "/" $
-                Text.unpack . encodeSlug <$> path
+                Text.unpack . encodeSlug <$> requestSlugs
     case parse content of
       Right a -> return a
       Left err -> MT.lift $ MT.lift $ MT.throwE $ DecoderErrorParser err
diff --git a/src/Webc/Encoder.hs b/src/Webc/Encoder.hs
index 91264bf..0a57086 100644
--- a/src/Webc/Encoder.hs
+++ b/src/Webc/Encoder.hs
@@ -7,6 +7,8 @@ import Data.Foldable (foldMap)
 import Data.Function (id, ($))
 
 -- import Data.List qualified as List
+
+import Data.ByteString.Lazy qualified as BSL
 import Data.Maybe (Maybe (..))
 import Data.Monoid (Endo (..), appEndo)
 import Data.Semigroup (Semigroup (..))
@@ -14,6 +16,8 @@ import Network.URI.Slug
 import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor ((<.>)), SumFunctor ((<+>)))
 
 import Webc.Classes
+import Webc.Decoder (Request (..))
+import Webc.MIME
 
 -- * The 'Encoder' interpreter
 
@@ -30,9 +34,7 @@ instance IsoFunctor Encoder where
 instance ProductFunctor Encoder where
   Encoder x <.> Encoder y = Encoder $
     MT.ReaderT $ \(a, b) ->
-      return $
-        MT.runReader x a
-          <> MT.runReader y b
+      return $ MT.runReader x a <> MT.runReader y b
 instance SumFunctor Encoder where
   Encoder x <+> Encoder y = Encoder $
     MT.ReaderT $ \case
@@ -52,6 +54,11 @@ instance Slugable Encoder where
   literalSlug s = Encoder $ return $ Endo (s :)
   chooseSlug _s = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)
 
+{-
+instance ContentTypeable PlainText BSL.ByteString Encoder where
+  contentType = Encoder $ MT.ReaderT $ \a ->
+    return a
+-}
 -- chooseSlugs _s = Encoder $ MT.ReaderT $ \s -> return $ Endo (List.reverse s <>)
 instance Capturable Encoder where
   captureSlug _n = Encoder $ MT.ReaderT $ \s -> return $ Endo (s :)
diff --git a/src/Webc/Generator.hs b/src/Webc/Generator.hs
index c77d07a..5146c55 100644
--- a/src/Webc/Generator.hs
+++ b/src/Webc/Generator.hs
@@ -79,11 +79,7 @@ instance Endable Generator where
   end = Generator [Gen [] ()]
 instance Slugable Generator where
   literalSlug s = Generator [Gen [s] ()]
-  chooseSlug ss =
-    Generator $
-      [ Gen [s] s
-      | s <- toList ss
-      ]
+  chooseSlug ss = Generator [Gen [s] s | s <- toList ss]
 
 -- chooseSlugs ss =
 --   Generator $
diff --git a/src/Webc/MIME.hs b/src/Webc/MIME.hs
new file mode 100644
index 0000000..60aef5f
--- /dev/null
+++ b/src/Webc/MIME.hs
@@ -0,0 +1,201 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Webc.MIME where
+
+import Control.Arrow (left)
+import Data.Bool
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.ByteString.Lazy.Char8 qualified as BLC
+import Data.Either (Either (..))
+import Data.Foldable (toList)
+import Data.Function (id, ($), (.))
+import Data.Functor ((<$>))
+import Data.Int (Int)
+import Data.Kind (Constraint, Type)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe (Maybe (..))
+import Data.Proxy (Proxy (..))
+import Data.Semigroup (Semigroup (..))
+import Data.String (String)
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Data.Text.Lazy qualified as TL
+import Data.Text.Lazy.Encoding qualified as TL
+import Data.Tuple (fst, snd)
+import Data.Typeable (Typeable)
+import Network.HTTP.Media qualified as Media
+import Text.Read (readMaybe)
+import Text.Show (Show (..))
+
+--import qualified Web.FormUrlEncoded as Web
+
+-- * Class 'MediaTypeFor'
+class MediaTypeFor t where
+  mediaTypeFor :: Proxy t -> MediaType
+  mediaTypesFor :: Proxy t -> NonEmpty MediaType
+  mediaTypesFor t = mediaTypeFor t :| []
+instance MediaTypeFor () where
+  mediaTypeFor _t = mimeAny
+
+-- ** Type 'MediaType'
+type MediaType = Media.MediaType
+mediaType :: forall t. MediaTypeFor t => MediaType
+mediaType = mediaTypeFor (Proxy @t)
+{-# INLINE mediaType #-}
+
+-- ** Type 'MediaTypes'
+type MediaTypes = NonEmpty MediaType
+mediaTypes :: forall ts c. MimeTypes ts c => MediaTypes
+mediaTypes = fst <$> mimeTypesMap @ts @c
+{-# INLINE mediaTypes #-}
+
+charsetUTF8 :: MediaType -> MediaType
+charsetUTF8 = (Media./: ("charset", "utf-8"))
+
+mimeAny :: MediaType
+mimeAny = "*/*"
+
+-- ** Type 'JSON'
+data JSON deriving (Typeable)
+instance MediaTypeFor JSON where
+  mediaTypeFor _t = charsetUTF8 $ "application" Media.// "json"
+  mediaTypesFor t = mediaTypeFor t :| ["application" Media.// "json"]
+
+-- ** Type 'HTML'
+data HTML deriving (Typeable)
+instance MediaTypeFor HTML where
+  mediaTypeFor _t = charsetUTF8 $ "text" Media.// "html"
+  mediaTypesFor t = mediaTypeFor t :| ["text" Media.// "html"]
+
+-- ** Type 'FormUrlEncoded'
+data FormUrlEncoded deriving (Typeable)
+instance MediaTypeFor FormUrlEncoded where
+  mediaTypeFor _t = "application" Media.// "x-www-form-urlencoded"
+
+-- ** Type 'OctetStream'
+data OctetStream deriving (Typeable)
+instance MediaTypeFor OctetStream where
+  mediaTypeFor _t = "application" Media.// "octet-stream"
+
+-- ** Type 'PlainText'
+data PlainText deriving (Typeable)
+instance MediaTypeFor PlainText where
+  mediaTypeFor _t = charsetUTF8 $ "text" Media.// "plain"
+
+-- * Type 'MimeType'
+
+-- | Existentially wraps a type-level type 't'
+-- with a proof it respects 'Constraint' 'c'.
+-- Usually 'c' is @'MimeEncodable' a@ or @'MimeDecodable' a@.
+data MimeType c where
+  MimeType :: (c t, MediaTypeFor t) => Proxy t -> MimeType c
+
+mimeType :: forall t c. MediaTypeFor t => c t => MimeType c
+mimeType = MimeType (Proxy @t)
+{-# INLINE mimeType #-}
+mimeTypes :: forall ts c. MimeTypes ts c => NonEmpty (MimeType c)
+mimeTypes = snd <$> mimeTypesMap @ts @c
+{-# INLINE mimeTypes #-}
+
+-- * Class 'MimeTypes'
+
+-- | Implicitely generate 'MediaType's and 'MimeType's
+-- from a type-level list of types.
+class MimeTypes (ts :: [Type]) (c :: Type -> Constraint) where
+  mimeTypesMap :: NonEmpty (MediaType, MimeType c)
+
+instance (MediaTypeFor t, c t) => MimeTypes '[t] c where
+  mimeTypesMap = (,MimeType @c @t Proxy) <$> mediaTypesFor (Proxy @t)
+instance (MediaTypeFor t, MimeTypes (t1 ': ts) c, c t) => MimeTypes (t ': t1 ': ts) c where
+  mimeTypesMap =
+    ( (,MimeType @c @t Proxy)
+        <$> mediaTypesFor (Proxy @t)
+    )
+      <> mimeTypesMap @(t1 ': ts) @c
+
+matchAccept ::
+  forall ts c.
+  MimeTypes ts c =>
+  BS.ByteString ->
+  Maybe (MimeType c)
+matchAccept = Media.mapAccept (toList $ mimeTypesMap @ts @c)
+
+matchContent ::
+  forall ts c.
+  MimeTypes ts c =>
+  BS.ByteString ->
+  Maybe (MimeType c)
+matchContent = Media.mapContent (toList $ mimeTypesMap @ts @c)
+
+-- * Type 'MimeEncodable'
+class MediaTypeFor t => MimeEncodable a t where
+  mimeEncode :: Proxy t -> MimeEncoder a
+instance MimeEncodable () PlainText where
+  mimeEncode _ () = BLC.pack ""
+
+-- | @BSL.fromStrict . T.encodeUtf8@
+instance MimeEncodable String PlainText where
+  mimeEncode _ = BLC.pack
+
+instance MimeEncodable T.Text PlainText where
+  mimeEncode _ = BSL.fromStrict . T.encodeUtf8
+instance MimeEncodable TL.Text PlainText where
+  mimeEncode _ = TL.encodeUtf8
+instance MimeEncodable BS.ByteString OctetStream where
+  mimeEncode _ = BSL.fromStrict
+instance MimeEncodable BSL.ByteString OctetStream where
+  mimeEncode _ = id
+instance MimeEncodable Int PlainText where
+  mimeEncode _ = TL.encodeUtf8 . TL.pack . show
+
+-- | @Web.urlEncodeAsForm@
+-- Note that the @mimeDecode p (mimeEncode p x) == Right x@ law only
+-- holds if every element of x is non-null (i.e., not @("", "")@)
+--instance Web.ToForm a => MimeEncodable a FormUrlEncoded where
+--  mimeEncode _ = Web.urlEncodeAsForm
+
+-- ** Type 'MimeEncoder'
+
+type MimeEncoder a = a -> BSL.ByteString
+
+-- * Type 'MimeDecodable'
+class MediaTypeFor mt => MimeDecodable a mt where
+  mimeDecode :: Proxy mt -> MimeDecoder a
+
+-- mimeDecode p = mimeUnserializeWithType p (mimeType p)
+
+-- ** Type 'MimeDecoder'
+type MimeDecoder a = BSL.ByteString -> Either String a
+
+instance MimeDecodable () PlainText where
+  mimeDecode _ bsl
+    | BLC.null bsl = Right ()
+    | otherwise = Left "not empty"
+instance MimeDecodable String PlainText where
+  mimeDecode _ = Right . BLC.unpack
+instance MimeDecodable T.Text PlainText where
+  mimeDecode _ = left show . T.decodeUtf8' . BSL.toStrict
+instance MimeDecodable TL.Text PlainText where
+  mimeDecode _ = left show . TL.decodeUtf8'
+instance MimeDecodable BS.ByteString OctetStream where
+  mimeDecode _ = Right . BSL.toStrict
+instance MimeDecodable BSL.ByteString OctetStream where
+  mimeDecode _ = Right
+instance MimeDecodable Int PlainText where
+  mimeDecode _mt bsl =
+    case readMaybe s of
+      Just n -> Right n
+      _ -> Left $ "cannot parse as Int: " <> s
+    where
+      s = TL.unpack (TL.decodeUtf8 bsl)
+
+-- | @Web.urlDecodeAsForm@
+-- Note that the @mimeDecode p (mimeEncode p x) == Right x@ law only
+-- holds if every element of x is non-null (i.e., not @("", "")@)
+--instance Web.FromForm a => MimeDecodable a FormUrlEncoded where
+--  mimeDecode _ = left T.unpack . Web.urlDecodeAsForm
diff --git a/tests/Examples/Ex01.hs b/tests/Examples/Ex01.hs
index 9362db6..7c754e7 100644
--- a/tests/Examples/Ex01.hs
+++ b/tests/Examples/Ex01.hs
@@ -31,3 +31,8 @@ site =
 
 -- <+> captureSlug "user" <. literalSlug "contact.html"
 -- <+> "post" </> many0 (captureSlug "dir")
+
+instance Renderable Site where
+  render Comp{..} = case compValue of
+    Index -> Right ("Hello world!", "txt")
+    About -> Right ("I'm a test", "txt")
diff --git a/tests/Examples/Ex02.hs b/tests/Examples/Ex02.hs
index 6298614..c00824c 100644
--- a/tests/Examples/Ex02.hs
+++ b/tests/Examples/Ex02.hs
@@ -7,6 +7,7 @@
 
 module Examples.Ex02 where
 
+import Data.Either (Either (..))
 import Data.Eq (Eq)
 import Data.Function (($), (.))
 import Data.Maybe (Maybe (..))
@@ -36,6 +37,12 @@ data Site
   -- SiteSpecial [URI.Slug]
   deriving (Eq, Show, Generic)
 
+instance Renderable Site where
+  render Comp{..} = case compValue of
+    SiteFeeds -> Right ("feeds", "txt")
+    SiteFilter _fil -> Right ("filter", "txt")
+    SiteStatic -> Left $ pathOfSlugs compSlugs
+
 gen0 :: [Gen Site]
 gen0 = generate (unReader site model0)
 
@@ -72,8 +79,8 @@ instance
   , SumFunctor repr
   , Slugable repr
   , Optionable repr
-  , Endable repr
-  , Inferable Tag repr
+  , -- , Endable repr
+    Inferable Tag repr
   ) =>
   Inferable Filter repr
   where
diff --git a/tests/Goldens.hs b/tests/Goldens.hs
index 068da21..7c08896 100644
--- a/tests/Goldens.hs
+++ b/tests/Goldens.hs
@@ -60,6 +60,37 @@ test =
           ]
         | (siteNum, Golden site models) <- ol goldens
         ]
+    , testGroup
+        "Compiler"
+        [ testGroup
+          (printf "Site%03d" siteNum)
+          [ withResource
+            ( compile
+                (Sym.unReader site model)
+                CompilerConf
+                  { compilerConfSource = getGoldenDir (printf "Encoder/Site%03d/Model%02d/Source/" siteNum modelNum)
+                  , compilerConfDest = getGoldenDir (printf "Encoder/Site%03d/Model%02d/Got/" siteNum modelNum)
+                  }
+            )
+            (\_ -> return ())
+            $ \io ->
+              testGroup
+                (printf "Model%02d" modelNum)
+                [ do
+                  goldenVsFileDiff
+                    (printf "Route%03d" genNum)
+                    goldenDiff
+                    (getGoldenDir (printf "Encoder/Site%03d/Model%02d/Expected/%s.txt" siteNum modelNum slugs))
+                    (getGoldenDir (printf "Encoder/Site%03d/Model%02d/Got/%s.txt" siteNum modelNum slugs))
+                    io
+                | --return $ fromString $ show $ encode (Sym.unReader site model) genValue
+                (genNum, Gen{..}) <- ol $ generate (Sym.unReader site model)
+                , let slugs = pathOfSlugs genSlugs
+                ]
+          | (modelNum, model) <- ol models
+          ]
+        | (siteNum, Golden site models) <- ol goldens
+        ]
     ]
 
 getGoldenDir :: FilePath -> FilePath
@@ -72,11 +103,22 @@ data Golden
   = forall a model.
     ( Show a
     , Typeable a
+    , Renderable a
     ) =>
     Golden
       (forall repr. Testable model repr => Sym.Reader model repr a)
       [model]
 
+instance (Renderable a, Renderable b) => Renderable (Either a b) where
+  render Comp{..} =
+    case compValue of
+      Left x -> render Comp{compValue = x, ..}
+      Right x -> render Comp{compValue = x, ..}
+instance (Renderable a, Renderable b) => Renderable (a, b) where
+  render Comp{compValue = (_x, y), ..} =
+    --render Comp{compValue = x, ..} <|>
+    render Comp{compValue = y, ..}
+
 goldens :: [Golden]
 goldens =
   [ Golden @() index [()]
diff --git a/tests/HUnits.hs b/tests/HUnits.hs
index 7a4adeb..41bb9ce 100644
--- a/tests/HUnits.hs
+++ b/tests/HUnits.hs
@@ -41,16 +41,7 @@ test =
             Ex02.site
             [
               ( Ex02.model0
-              ,
-                [ Gen ["static"] $ Ex02.SiteStatic
-                , Gen ["feed"] $ Ex02.SiteFeeds
-                , Gen ["filter", "all"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Nothing, filterTag = Nothing}
-                , Gen ["filter", "all", "tag0"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Nothing, filterTag = Just (Ex02.Tag{Ex02.unTag = "tag0"})}
-                , Gen ["filter", "fr"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Just Ex02.LangEn, filterTag = Nothing}
-                , Gen ["filter", "fr", "tag0"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Just Ex02.LangEn, filterTag = Just (Ex02.Tag{Ex02.unTag = "tag0"})}
-                , Gen ["filter", "en"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Just Ex02.LangFr, filterTag = Nothing}
-                , Gen ["filter", "en", "tag0"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Just Ex02.LangFr, filterTag = Just (Ex02.Tag{Ex02.unTag = "tag0"})}
-                ]
+              , [Gen{genSlugs = ["static"], genValue = Ex02.SiteStatic}, Gen{genSlugs = ["feed"], genValue = Ex02.SiteFeeds}, Gen{genSlugs = ["filter", "all"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Nothing, filterTag = Nothing})}, Gen{genSlugs = ["filter", "all", "tag0"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Nothing, filterTag = Just (Ex02.Tag{unTag = "tag0"})})}, Gen{genSlugs = ["filter", "all", "tag1"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Nothing, filterTag = Just (Ex02.Tag{unTag = "tag1"})})}, Gen{genSlugs = ["filter", "fr"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Just Ex02.LangEn, filterTag = Nothing})}, Gen{genSlugs = ["filter", "fr", "tag0"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Just Ex02.LangEn, filterTag = Just (Ex02.Tag{unTag = "tag0"})})}, Gen{genSlugs = ["filter", "fr", "tag1"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Just Ex02.LangEn, filterTag = Just (Ex02.Tag{unTag = "tag1"})})}, Gen{genSlugs = ["filter", "en"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Just Ex02.LangFr, filterTag = Nothing})}, Gen{genSlugs = ["filter", "en", "tag0"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Just Ex02.LangFr, filterTag = Just (Ex02.Tag{unTag = "tag0"})})}, Gen{genSlugs = ["filter", "en", "tag1"], genValue = Ex02.SiteFilter (Ex02.Filter{filterLang = Just Ex02.LangFr, filterTag = Just (Ex02.Tag{unTag = "tag1"})})}]
               )
             ]
         ]
@@ -134,13 +125,13 @@ testCoderIsomorphism ::
   TestTree
 testCoderIsomorphism tn site model =
   testGroup tn $
-    [ testGroup (printf "Url%d" urlNum) $
+    [ testGroup (printf "Request%d" urlNum) $
       [ ( testCase "decode . encode" do
-            decode @() decoder (encode encoder genValue)
+            decode @() decoder Request{requestSlugs = encode encoder genValue, requestBody = ""}
               >>= (@?= Right genValue)
         )
       , ( testCase "encode . decode" do
-            dec <- decode @() decoder genSlugs
+            dec <- decode @() decoder Request{requestSlugs = genSlugs, requestBody = ""}
             encode encoder <$> dec @?= Right genSlugs
         )
       ]
@@ -163,7 +154,7 @@ testDecoder tn site models =
     [ testGroup
       (printf "Model%d" modelNum)
       [ testCase (printf "Gen%d" genNum) do
-        decode (Sym.unReader site model) genSlugs
+        decode (Sym.unReader site model) Request{requestSlugs = genSlugs, requestBody = ""}
           >>= (@?= Right genValue)
       | (genNum, Gen{..}) <- ol expectedGens
       ]
diff --git a/tests/Utils.hs b/tests/Utils.hs
index 5ad0567..1fb1c7b 100644
--- a/tests/Utils.hs
+++ b/tests/Utils.hs
@@ -17,11 +17,11 @@ class
   , Sym.IsoFunctor repr
   , Sym.Optionable repr
   , Sym.ProductFunctor repr
-  , Sym.Repeatable repr
-  , Sym.SumFunctor repr
-  , Endable repr
-  , Slugable repr
-  -- , Fileable repr
+  , -- , Sym.Repeatable repr
+    Sym.SumFunctor repr
+  , -- , Endable repr
+    Slugable repr
+    -- , Fileable repr
   ) =>
   Testable model repr
 
@@ -30,11 +30,11 @@ instance
   , Sym.IsoFunctor repr
   , Sym.Optionable repr
   , Sym.ProductFunctor repr
-  , Sym.Repeatable repr
-  , Sym.SumFunctor repr
-  , Endable repr
-  , Slugable repr
-  -- , Fileable repr
+  , -- , Sym.Repeatable repr
+    Sym.SumFunctor repr
+  , --, Endable repr
+    Slugable repr
+    -- , Fileable repr
   ) =>
   Testable model repr
 
diff --git a/webc.cabal b/webc.cabal
index 406b816..672275e 100644
--- a/webc.cabal
+++ b/webc.cabal
@@ -81,6 +81,8 @@ common library-deps
     , fast-logger            >=3.0
     , filepath               >=1.4
     , filepattern            >=0.1
+    , http-client            >=0.6
+    , http-media             >=0.7
     , lvar
     , microlens
     , peano
@@ -100,11 +102,15 @@ library
   exposed-modules:
     Webc
     Webc.Classes
+    Webc.Compiler
+    Webc.Decoder
     Webc.Encoder
     Webc.Generator
+    Webc.MIME
 
 --Webc.Decoder
 test-suite webc-tests
+  -- library-deps is only to have ghcid reloaded on changes in src
   import:          boilerplate, library-deps
   type:            exitcode-stdio-1.0
   hs-source-dirs:  tests
@@ -122,7 +128,7 @@ test-suite webc-tests
     , base           >=4.6  && <5
     , containers     >=0.5
     , monad-classes
-    , relude         >=0.7  && <1
+    , relude         >=1    && <2
     , symantic-base  >=0.5
     , tasty          >=0.11
     , tasty-golden   >=2.3
@@ -130,5 +136,3 @@ test-suite webc-tests
     , text           >=1.2
     , transformers   >=0.5
     , url-slug       >=0.1
-
---, webc