From 4c7fc78eb49e0b5c05fea2c1a6210a5f8c1ba2a5 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 22 Aug 2022 20:06:57 +0200 Subject: [PATCH] wip --- flake.nix | 1 + src/Webc/Classes.hs | 4 + src/Webc/Compiler.hs | 335 +++++++++++++++++++++++++++++++++++++++++ src/Webc/Decoder.hs | 145 +++++++++++++----- src/Webc/Encoder.hs | 13 +- src/Webc/Generator.hs | 6 +- src/Webc/MIME.hs | 201 +++++++++++++++++++++++++ tests/Examples/Ex01.hs | 5 + tests/Examples/Ex02.hs | 11 +- tests/Goldens.hs | 42 ++++++ tests/HUnits.hs | 19 +-- tests/Utils.hs | 20 +-- webc.cabal | 10 +- 13 files changed, 738 insertions(+), 74 deletions(-) create mode 100644 src/Webc/Compiler.hs create mode 100644 src/Webc/MIME.hs 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 -- 2.44.1