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"
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
--- /dev/null
+{-# 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
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
module Webc.Decoder where
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 <$>)
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
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
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
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
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 (..))
import Symantic.Classes (Iso (..), IsoFunctor ((<%>)), Optionable (..), ProductFunctor ((<.>)), SumFunctor ((<+>)))
import Webc.Classes
+import Webc.Decoder (Request (..))
+import Webc.MIME
-- * The 'Encoder' interpreter
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
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 :)
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 $
--- /dev/null
+{-# 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
-- <+> 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")
module Examples.Ex02 where
+import Data.Either (Either (..))
import Data.Eq (Eq)
import Data.Function (($), (.))
import Data.Maybe (Maybe (..))
-- 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)
, SumFunctor repr
, Slugable repr
, Optionable repr
- , Endable repr
- , Inferable Tag repr
+ , -- , Endable repr
+ Inferable Tag repr
) =>
Inferable Filter repr
where
]
| (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
= 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 [()]
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"})})}]
)
]
]
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
)
]
[ 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
]
, 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
, 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
, fast-logger >=3.0
, filepath >=1.4
, filepattern >=0.1
+ , http-client >=0.6
+ , http-media >=0.7
, lvar
, microlens
, peano
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
, 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
, text >=1.2
, transformers >=0.5
, url-slug >=0.1
-
---, webc
sourcephile / git / webc.git / commitdiff