diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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! diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE OverloadedStrings, LambdaCase, NamedFieldPuns, TupleSections #-} + +-- | +-- Module : Main +-- Copyright : (c) Sena, 2024 +-- License : AGPL-3.0-or-later +-- +-- Maintainer : Sena +-- 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

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 + [ "" + , "" + , " " + , " " + , " " + , " \" rel=\"stylesheet\" />" + , " <!--#VAR title#-->" + , " " + , " " + , "" + , "" + , " " + , "" + ] + 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 ("") 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 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) + diff --git a/gemmula-altera.cabal b/gemmula-altera.cabal --- a/gemmula-altera.cabal +++ b/gemmula-altera.cabal @@ -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 @@ -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 diff --git a/src/Text/Gemini/Web.hs b/src/Text/Gemini/Web.hs --- a/src/Text/Gemini/Web.hs +++ b/src/Text/Gemini/Web.hs @@ -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 @

@ in the document, if there's any. +-- +-- Useful for using as @@. +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.