src/Webc/Compiler.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2
   3 module Webc.Compiler where
   4
   5 import Control.Applicative (Applicative (..))
   6 import Control.Monad (Monad (..), forM_, when)
   7 import Data.Bool
   8 import Data.ByteString.Lazy qualified as BSL
   9 import Data.Either (Either (..))
  10 import Data.Eq (Eq (..))
  11 import Data.Foldable (null, toList)
  12 import Data.Function (($), (.))
  13 import Data.Functor (Functor (..), (<$>))
  14 import Data.Maybe (Maybe (..))
  15 import Data.Ord (Ord (..))
  16 import Data.Semigroup (Semigroup (..))
  17 import Data.Text qualified as Text
  18 import GHC.Base (error)
  19 import GHC.Stack (HasCallStack)
  20 import Network.URI.Slug (Slug)
  21 import Network.URI.Slug qualified as URI
  22 import Symantic (
  23   Optionable (..),
  24   ProductFunctor (..),
  25   SumFunctor (..),
  26  )
  27 import Symantic.Classes (Iso (..), IsoFunctor (..))
  28 import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist {-, getCurrentDirectory-})
  29 import System.FilePath (FilePath, takeDirectory, (</>))
  30 import System.FilePath qualified as FilePath
  31 import System.FilePattern.Directory (getDirectoryFiles)
  32 import System.IO (IO, hPutStrLn, stderr)
  33 import Text.Show (Show (..))
  34 import Webc.Classes hiding ((</>))
  35 import Webc.MIME (PlainText)
  36
  37 -- * The 'Compiler' interpreter
  38
  39 newtype Compiler a = Compiler
  40   { unCompiler :: [Comp a]
  41   }
  42   deriving (Functor, Show)
  43
  44 instance Applicative Compiler where
  45   pure = Compiler . pure . pure
  46   Compiler f <*> Compiler x = Compiler $ (<*>) <$> f <*> x
  47
  48 -- instance Monad Compiler where
  49 --   return = pure
  50 --   Compiler x >>= f = Compiler (x >>=)
  51
  52 data CompilerConf = CompilerConf
  53   { compilerConfSource :: FilePath
  54   , compilerConfDest :: FilePath
  55   }
  56
  57 compile :: Show a => Renderable a => Compiler a -> CompilerConf -> IO ()
  58 compile comp CompilerConf{..} = do
  59   createDirectoryIfMissing True compilerConfDest
  60   let routes = unCompiler comp
  61   when (null routes) $
  62     error "no routes, nothing to compile"
  63   forM_ routes $ \c@Comp{..} -> do
  64     hPutStrLn stderr $ "route: " <> show c
  65     let routePath = pathOfSlugs compSlugs
  66      in case render c of
  67           Left staticPath ->
  68             doesPathExist (compilerConfSource </> staticPath) >>= \case
  69               True -> do
  70                 -- TODO: In current branch, we don't expect this to be a directory.
  71                 -- Although the user may pass it, but review before merge.
  72                 hPutStrLn stderr $
  73                   "staticCopy: "
  74                     <> show
  75                       ( (compilerConfSource </> staticPath)
  76                       , (compilerConfDest </> staticPath)
  77                       )
  78                 copyDirRecursively
  79                   routePath
  80                   (compilerConfSource </> staticPath)
  81                   (compilerConfDest </> staticPath)
  82               False ->
  83                 return ()
  84           -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
  85           Right (bs, ext) -> do
  86             hPutStrLn stderr $ "mkdir: " <> show (takeDirectory (compilerConfDest </> routePath))
  87             createDirectoryIfMissing True (takeDirectory (compilerConfDest </> routePath))
  88             hPutStrLn stderr $ "write: " <> show (compilerConfDest </> routePath FilePath.<.> ext)
  89             BSL.writeFile (compilerConfDest </> routePath FilePath.<.> ext) bs
  90
  91 -- ** Class 'Renderable'
  92 class Renderable a where
  93   render :: Comp a -> Either FilePath (BSL.ByteString, FilePath)
  94 instance Renderable () where
  95   render Comp{..} = Left $ pathOfSlugs compSlugs
  96
  97 pathOfSlugs :: [Slug] -> FilePath
  98 pathOfSlugs s = Text.unpack $ Text.intercalate "/" $ URI.encodeSlug <$> s
  99
 100 -- ** Type 'Comp'
 101 data Comp a = Comp
 102   { compSlugs :: [Slug] -- TODO: Endo? Seq?
 103   , compValue :: a
 104   , compExt :: Maybe FilePath
 105   }
 106   deriving (Eq, Ord, Show, Functor)
 107 instance Applicative Comp where
 108   pure compValue =
 109     Comp
 110       { compSlugs = []
 111       , compValue
 112       , compExt = Nothing
 113       }
 114   f <*> x =
 115     Comp
 116       { compSlugs = compSlugs f <> compSlugs x
 117       , compValue = compValue f (compValue x)
 118       , compExt = compExt f <> compExt x
 119       }
 120
 121 instance IsoFunctor Compiler where
 122   (<%>) Iso{..} = (a2b <$>)
 123 instance ProductFunctor Compiler where
 124   (<.>) = liftA2 (,)
 125   (<.) = (<*)
 126   (.>) = (*>)
 127 instance SumFunctor Compiler where
 128   x <+> y =
 129     Compiler $
 130       (<>)
 131         ((Left <$>) <$> unCompiler x)
 132         ((Right <$>) <$> unCompiler y)
 133 instance Optionable Compiler where
 134   optional x =
 135     Compiler $
 136       Comp{compSlugs = [], compValue = Nothing, compExt = Nothing} :
 137       ((Just <$>) <$> unCompiler x)
 138 instance Slugable Compiler where
 139   literalSlug s = Compiler [Comp{compSlugs = [s], compValue = (), compExt = Nothing}]
 140   chooseSlug ss =
 141     Compiler $
 142       [ Comp{compSlugs = [s], compValue = s, compExt = Nothing}
 143       | s <- toList ss
 144       ]
 145 instance ContentTypeable PlainText () Compiler where
 146   contentType =
 147     Compiler
 148       [ Comp
 149           { compSlugs = []
 150           , compValue = ()
 151           , compExt = Just "txt"
 152           }
 153       ]
 154
 155 -- instance Repeatable Compiler where
 156 --   many0 (Compiler x) =
 157 --     Compiler $
 158 --       ((\Comp{} -> Comp [] []) <$> x)
 159 --         <> ((\(Comp s a) -> Comp s [a]) <$> x)
 160 --         <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
 161 --   many1 (Compiler x) =
 162 --     Compiler $
 163 --       ((\(Comp s a) -> Comp s [a]) <$> x)
 164 --         <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
 165 -- instance Endable Compiler where
 166 --   end = Compiler [Comp [] ()]
 167 -- instance Capturable Compiler where
 168 --   captureSlug n = Compiler $ [Comp [n] n]
 169 -- instance Constantable c Compiler where
 170 --   constant = pure
 171
 172 {-
 173 let (staticPaths, generatedPaths) =
 174       lefts &&& rights $
 175         routes <&> \r ->
 176           case render model r of
 177             AssetStatic fp -> Left (r, fp)
 178             AssetComperated _fmt s -> Right (encodeRoute model r, s)
 179 paths <- forM generatedPaths $ \(relPath, !s) -> do
 180   let fp = dest </> relPath
 181   log LevelInfo $ toText $ "W " <> fp
 182   liftIO $ do
 183     createDirectoryIfMissing True (takeDirectory fp)
 184     writeFileLBS fp s
 185     pure fp
 186 forM_ staticPaths $ \(r, staticPath) -> do
 187   liftIO (doesPathExist staticPath) >>= \case
 188     True ->
 189       -- TODO: In current branch, we don't expect this to be a directory.
 190       -- Although the user may pass it, but review before merge.
 191       copyDirRecursively (encodeRoute model r) staticPath dest
 192     False ->
 193       log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
 194 -}
 195 {-
 196 instance Slugable Compiler where
 197   literalSlug s = Compiler $ return $ Endo (s :)
 198   captureSlug _n = Compiler $ MT.ReaderT $ \s -> return $ Endo (s :)
 199 instance ProductFunctor Compiler where
 200   Compiler x <.> Compiler y = Compiler $
 201     MT.ReaderT $ \env ->
 202       MT.withReaderT (\env -> env{compilerArgs = b2a (compilerArgs env)})
 203       return $
 204         MT.runReaderT x a
 205           <> MT.runReaderT y b
 206 -}
 207
 208 --deriving stock (Eq, Show, Ord, Comperic)
 209
 210 {-
 211
 212 safeForLarge' :: Int -> IO ()
 213 safeForLarge' n = flip finally (cleanup tmpfile) $ do
 214     cleanup tmpfile
 215     lgrset <- newFileLoggerSet defaultBufSize tmpfile
 216     let xs = toLogStr $ BS.pack $ take (abs n) (cycle ['a'..'z'])
 217         lf = "x"
 218     pushLogStr lgrset $ xs <> lf
 219     flushLogStr lgrset
 220     rmLoggerSet lgrset
 221     bs <- BS.readFile tmpfile
 222     bs `shouldBe` BS.pack (take (abs n) (cycle ['a'..'z']) <> "x")
 223     where
 224         tmpfile = "test/temp"
 225
 226 cleanup :: FilePath -> IO ()
 227 cleanup file = do
 228     exist <- doesFileExist file
 229     when exist $ removeFile file
 230
 231 logAllMsgs :: IO ()
 232 logAllMsgs = logAll "LICENSE" `finally` cleanup tmpfile
 233   where
 234     tmpfile = "test/temp"
 235     logAll file = do
 236         cleanup tmpfile
 237         lgrset <- newFileLoggerSet 512 tmpfile
 238         src <- BS.readFile file
 239         let bs = (<> "\n") . toLogStr <$> BS.lines src
 240         mapM_ (pushLogStr lgrset) bs
 241         flushLogStr lgrset
 242         rmLoggerSet lgrset
 243         dst <- BS.readFile tmpfile
 244         dst `shouldBe` src
 245
 246 compile ::
 247   forall model m route.
 248   ( -- MonadIO m,
 249     -- MonadUnliftIO m,
 250     -- MonadLoggerIO m,
 251     -- Show r,
 252     HasCallStack
 253   ) =>
 254   FilePath ->
 255   model ->
 256   (model -> route -> Asset BSL.ByteString) ->
 257   -- | List of generated files.
 258   IO ()
 259 compile dest model render = do
 260   dirExists <- doesDirectoryExist dest
 261   when (not dirExists) $ do
 262     error $ "Destination does not exist: " <> dest
 263   let routes = allRoutes model
 264   when (null routes) $
 265     error "allRoutes is empty; nothing to compile"
 266   -- log LevelInfo $ "Writing " <> show (length routes) <> " routes"
 267   let staticPaths =
 268           (<$> routes) $ \route ->
 269             case render model route of
 270               AssetStatic fp -> Left (route, fp)
 271               AssetComperated _fmt s -> Right (encodeRoute model route, s)
 272   forM_ staticPaths $ \(route, staticPath) -> do
 273     (doesPathExist staticPath) >>= \case
 274       True ->
 275         -- TODO: In current branch, we don't expect this to be a directory.
 276         -- Although the user may pass it, but review before merge.
 277         copyDirRecursively (encodeRoute model route) staticPath dest
 278       False ->
 279         return ()
 280         -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
 281
 282 log :: MonadLogger m => LogLevel -> Text -> m ()
 283 log = logWithoutLoc "Comperate"
 284
 285 -- | Disable birdbrained hacks from GitHub to disable surprises like,
 286 -- https://github.com/jekyll/jekyll/issues/55
 287 noBirdbrainedJekyll :: (MonadIO m, MonadLoggerIO m) => FilePath -> m ()
 288 noBirdbrainedJekyll dest = do
 289   let nojekyll = dest </> ".nojekyll"
 290   liftIO (doesFileExist nojekyll) >>= \case
 291     True -> pure ()
 292     False -> do
 293       log LevelInfo $ "Disabling Jekyll by writing " <> toText nojekyll
 294       writeFileLBS nojekyll ""
 295
 296 newtype StaticAssetMissing = StaticAssetMissing FilePath
 297   deriving stock (Show)
 298   deriving anyclass (Exception)
 299
 300 -}
 301 copyDirRecursively ::
 302   ( --MonadIO m,
 303     --MonadUnliftIO m,
 304     --MonadLoggerIO m,
 305     HasCallStack
 306   ) =>
 307   -- | Source file path relative to CWD
 308   FilePath ->
 309   -- | Absolute path to source file to copy.
 310   FilePath ->
 311   -- | Directory *under* which the source file/dir will be copied
 312   FilePath ->
 313   IO ()
 314 copyDirRecursively srcRel srcAbs destParent = do
 315   doesFileExist srcAbs >>= \case
 316     True -> do
 317       let b = destParent </> srcRel
 318       --log LevelInfo $ toText $ "C " <> b
 319       copyFileCreatingParents srcAbs b
 320     False ->
 321       doesDirectoryExist srcAbs >>= \case
 322         False ->
 323           return ()
 324         -- throw $ StaticAssetMissing srcAbs
 325         True -> do
 326           fs <- getDirectoryFiles srcAbs ["**"]
 327           forM_ fs $ \fp -> do
 328             let a = srcAbs </> fp
 329                 b = destParent </> srcRel </> fp
 330             -- log LevelInfo $ toText $ "C " <> b
 331             copyFileCreatingParents a b
 332   where
 333     copyFileCreatingParents a b = do
 334       createDirectoryIfMissing True (takeDirectory b)
 335       copyFile a b