gemmula-altera 1.0.0 → 2.0.0

raw patch · 5 files changed

+287/−6 lines, 5 filesdep +directorydep +filepathdep +optparse-applicativedep ~basedep ~gemmuladep ~textnew-component:exe:gemalterPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath, optparse-applicative

Dependency ranges changed: base, gemmula, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• README.md +2/−0
• app/Main.hs +248/−0
• gemmula-altera.cabal +17/−2
• src/Text/Gemini/Web.hs +15/−4

@@ -1,6 +1,11 @@  # `gemmula-altera` Change Log +## 2.0.0 (January 18, 2024)+* Add `gemalter` executable.+* Add `Text.Gemini.Web.getTitle` function.+* Don't "webify" non-`gemini://` links.+ ## 1.0.0 (January 14, 2024) * Initial release! 

@@ -7,6 +7,8 @@ * [Markdown](https://hackage.haskell.org/package/gemmula-altera/docs/Text-Gemini-Markdown.html) ([CommonMark](https://spec.commonmark.org/current)) * [HTML](https://hackage.haskell.org/package/gemmula-altera/docs/Text-Gemini-Web.html) +See the repository [page](https://codeberg.org/sena/gemmula) for (also) tiny command line app usage.+ The documentation is available at [Hackage](https://hackage.haskell.org/package/gemmula-altera).  You can find more information and related modules at the [Codeberg repository](https://codeberg.org/sena/gemmula).

@@ -0,0 +1,248 @@+{-# LANGUAGE OverloadedStrings, LambdaCase, NamedFieldPuns, TupleSections #-}++-- |+-- Module      :  Main+-- Copyright   :  (c) Sena, 2024+-- License     :  AGPL-3.0-or-later+--+-- Maintainer  :  Sena <jn-sena@proton.me>+-- Stability   :  unstable+-- Portability :  portable+--+-- A tiny command line helper for converting Gemini capsules.+--+-- Converts Gemtext to Markdown and HTML.++module Main (main) where++import Options.Applicative+import Control.Monad (when)+import Control.Arrow (first, second)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Maybe (fromMaybe)+import Data.List (isPrefixOf)+import Data.Bool (bool)+import Data.Function ((&))++import System.IO (hReady, stdin)+import System.Directory+import System.FilePath++import Paths_gemmula_altera (version)+import Data.Version (showVersion)+import Data.Text.IO (readFile, writeFile)+import Prelude hiding (readFile, writeFile)++import Text.Gemini (GemDocument)+import qualified Text.Gemini as G+import qualified Text.Gemini.Markdown as M+import qualified Text.Gemini.Web as W+++-- | Process the input files according to the command and write them.+run :: Opts -> IO ()+run opt = case mode opt of+    Markdown {} -> writeFiles =<< processFiles opt (markdown opt) "md"+    Web {} -> writeFiles =<< processFiles opt (web opt) "html"++-- | Process the piped input and write it.+-- Doesn't have any advanced options.+pipeRun :: PipeOpts -> IO ()+pipeRun opt = case pipeMode opt of+    PipeMarkdown {} -> putStr =<< processPipe M.encode+    PipeWeb {} -> putStr =<< processPipe W.encode+    where processPipe :: (GemDocument -> Text) -> IO String+          processPipe convert = T.unpack . convert . G.decode . T.pack <$> getContents+++-- | Convert Gemtext to Markdown.+--+-- Rewrites all local @.gmi@ links as @.md@ and encodes the file using 'M.encode'.+-- Non-local links are webified using 'W.webifyLink' if the @webify@ flag is used.+markdown :: Opts -> FilePath -> GemDocument -> IO Text+markdown (Opts { webify }) _ = fmap (M.encode . map M.rewriteLink) . bool return (mapM W.webifyLink) webify++-- | Convert Gemtext to HTML.+--+-- Rewrites all local @.gmi@ links as @.html@ and encodes the file using 'W.encode'.+-- Non-local links are webified using 'W.webifyLink' if the @webify@ flag is used.+--+-- If the body flag is not used, the template is used with the following special variables:+--+--     * @body@: Encoded HTML body, converted from GemText.+--     * @title@: The text of the first <h1> heading in the document.+--+-- The file path variables are inserted while processing the inputs.+web :: Opts -> FilePath -> GemDocument -> IO Text+web (Opts { mode, webify }) path doc+    | body mode = fmap (W.encode . map W.rewriteLink) . bool return (mapM W.webifyLink) webify $ doc+    | otherwise = let title = fromMaybe (T.pack $ takeFileName path) $ W.getTitle doc+                      defaultTemplate = T.unlines+                          [ "<!DOCTYPE html>"+                          , "<html lang=\"en\">"+                          , "  <head>"+                          , "    <meta charset=\"utf-8\" />"+                          , "    <meta name=\"viewport\" content=\"width=device-width, \+                              \ initial-scale=1.0, maximum-scale=1.0\" />"+                          , "    <link href=\"<!--#VAR style#-->\" rel=\"stylesheet\" />"+                          , "    <title><!--#VAR title#--></title>"+                          , "  </head>"+                          , "  <body>"+                          , ""+                          , "<!--#VAR body#-->"+                          , "  </body>"+                          , "</html>"+                          ]+          in do templ <- maybe (return defaultTemplate) readFile $ template mode+                body <- fmap (W.encode . map W.rewriteLink) . bool return (mapM W.webifyLink) webify $ doc+                return $ insertVars templ [("body", body), ("title", title)]+++-- | Write the processed files to their output paths.+writeFiles :: [(FilePath, Either FilePath Text)] -> IO ()+writeFiles files = do when (null files) $ errorWithoutStackTrace "No files to copy or write found."+                      mapM_ (\(out, content) -> case content of+                                                    Left src -> copyFile src out+                                                    Right text -> writeFile out text) files++-- | Process the input files with the given converter function and extension.+-- The output is a tuple with the output path of the file; and the content of the+-- file, where Left is the path to copy from if the input file isn't @.gmi@, or+-- Right is the converted text content if it is @.gmi@.+--+-- Directories are processed recursively. If the input is a single directory, the+-- files are directly put in the output dir, with the input dir name stripped.+-- Otherwise, they are put in a subdirectory in the output dir.+--+-- The file path variables are inserted here, after the subdir is stripped if needed.+processFiles :: Opts -> (FilePath -> GemDocument -> IO Text) -> String -> IO [(FilePath, Either FilePath Text)]+processFiles (Opts { mode, output, copy }) convert ext = let+    stripSubdir fs = if all (isPrefixOf (head $ splitDirectories (fst $ head fs)) . fst) fs+                     then return $ map (first ((\p -> joinPath $ bool p (tail p) (length p > 1)) . splitPath)) fs+                     else return fs++    insertPathVars = case mode of+        Web {} -> mapM (\(path, content) -> case content of+                      Left _ -> return (path, content)+                      Right t -> (path,) . Right . insertVars t <$> mapM (pathVar path) (filevars mode))+        _ -> return++    outputPath fs+        | length fs <= 1 = maybe (return fs)+              (\o -> (fs &) . map . bool (first (const o)) (first (o </>)) <$> doesDirectoryExist o) output+        | otherwise = let out = fromMaybe "result" output+                       in do createDirectoryIfMissing True out+                             mapM_ (\f -> createDirectoryIfMissing True (out </> takeDirectory (fst f))) fs+                             return $ map (first (out </>)) fs++    in outputPath =<< insertPathVars =<< stripSubdir . concat =<< mapM (process "") (inputs mode)++    where process :: FilePath -> FilePath -> IO [(FilePath, Either FilePath Text)]+          process root path = ((path &) . bool (single root) (recurse root)) =<< doesDirectoryExist path++          single :: FilePath -> FilePath -> IO [(FilePath, Either FilePath Text)]+          single root path+              | takeExtension path /= ".gmi" = return $ bool [] [(root </> takeFileName path, Left path)] copy+              | otherwise = let out = root </> replaceExtension (takeFileName path) ext+                             in (:[]) . (out,) . Right <$> (convert out . G.decode =<< readFile path)++          recurse :: FilePath -> FilePath -> IO [(FilePath, Either FilePath Text)]+          recurse root path = let proc p = process (root </> last (splitDirectories path)) (path </> p)+                               in fmap concat . mapM proc =<< listDirectory path+++-- | Parse the variable option and make it relative to the 'FilePath'.+pathVar :: FilePath -> Text -> IO (Text, Text)+pathVar path text = (\(name, val) ->+    let relative = joinPath (replicate (length . init . splitDirectories $ path) "..") </> val+     in return (name, T.pack relative)) . second T.unpack =<< getVar text++-- | Parse a variable option of @"key=val"@ as a pair of key and value.+getVar :: Text -> IO (Text, Text)+getVar var+    | T.null val = errorWithoutStackTrace "Incorrect variable option. See \"web --help\"."+    | otherwise = return (name, val)+    where (name, val) = second (T.drop 1) . T.break (== '=') $ var++-- | Replace the variable keywords in the text with the parsed variables in the list.+insertVars :: Text -> [(Text, Text)] -> Text+insertVars text vars = foldr (\(n, v) t -> T.replace ("<!--#VAR " <> n <> "#-->") v t) text (reverse vars)+++-- | Options to use normally.+data Opts = Opts { output :: !(Maybe FilePath)+                 , copy :: !Bool+                 , webify :: !Bool+                 , mode :: !Command+                 } deriving (Show, Eq)++data Command = Markdown { inputs :: ![FilePath] }+             | Web { body :: !Bool+                   , template :: !(Maybe FilePath)+                   , filevars :: ![Text]+                   , inputs :: ![FilePath]+                   } deriving (Show, Eq)++opts :: Parser Opts+opts = Opts+    <$> optional (option str+        ( long "output"+       <> short 'o'+       <> help "The output path"+       <> metavar "PATH" ))+    <*> flag True False+        ( long "no-copy"+       <> short 'n'+       <> help "Do not copy non-convertable files to the output dir" )+    <*> switch+        ( long "webify"+       <> short 'w'+       <> help "Rewrite gemini links as http if they can be reached" )+    <*> hsubparser+        ( command "md" (info (Markdown+                  <$> some (argument str (metavar "FILES"))+              ) (progDesc "Convert Gemtext files to Markdown."))+       <> command "web" (info (Web+                  <$> switch+                      ( long "body"+                     <> short 'b'+                     <> help "Output the HTML body only" )+                  <*> optional (option str+                      ( long "template"+                     <> short 't'+                     <> help "Template file to use while producing HTML outputs, \+                            \ where <!--#VAR name#--> are replaced with the \+                            \ variable values. Special variables are: body, title"+                     <> metavar "PATH" ))+                  <*> many (option str+                      ( long "file"+                     <> short 'f'+                     <> help "Set a dynamic file path variable always pointing to \+                            \ the given path, in the form of \"name=value\", where \+                            \ value must be a path relative to the output root"+                     <> metavar "VAR" ))+                  <*> some (argument str (metavar "FILES"))+              ) (progDesc "Convert Gemtext files to HTML.")) )++-- | Options to use if there's a piped input.+newtype PipeOpts = PipeOpts { pipeMode :: PipeCommand } deriving (Show, Eq)+data PipeCommand = PipeMarkdown | PipeWeb deriving (Show, Eq)++pipeOpts :: Parser PipeOpts+pipeOpts = PipeOpts+    <$> hsubparser+        ( command "md" (info (pure PipeMarkdown)+              (progDesc "Convert Gemtext files to Markdown."))+       <> command "web" (info (pure PipeWeb)+              (progDesc "Convert Gemtext files to HTML.")) )++main :: IO ()+main = let parser p = info (p <**> helper <**> simpleVersioner ("v" <> showVersion version))+                          ( fullDesc+                         <> progDesc "Convert Gemtext to Markdown and HTML using gemmula library."+                         <> header "gemalter - a tiny command line helper for converting Gemini capsules")+       in hReady stdin >>= \case+              False -> run =<< execParser (parser opts)+              True -> pipeRun =<< execParser (parser pipeOpts)+

@@ -1,8 +1,9 @@ name:               gemmula-altera-version:            1.0.0+version:            2.0.0 synopsis:           A tiny Gemtext converter for gemmula description:        gemmula-altera is a tiny Gemtext converter, built on gemmula library.-                    It provides simple encodings for Markdown and HTML.+                    It provides simple encodings for Markdown and HTML, plus a tiny+                    command line helper. license:            AGPL-3 license-file:       LICENSE author:             Sena <jn-sena@proton.me>@@ -26,6 +27,20 @@                  , HTTP >= 4000.4.0 && < 5000.0                  , modern-uri >= 0.3.6 && < 0.4   ghc-options:     -Wall++executable gemalter+  default-language: Haskell2010+  hs-source-dirs: app+  main-is:        Main.hs+  other-modules:  Paths_gemmula_altera+  build-depends:  base+                , text+                , filepath >= 1.4.100.4 && < 1.6+                , directory >= 1.3.7 && < 1.4+                , optparse-applicative >= 0.18.1 && < 0.19+                , gemmula+                , gemmula-altera+  ghc-options:    -Wall  test-suite gemmulae-alterius-probatio   default-language: Haskell2010

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-}+{-# LANGUAGE OverloadedStrings, LambdaCase, TupleSections #-}  -- | -- Module      :  Text.Gemini.Web@@ -22,6 +22,8 @@       -- * Rewriting links     , rewriteLink     , webifyLink+      -- * Other+    , getTitle     ) where  import Control.Exception (catch, SomeException)@@ -29,6 +31,7 @@ import qualified Data.Text as T import Data.Maybe (fromMaybe, fromJust, isNothing, maybeToList) import Data.Either (isRight)+import Data.List (find) import Data.Bool (bool) import qualified Text.URI as URI import Network.HTTP (simpleHTTP, getRequest, getResponseCode)@@ -104,14 +107,22 @@ -- Does /nothing/ if the link is local or can't be reached. webifyLink :: GemItem -> IO GemItem webifyLink (GemLink link desc)-    | isRight (URI.uriAuthority uri) = (\(t, _, _) -> GemLink (bool (URI.render uri') link (t > 3)) desc) <$>-          catch (simpleHTTP (getRequest $ URI.renderStr uri') >>= getResponseCode)-              (\e -> let _ = (e :: SomeException) in return (9, 9, 9))+    | isRight (URI.uriAuthority uri) && maybe "" URI.unRText (URI.uriScheme uri) == "gemini" =+          (\(t, _, _) -> GemLink (bool (URI.render uri') link (t > 3)) desc) <$>+              catch (simpleHTTP (getRequest $ URI.renderStr uri') >>= getResponseCode)+                  (\e -> let _ = (e :: SomeException) in return (9, 9, 9))     | otherwise = return $ GemLink link desc     where uri = fromMaybe URI.emptyURI $ URI.mkURI link           uri' = uri {URI.uriScheme = Just (fromJust $ URI.mkScheme "http")} webifyLink item = return item ++-- | Get the text of the first @<h1>@ in the document, if there's any.+--+-- Useful for using as @<title>@.+getTitle :: GemDocument -> Maybe Text+getTitle doc = (\case { GemHeading _ t -> Just t; _ -> Nothing })+                   =<< find (\case { GemHeading l _ -> l == 1; _ -> False }) doc  -- Creates a HTML tag with the given name, attributes and body. -- The body and attributes are escaped using the functions below.