diff options
author | defanor <defanor@uberspace.net> | 2017-11-05 11:16:46 +0300 |
---|---|---|
committer | defanor <defanor@uberspace.net> | 2017-11-05 11:37:27 +0300 |
commit | 09e4bdddc7415117cc27047ad0d7afe523f064c2 (patch) | |
tree | 09a9801234540c1685d011c71ea04bbc4a9bb22b /Pancake.hs | |
parent | 8f9c51474f8cad8cd2337f9231d95fd8e7f7e258 (diff) |
Read metadata
Reading effective URI and content type (if those are available) now,
aiming `curl -w` or similar commands.
Not a particularly nice way, and complicates both the program and the
configuration, but sometimes file name extensions are deceptive.
Diffstat (limited to 'Pancake.hs')
-rw-r--r-- | Pancake.hs | 89 |
1 files changed, 47 insertions, 42 deletions
@@ -31,6 +31,7 @@ import System.Exit import Control.Exception import Data.Char import System.IO.Error +import Control.Applicative import Pancake.Common import Pancake.Configuration @@ -82,52 +83,56 @@ loadDocument :: MonadIO m -> URI -- ^ Document URI. -> StateT LoopState m (URI, Maybe P.Pandoc) -loadDocument t u' = do +loadDocument sType rawURI = do st <- get - let ddg = isPrefixOf "/l/?kh=-1&uddg=" $ uriToString id u' "" - u = case (ddg, uriIsAbsolute u', history st) of - -- fix DDG links (that's rather hacky, todo: improve) - (True, _, _) -> maybe u' id $ - parseAbsoluteURI (unEscapeString $ drop 12 (uriQuery u')) - -- handle relative URIs - (_, False, ((cur, _):_, _)) -> relativeTo u' cur - _ -> u' - uScheme = case uriScheme u of + let ddg = isPrefixOf "/l/?kh=-1&uddg=" $ uriToString id rawURI "" + adjustedURI = case (ddg, uriIsAbsolute rawURI, history st) of + -- fix DDG links (that's rather hacky, todo: improve) + (True, _, _) -> maybe rawURI id $ + parseAbsoluteURI (unEscapeString $ drop 12 (uriQuery rawURI)) + -- handle relative URIs + (_, False, ((cur, _):_, _)) -> relativeTo rawURI cur + _ -> rawURI + uScheme = case uriScheme adjustedURI of [] -> "unknown" - (_:s) -> s + s -> init s cmd = maybe (defaultCommand $ conf st) id $ M.lookup uScheme (commands $ conf st) - ext = case (t, takeExtension $ uriPath u) of - (Just x, _) -> x - (_, '.':xs) -> map toLower xs - (_, other) -> other - d <- liftIO $ do - case M.lookup ext (externalViewers $ conf st) of - Nothing -> do - doc <- readDoc cmd t u - case doc of - Left err -> do - putErrLn $ show err - pure mzero - Right r -> pure $ pure r - Just ev -> do - d <- retrieve cmd u - dir <- getXdgDirectory XdgCache "pancake" - let tmpPath = dir </> (takeFileName $ uriPath u) - handle - (\(e :: SomeException) -> - putErrLn (concat ["Failed to open `", tmpPath, "` with `" - , cmd, "`: ", show e])) $ do - createDirectoryIfMissing True dir - BS.writeFile tmpPath d - curEnv <- getEnvironment - ec <- withCreateProcess - ((shell ev) { env = Just (("FILE", tmpPath) : curEnv) }) $ - \_ _ _ p -> waitForProcess p - when (ec /= ExitSuccess) $ - putErrLn $ concat ["An error occured. Exit code: ", show ec] - pure mzero - pure (u, d) + liftIO $ do + docData <- retrieve cmd adjustedURI + case docData of + Nothing -> pure (adjustedURI, mzero) + Just (rawDoc, mdURI, mdType) -> do + let effectiveURI = maybe adjustedURI id mdURI + fType = sType <|> mdType + ext = case (fType, takeExtension $ uriPath effectiveURI) of + (Just x, _) -> x + (_, '.':xs) -> map toLower xs + (_, other) -> other + case M.lookup ext (externalViewers $ conf st) of + Nothing -> do + doc <- readDoc rawDoc fType effectiveURI + case doc of + Left err -> do + putErrLn $ show err + pure (effectiveURI, mzero) + Right r -> pure (effectiveURI, pure r) + Just ev -> do + dir <- getXdgDirectory XdgCache "pancake" + let tmpPath = dir </> (takeFileName $ uriPath effectiveURI) + handle + (\(e :: SomeException) -> + putErrLn (concat ["Failed to open `", tmpPath, "` with `" + , cmd, "`: ", show e])) $ do + createDirectoryIfMissing True dir + BS.writeFile tmpPath rawDoc + curEnv <- getEnvironment + ec <- withCreateProcess + ((shell ev) { env = Just (("FILE", tmpPath) : curEnv) }) $ + \_ _ _ p -> waitForProcess p + when (ec /= ExitSuccess) $ + putErrLn $ concat ["An error occured. Exit code: ", show ec] + pure (effectiveURI, mzero) -- | Visits an URI, updates history accordingly. goTo :: MonadIO m => Maybe String -> URI -> StateT LoopState m () |