diohsc-0.1.3: diohsc.hs
-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Main where
import Control.Applicative (Alternative, empty)
import Control.Monad ((<=<))
import Control.Monad.Catch
import Control.Monad.State
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.Bifunctor (second)
import Data.Char (isUpper, toLower)
import Data.Hash (Hash, hash)
import Data.List (find, intercalate, isPrefixOf,
isSuffixOf, stripPrefix)
import Data.Maybe
import Safe
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.IO.Unsafe (unsafeInterleaveIO)
import Text.Regex (Regex, matchRegex,
mkRegexWithOpts)
import Time.System (timeCurrentP)
import Time.Types (ElapsedP)
import qualified Data.ByteString.Lazy as BL
import qualified Codec.MIME.Parse as MIME
import qualified Codec.MIME.Type as MIME
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as TS
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import qualified Data.Text.Lazy.IO as T
import qualified System.Console.Haskeline as HL
import qualified System.Console.Terminal.Size as Size
import ANSIColour
import ActiveIdentities
import Alias
import qualified BStack
import Command
import CommandLine
import GeminiProtocol
import Identity
import Marks
import MetaString
import Mundanities
import Opts
import Pager
import Prompt hiding (promptYN)
import qualified Prompt
import Request
import RunExternal hiding (runRestrictedIO)
import qualified RunExternal
import Slurp
import TextGemini
import URI
import Util
import Version
#ifndef WINDOWS
import System.Posix.Files (ownerModes, setFileMode)
#endif
#ifdef ICONV
import Codec.Text.IConv (convert)
#endif
#ifdef MAGIC
import qualified Magic
#endif
-- |Immutable options set at startup
data ClientOptions = ClientOptions
{ cOptUserDataDir :: FilePath
, cOptInteractive :: Bool
, cOptAnsi :: Bool
, cOptRestrictedMode :: Bool
, cOptGhost :: Bool
, cOptRequestContext :: RequestContext
, cOptLogH :: Maybe Handle
}
data HistoryChild = HistoryChild
{ childItem :: HistoryItem
, childLink :: Maybe Int
}
data HistoryOrigin = HistoryOrigin
{ originItem :: HistoryItem
, originLink :: Maybe Int
}
data HistoryItem = HistoryItem
{ historyRequest :: Request
, historyRequestTime :: ElapsedP
, historyMimedData :: MimedData
, historyGeminatedMimedData :: MimedData -- ^generated with lazy IO
, historyParent :: Maybe HistoryItem
, historyChild :: Maybe HistoryChild
}
historyUri :: HistoryItem -> URI
historyUri = requestUri . historyRequest
historyEnv :: HistoryItem -> [(String,String)]
historyEnv item =
[ ("URI", show $ historyUri item)
, ("MIMETYPE", showMimeType $ historyMimedData item) ]
historyAncestors :: HistoryItem -> [HistoryItem]
historyAncestors i = case historyParent i of
Nothing -> []
Just i' -> i' : historyAncestors i'
historyDescendants :: HistoryItem -> [HistoryItem]
historyDescendants i = case historyChild i of
Nothing -> []
Just (HistoryChild i' _) -> i' : historyDescendants i'
pathItemByUri :: HistoryItem -> URI -> Maybe HistoryItem
pathItemByUri i uri = find ((uri ==) . historyUri) $
historyAncestors i ++ [i] ++ historyDescendants i
data ClientConfig = ClientConfig
{ clientConfDefaultAction :: (String, [CommandArg])
, clientConfProxies :: M.Map String Host
, clientConfGeminators :: [(String,(Regex,String))]
, clientConfRenderFilter :: Maybe String
, clientConfPreOpt :: PreOpt
, clientConfMaxLogLen :: Int
, clientConfMaxWrapWidth :: Int
, clientConfNoConfirm :: Bool
}
defaultClientConfig :: ClientConfig
defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptPre 1000 80 False
data QueueItem = QueueItem
{ queueOrigin :: Maybe HistoryOrigin
, queueUri :: URI
}
data ClientState = ClientState
{ clientCurrent :: Maybe HistoryItem
, clientJumpBack :: Maybe HistoryItem
, clientLog :: BStack.BStack T.Text
, clientVisited :: S.Set Hash
, clientQueue :: [QueueItem]
, clientActiveIdentities :: ActiveIdentities
, clientMarks :: Marks
, clientSessionMarks :: M.Map Int HistoryItem
, clientAliases :: Aliases
, clientQueuedCommands :: [String]
, clientConfig :: ClientConfig
}
type ClientM = StateT ClientState IO
type CommandAction = HistoryItem -> ClientM ()
emptyClientState :: ClientState
emptyClientState = ClientState Nothing Nothing BStack.empty S.empty [] M.empty emptyMarks M.empty defaultAliases [] defaultClientConfig
enqueue :: Maybe Int -> [QueueItem] -> ClientM ()
enqueue _ [] = return ()
enqueue after qs = modify $ \s -> s {clientQueue = insert after qs $ clientQueue s}
where
insert mn as bs = let (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn in del as bs' ++ as ++ del as bs''
del as = filter $ (`notElem` (queueUri <$> as)) . queueUri
dropUriFromQueue :: URI -> ClientM ()
dropUriFromQueue uri = modify $ \s -> s { clientQueue = filter ((/= uri) . queueUri) $ clientQueue s }
popQueuedCommand :: ClientM (Maybe String)
popQueuedCommand = do
cmd <- gets $ headMay . clientQueuedCommands
when (isJust cmd) . modify $ \s ->
s { clientQueuedCommands = drop 1 $ clientQueuedCommands s }
return cmd
modifyCConf :: (ClientConfig -> ClientConfig) -> ClientM ()
modifyCConf f = modify $ \s -> s { clientConfig = f $ clientConfig s }
main :: IO ()
main = do
argv <- getArgs
(opts,args) <- parseArgs argv
when (Help `elem` opts) $ putStr usage >> exitSuccess
when (Version `elem` opts) $ putStrLn version >> exitSuccess
defUserDataDir <- getAppUserDataDirectory programName
userDataDir <- makeAbsolute . fromMaybe defUserDataDir $ listToMaybe [ path | DataDir path <- opts ]
let restrictedMode = Restricted `elem` opts
outTerm <- hIsTerminalDevice stdout
let ansi = NoAnsi `notElem` opts && (outTerm || Ansi `elem` opts)
let argCommands (ScriptFile "-") = warnIOErrAlt $
(T.unpack . T.strip <$>) . T.lines <$> T.getContents
argCommands (ScriptFile f) = warnIOErrAlt $ (T.unpack <$>) <$> readFileLines f
argCommands (OptCommand c) = return [c]
argCommands _ = return []
optCommands <- concat <$> mapM argCommands opts
let interactive = null optCommands || Interactive `elem` opts
let argToUri arg = doesPathExist arg >>= \case
True -> Just . ("file://" <>) . escapePathString <$> makeAbsolute arg
False | Just uri <- parseUriAsAbsolute arg -> return $ Just $ show uri
_ -> printErrOpt ansi ("No such URI / file: " <> arg) >> return Nothing
argCommand <- join <$> mapM argToUri (listToMaybe args)
let initialCommands = optCommands ++ maybeToList argCommand
let ghost = Ghost `elem` opts
mkdirhier userDataDir
#ifndef WINDOWS
setFileMode userDataDir ownerModes -- chmod 700
#endif
let cmdHistoryPath = userDataDir </> "commandHistory"
marksPath = userDataDir </> "marks"
logPath = userDataDir </> "log"
let displayInfo :: [String] -> IO ()
displayInfo = mapM_ $ printInfoOpt ansi
displayWarning = mapM_ $ printErrOpt ansi
promptYN = Prompt.promptYN interactive
callbacks = InteractionCallbacks displayInfo displayWarning waitKey promptYN
requestContext <- initRequestContext callbacks userDataDir ghost
(warnings, marks) <- loadMarks marksPath
displayWarning warnings
let hlSettings = (HL.defaultSettings::HL.Settings ClientM)
{ HL.complete = HL.noCompletion
, HL.historyFile = if ghost then Nothing else Just cmdHistoryPath
}
cLog <- BStack.fromList . reverse <$> readFileLines logPath
let visited = S.fromList $ hash . T.unpack <$> BStack.toList cLog
let openLog :: IO (Maybe Handle)
openLog = ignoreIOErrAlt $ Just <$> do
h <- openFile logPath AppendMode
hSetBuffering h LineBuffering
return h
closeLog :: Maybe Handle -> IO ()
closeLog = maybe (return ()) hClose
bracketOnError openLog closeLog $ \logH ->
let clientOptions = ClientOptions userDataDir interactive ansi ghost
restrictedMode requestContext logH
initState = emptyClientState {clientMarks = marks
, clientLog = cLog, clientVisited = visited}
in do
endState <- (`execStateT` initState) . HL.runInputT hlSettings $
lineClient clientOptions initialCommands
closeLog logH
-- |reread file rather than just writing clientLog, in case another instance has also
-- been appending to the log.
unless ghost . warnIOErr $ truncateToEnd (clientConfMaxLogLen $ clientConfig endState) logPath
printErrOpt :: MonadIO m => Bool -> String -> m ()
printErrOpt ansi s = liftIO . hPutStrLn stderr . applyIf ansi (withColourStr BoldRed) $ "! " <> s
printInfoOpt :: MonadIO m => Bool -> String -> m ()
printInfoOpt ansi s = liftIO . hPutStrLn stderr $ applyIf ansi withBoldStr ". " <> s
getTermSize :: IO (Int,Int)
getTermSize = do
Size.Window height width <- fromMaybe (Size.Window 25 80) <$> Size.size
return (height,width)
lineClient :: ClientOptions -> [String] -> HL.InputT ClientM ()
lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir
, cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands = do
(liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)
lift addToQueueFromFile
mapM_ handleLine' initialCommands
when interactive lineClient'
unless ghost $ lift appendQueueToFile
where
handleLine' :: String -> HL.InputT ClientM Bool
handleLine' line = lift get >>= \s -> handleLine cOpts s line
lineClient' :: HL.InputT ClientM ()
lineClient' = do
cmd <- runMaybeT $ msum
[ do
c <- MaybeT $ lift popQueuedCommand
printInfoOpt ansi $ "> " <> c
return c
, MaybeT $ lift getPrompt >>= promptLineInputT ]
lift addToQueueFromFile
quit <- case cmd of
Nothing -> if interactive
then printErrOpt ansi "Use \"quit\" to quit" >> return False
else return True
Just line -> handleLine' line
unless quit lineClient'
addToQueueFromFile :: ClientM ()
addToQueueFromFile | ghost = return ()
| otherwise = enqueue Nothing <=< (liftIO . ignoreIOErr) $ doesPathExist queueFile >>= \case
True -> catMaybes . (queueLine <$>) <$> readFileLines queueFile <* removeFile queueFile
where
queueLine :: T.Text -> Maybe QueueItem
queueLine s = QueueItem Nothing <$> parseUriAsAbsolute (T.unpack s)
False -> return []
appendQueueToFile :: ClientM ()
appendQueueToFile = do
queue <- gets clientQueue
unless (null queue) . liftIO . BL.appendFile queueFile .
T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue
queueFile :: FilePath
queueFile = userDataDir </> "queue"
getPrompt :: ClientM String
getPrompt = do
queue <- gets clientQueue
curr <- gets clientCurrent
proxies <- gets $ clientConfProxies . clientConfig
ais <- gets clientActiveIdentities
let queueStatus :: Maybe String
queueStatus = guard (not $ null queue) >> return (show (length queue) ++ "~")
colour = applyIf ansi . withColourStr
bold = applyIf ansi withBoldStr
uriStatus :: Int -> URI -> String
uriStatus w uri =
let fullUriStr = stripGem $ show uri
stripGem s = fromMaybe s $ stripPrefix "gemini://" s
mIdName = (identityName <$>) $ findIdentity ais =<< requestOfProxiesAndUri proxies uri
idStr = flip (maybe "") mIdName $ \idName ->
let abbrId = length idName > 8 && length fullUriStr + 2 + length idName > w - 2
in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]"
abbrUri = length fullUriStr + length idStr > w - 2
uriFormat = colour BoldMagenta
uriStr = if abbrUri
then
let abbrUriChars = w - 4 - length idStr
preChars = abbrUriChars `div` 2
postChars = abbrUriChars - preChars
in uriFormat (take preChars fullUriStr) <>
".." <>
uriFormat (drop (length fullUriStr - postChars) fullUriStr)
else uriFormat fullUriStr
in uriStr ++
(if null idStr then "" else colour Green idStr)
prompt :: Int -> String
prompt maxPromptWidth
| interactive = (colour BoldCyan "%%% " ++) . (++ bold "> ") . unwords $ catMaybes
[ queueStatus
, uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus) . historyUri <$> curr
]
| otherwise = ""
prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize
handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool
handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of
Left err -> printErrOpt ansi err >> return False
Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True
Right cline -> handleCommandLine cOpts s cline >> return False
where
catchInterrupts = HL.handleInterrupt (printErrOpt ansi "Interrupted." >> return False) . HL.withInterrupt . lift
backupHandler :: SomeException -> HL.InputT ClientM Bool
backupHandler = (>> return False) . printErrOpt ansi . ("Unhandled exception: " <>) . show
data Target
= TargetHistory HistoryItem
| TargetFrom HistoryOrigin URI
| TargetIdUri String URI
| TargetUri URI
targetUri :: Target -> URI
targetUri (TargetHistory item) = historyUri item
targetUri (TargetFrom _ uri) = uri
targetUri (TargetIdUri _ uri) = uri
targetUri (TargetUri uri) = uri
targetQueueItem :: Target -> QueueItem
targetQueueItem (TargetFrom o uri) = QueueItem (Just o) uri
targetQueueItem i = QueueItem Nothing $ targetUri i
handleCommandLine :: ClientOptions -> ClientState -> CommandLine -> ClientM ()
handleCommandLine
cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)
cState@(ClientState curr jumpBack cLog visited queue _ marks sessionMarks aliases _
(ClientConfig defaultAction proxies geminators renderFilter preOpt maxLogLen maxWrapWidth confNoConfirm))
= \(CommandLine mt mcas) -> case mcas of
Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->
let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args
appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)
where
appendTail arg@(CommandArg a' t') = case args of
[] -> arg
(CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t
in handleCommandLine' (mt' `mplus` mt) $
(appendCArgs <$> mcas') `mplus` mcas''
_ -> handleCommandLine' mt mcas
where
-- Remark: we handle haskell's "configurations problem" by having the below all within the scope
-- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of
-- simulating global variables or threading a Reader monad throughout. The downside is that this
-- module can't be split as much as it ought to be.
-- Similar remarks go for `GeminiProtocol.makeRequest`.
onRestriction :: IO ()
onRestriction = printErr "This is not allowed in restricted mode."
doRestricted :: Monoid a => RestrictedIO a -> IO a
doRestricted m | restrictedMode = onRestriction >> return mempty
| otherwise = RunExternal.runRestrictedIO m
doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)
doRestrictedAlt m | restrictedMode = onRestriction >> return empty
| otherwise = RunExternal.runRestrictedIO m
doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)
doRestrictedFilter f | restrictedMode = \a -> do
onRestriction
return a
| otherwise = RunExternal.runRestrictedIO . f
printInfo :: MonadIO m => String -> m ()
printInfo = printInfoOpt ansi
printErr :: MonadIO m => String -> m ()
printErr = printErrOpt ansi
printIOErr :: IOError -> IO ()
printIOErr = printErr . show
noConfirm :: Bool
noConfirm = confNoConfirm || not interactive
confirm :: Applicative m => m Bool -> m Bool
confirm | noConfirm = const $ pure True
| otherwise = id
promptYN = Prompt.promptYN interactive
colour :: MetaString a => Colour -> a -> a
colour = applyIf ansi . withColourStr
bold :: MetaString a => a -> a
bold = applyIf ansi withBoldStr
isVisited :: URI -> Bool
isVisited uri = S.member (hash $ show uri) visited
requestOfUri = requestOfProxiesAndUri proxies
idAtUri :: ActiveIdentities -> URI -> Maybe Identity
idAtUri ais uri = findIdentity ais =<< requestOfUri uri
showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a
showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base
showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a
showUriFull ansi' ais base uri =
let scheme = uriScheme uri
handled = scheme `elem` ["gemini","file"] || M.member scheme proxies
col = case (isVisited uri,handled) of
(True,True) -> Yellow
(False,True) -> BoldYellow
(True,False) -> Red
(False,False) -> BoldRed
s = case base of
Nothing -> show uri
Just b -> show $ relativeFrom uri b
in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of
Nothing -> ""
Just ident -> showIdentity ansi' ident
displayUri :: MetaString a => URI -> a
displayUri = colour Yellow . fromString . show
showUri :: URI -> ClientM ()
showUri uri = do
ais <- gets clientActiveIdentities
liftIO . putStrLn $ showUriFull ansi ais Nothing uri
addToLog :: URI -> ClientM ()
addToLog uri = do
let t = T.pack $ show uri
modify $ \s -> s
{ clientLog = BStack.push maxLogLen t $ clientLog s
, clientVisited = S.insert (hash $ show uri) $ clientVisited s }
unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH
loggedUris = catMaybes $ (parseAbsoluteUri . T.unpack <$>) $ BStack.toList cLog
expand :: String -> String
expand = expandHelp ansi (fst <$> aliases) userDataDir
idsPath = userDataDir </> "identities"
savesDir = userDataDir </> "saves"
marksDir = userDataDir </> "marks"
setMark :: String -> URIWithIdName -> ClientM ()
setMark mark uriId = do
modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
unless (mark `elem` tempMarks) . liftIO .
handle printIOErr $ saveMark marksDir mark uriId
promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath
where inputHistPath = userDataDir </> "inputHistory"
handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()
handleCommandLine' mt mcas = void . runMaybeT $ do
ts <- case mt of
Nothing -> return []
Just pt -> either ((>> mzero) . printErr)
(\ts -> mapM_ addTargetId ts >> return ts) $
resolveTarget pt
case mcas of
Nothing -> lift $ handleBareTargets ts
Just (s,as) -> do
c' <- maybe (printErr (unknownCommand s) >> mzero)
return $ normaliseCommand s
lift $ handleCommand ts (c',as)
where
unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."
addTargetId :: Target -> MaybeT ClientM ()
addTargetId (TargetIdUri idName uri) =
liftIO (loadIdentity idsPath idName) >>= (\case
(Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero
(_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero
(Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)
addTargetId _ = return ()
resolveTarget :: PTarget -> Either String [Target]
resolveTarget PTargetCurr =
(:[]) . TargetHistory <$> maybeToEither "No current location" curr
resolveTarget PTargetJumpBack =
(:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack
resolveTarget (PTargetMark s)
| Just n <- readMay s =
(:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)
| otherwise =
(:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)
where
targetOfMark (URIWithIdName uri Nothing) = TargetUri uri
targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri
resolveTarget (PTargetLog specs) =
(TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs
resolveTarget (PTargetQueue specs) =
(queueTarget <$>) <$> resolveElemsSpecs "queue item" (matchPatternOn $ show . queueUri) queue specs
where
queueTarget (QueueItem Nothing uri) = TargetUri uri
queueTarget (QueueItem (Just o) uri) = TargetFrom o uri
resolveTarget (PTargetRoot base) =
(rootOf <$>) <$> resolveTarget base
where
rootOf :: Target -> Target
rootOf (TargetHistory item) = rootOfItem item
rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item
rootOf t = t
rootOfItem item = TargetHistory . lastDef item $ historyAncestors item
resolveTarget (PTargetAncestors base specs) =
concat <$> (mapM resolveAncestors =<< resolveTarget base)
where
resolveAncestors :: Target -> Either String [Target]
resolveAncestors (TargetHistory item) =
resolveAncestors' $ historyAncestors item
resolveAncestors (TargetFrom (HistoryOrigin item _) _) =
resolveAncestors' $ item : historyAncestors item
resolveAncestors _ = Left "No history"
resolveAncestors' hist = (TargetHistory <$>) <$>
resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)
hist specs
resolveTarget (PTargetDescendants base specs) =
concat <$> (mapM resolveDescendants =<< resolveTarget base)
where
resolveDescendants :: Target -> Either String [Target]
resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>
resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)
(historyDescendants item) specs
resolveDescendants _ = Left "No history"
resolveTarget (PTargetChild increasing noVisited base specs) =
concat <$> (mapM resolveChild =<< resolveTarget base)
where
resolveChild (TargetHistory item) =
let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
b = case historyChild item of
Just (HistoryChild _ (Just b')) -> b'
_ | increasing -> -1
_ -> length itemLinks
slice | increasing = zip [b+1..] $ drop (b+1) itemLinks
| otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks
linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item
slice' = applyIf noVisited (filter linkUnvisited) slice
in resolveLinkSpecs False item slice' specs
resolveChild _ = Left "No known links"
resolveTarget (PTargetLinks noVisited base specs) =
concat <$> (mapM resolveLinks =<< resolveTarget base)
where
resolveLinks (TargetHistory item) =
let itemLinks = extractLinksMimed $ historyGeminatedMimedData item
in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs
resolveLinks _ = Left "No known links"
resolveTarget (PTargetRef base s) =
let makeRel r | base == PTargetCurr = r
makeRel r@('/':_) = '.':r
makeRel r = r
in case parseUriReference . escapeQueryPart $ makeRel s of
Nothing -> Left $ "Failed to parse relative URI: " <> s
Just ref -> map relTarget <$> resolveTarget base
where
relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $
ref `relativeTo` historyUri item
relTarget t = TargetUri . relativeTo ref $ targetUri t
resolveTarget (PTargetAbs s) = case parseUriAsAbsolute $ escapeQueryPart s of
Nothing -> Left $ "Failed to parse URI: " <> s
Just uri -> return [TargetUri uri]
resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]
resolveLinkSpecs purgeVisited item slice specs =
let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||
matchPattern s (T.unpack $ linkDescription l)
linkTarg (n,l) =
let uri = linkUri l `relativeTo` historyUri item
in if purgeVisited && isVisited uri then Nothing
else Just $ TargetFrom (HistoryOrigin item $ Just n) uri
in resolveElemsSpecs "link" isMatch slice specs >>= (\case
[] -> Left "No such link"
targs -> return targs) . catMaybes . (linkTarg <$>)
matchPattern :: String -> String -> Bool
matchPattern patt =
let regex = mkRegexWithOpts patt True (any isUpper patt)
in isJust . matchRegex regex
matchPatternOn :: (a -> String) -> String -> a -> Bool
matchPatternOn f patt = matchPattern patt . f
doPage :: [T.Text] -> ClientM ()
doPage ls
| interactive = do
(height,width) <- liftIO getTermSize
let pageWidth = min maxWrapWidth (width - 4)
queued <- liftIO $ printLinesPaged pageWidth width (height - 2) ls
modify $ \s -> s { clientQueuedCommands = clientQueuedCommands s ++ queued }
| otherwise = liftIO $ mapM_ T.putStrLn ls
handleBareTargets :: [Target] -> ClientM ()
handleBareTargets [] = return ()
handleBareTargets (_:_:_) =
printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"
handleBareTargets [TargetHistory item] = goHistory item
handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri
handleBareTargets [t] = goUri False Nothing $ targetUri t
handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()
handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =
printErr "Command disabled in restricted mode"
handleCommand [] ("help", args) = case args of
[] -> doPage . map (T.pack . expand) $ helpText
CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s
handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText
where
commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++
["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)
showAlias (a, Alias s _) = "{" <> a <> "}: " <> s
handleCommand [] ("mark", []) =
let ms = M.toAscList marks
markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
in T.pack $ "'" <> m' <>
replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
showUriWithId uriId
in doPage $ markLine <$> ms
handleCommand [] ("inventory",_) = do
ais <- gets clientActiveIdentities
let showNumberedUri :: T.Text -> (Int,URI) -> T.Text
showNumberedUri s (n,uri) = s <> T.pack (show n) <> " " <> showUriFull ansi ais Nothing uri
showNumberedItem s (n,item) = showNumberedUri s (n, historyUri item)
showNumberedQueueItem s (n,q) = showNumberedUri s (n, queueUri q)
showJumpBack :: [T.Text]
showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
doPage . intercalate [""] . filter (not . null) $
[ showJumpBack
, showNumberedQueueItem "~" <$> zip [1..] queue
, showNumberedItem "'" <$> M.toAscList sessionMarks
, showNumberedItem "<" <$> zip [1..] (maybe [] historyAncestors curr)
, showNumberedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)
]
handleCommand [] ("log",_) =
let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t
in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)
handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do
c <- either ((>>mzero) . printErr) return $ parseCommand a
when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero
cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
modify $ \s ->
s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }
handleCommand [] ("alias", [CommandArg a _]) =
modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }
handleCommand [] ("set", []) = liftIO $ do
let (c,args) = defaultAction
putStrLn $ expand "{default_action}: " <> c <>
maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)
putStrLn $ expand "{proxies}:"
printMap showHost $ M.toAscList proxies
putStrLn $ expand "{geminators}:"
printMap id $ second snd <$> geminators
putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter
putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt
putStrLn $ expand "{log_length}: " <> show maxLogLen
putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
putStrLn $ expand "{no_confirm}: " <> show noConfirm
where
printMap :: (a -> String) -> [(String,a)] -> IO ()
printMap f as = mapM_ putStrLn $
(\(k,e) -> " " <> k <> " " <> f e) <$> as
handleCommand [] ("set", CommandArg opt _ : val)
| opt `isPrefixOf` "default_action" = case val of
(CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of
Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }
Nothing -> printErr "Invalid action"
_ -> printErr "Require value for option."
| opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of
(CommandArg scheme _ : val') ->
let f = maybe (M.delete scheme) (M.insert scheme) $
parseHost . commandArgLiteralTail =<< headMay val'
in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }
-- if only I'd allowed myself to use lenses, eh?
[] -> printErr "Require mimetype to set geminator for."
| opt `isPrefixOf` "geminators" = case val of
(CommandArg patt _ : val') ->
let f = maybe (filter $ (/= patt) . fst)
(\v -> (++ [(patt, (mkRegexWithOpts patt True True,
commandArgLiteralTail v))])) $
headMay val'
in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }
[] -> printErr "Require mimetype to set geminator for."
| opt `isPrefixOf` "render_filter" =
modifyCConf $ \c -> c { clientConfRenderFilter =
commandArgLiteralTail <$> headMay val }
| opt `isPrefixOf` "pre_display" = case val of
[CommandArg s _] | map toLower s `isPrefixOf` "both" ->
modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }
[CommandArg s _] | map toLower s `isPrefixOf` "pre" ->
modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }
[CommandArg s _] | map toLower s `isPrefixOf` "alt" ->
modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }
_ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"
| opt `isPrefixOf` "log_length" = case val of
[CommandArg s _] | Just n <- readMay s, n >= 0 -> do
modifyCConf $ \c -> c { clientConfMaxLogLen = n }
modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }
_ -> printErr "Require non-negative integer value for log_length"
| opt `isPrefixOf` "max_wrap_width" = case val of
[CommandArg s _] | Just n <- readMay s, n > 0 ->
modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }
_ -> printErr "Require positive integer value for max_wrap_width"
| opt `isPrefixOf` "no_confirm" = case val of
[CommandArg s _] | map toLower s `isPrefixOf` "true" ->
modifyCConf $ \c -> c { clientConfNoConfirm = True }
[CommandArg s _] | map toLower s `isPrefixOf` "false" ->
modifyCConf $ \c -> c { clientConfNoConfirm = False }
_ -> printErr "Require \"true\" or \"false\" as value for no_confirm"
| otherwise = printErr $ "No such option \"" <> opt <> "\"."
handleCommand [] cargs =
case curr of
Just item -> handleCommand [TargetHistory item] cargs
Nothing -> printErr "No current location. Enter an URI, or type \"help\"."
handleCommand ts ("add", args) =
enqueue (readMay . commandArgArg =<< headMay args) $ targetQueueItem <$> ts
handleCommand ts cargs =
mapM_ handleTargetCommand ts
where
handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =
action item
handleTargetCommand t | Just action <- actionOfCommand cargs =
let uri = targetUri t
in dropUriFromQueue uri >> doRequestUri uri action
handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =
goUri True (recreateOrigin <$> historyParent item) $ historyUri item
handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =
repl (recreateOrigin <$> historyParent item) $ historyUri item
handleTargetCommand (TargetHistory item) =
handleUriCommand (historyUri item) cargs
handleTargetCommand t =
handleUriCommand (targetUri t) cargs
recreateOrigin :: HistoryItem -> HistoryOrigin
recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent
handleUriCommand uri ("delete",_) = dropUriFromQueue uri
handleUriCommand uri ("repeat",_) = goUri True Nothing uri
handleUriCommand uri ("uri",_) = showUri uri
handleUriCommand uri ("mark", CommandArg mark _ : _)
| Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"
| otherwise = do
ais <- gets clientActiveIdentities
let mIdName = case findIdentity ais =<< requestOfUri uri of
Just ident | not $ isTemporary ident -> Just $ identityName ident
_ -> Nothing
setMark mark $ URIWithIdName uri mIdName
handleUriCommand uri ("identify", args) = case requestOfUri uri of
Nothing -> printErr "Bad URI"
Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case
Just (root,(ident,_)) -> endIdentityPrompted root ident
Nothing -> void . runMaybeT $ do
ident <- MaybeT . liftIO $ case args of
(CommandArg idName _ : _) -> getIdentity noConfirm ansi idsPath idName
[] -> getIdentityRequesting ansi idsPath
lift $ addIdentity req ident
handleUriCommand uri ("browse", args) = void . liftIO . runMaybeT $ do
cmd <- case args of
[] -> maybe notSet
(\s -> if null s then notSet else return $ parseBrowser s) =<<
lift (lookupEnv "BROWSER")
where
notSet = printErr "Please set $BROWSER or give a command to run" >> mzero
-- |based on specification for $BROWSER in 'man 1 man'
parseBrowser :: String -> String
parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')
(CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c
lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd [])
handleUriCommand uri ("repl",_) = repl Nothing uri
handleUriCommand uri ("log",_) = addToLog uri
handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c
repl :: Maybe HistoryOrigin -> URI -> ClientM ()
repl origin uri = repl' where
repl' = liftIO (promptInput ">> ") >>= \case
Nothing -> return ()
Just "" -> return ()
Just query -> do
goUri True origin . setQuery ('?':escapeQuery query) $ uri
repl'
actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction
actionOnRendered ansi' m item = do
ais <- gets clientActiveIdentities
liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=
either printErr m
actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction
actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing
actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn
actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage
actionOfCommand ("links",_) = Just $ \item -> do
ais <- gets clientActiveIdentities
let cl = childLink =<< historyChild item
linkLine n link =
applyIf (cl == Just (n-1)) (bold "* " <>) $
printGemLinkLine ansi (showUriRefFull ansi ais $ historyUri item) n link
doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item
actionOfCommand ("mark", CommandArg mark _ : _) |
Just n <- readMay mark :: Maybe Int = Just $ \item ->
modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData
actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])
actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do
createDirectoryIfMissing True savesDir
homePath <- getHomeDirectory
let path' = if take 2 path == "~/"
then homePath </> drop 2 path
else savesDir </> path
body = mimedBody $ historyMimedData item
name = fromMaybe "" . lastMay . pathSegments $ historyUri item
handle printIOErr . void . runMaybeT $ do
lift $ mkdirhierto path'
isDir <- lift $ doesDirectoryExist path'
let fullpath = if isDir then path' </> name else path'
lift (doesDirectoryExist fullpath) >>? do
lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"
mzero
lift (doesFileExist fullpath) >>?
guard . not =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")
lift $ do
putStrLn $ "Saving to " ++ fullpath
t0 <- timeCurrentP
BL.writeFile fullpath =<< interleaveProgress t0 body
actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted .
shellOnData noConfirm cmd userDataDir (historyEnv item) . mimedBody $ historyMimedData item
actionOfCommand ("view",_) = Just $ \item ->
let mimed = historyMimedData item
mimetype = showMimeType mimed
body = mimedBody mimed
in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body
actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted $
pipeToShellLazily cmd (historyEnv item) . mimedBody $ historyMimedData item
actionOfCommand ("||", args) = Just $ pipeRendered ansi args
actionOfCommand ("||-", args) = Just $ pipeRendered False args
actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData
actionOfCommand ("at", CommandArg _ str : _) = Just $ \item -> void . runMaybeT $ do
cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
lift $ handleCommandLine cOpts (cState { clientCurrent = Just item }) cl
actionOfCommand _ = Nothing
pipeRendered :: Bool -> [CommandArg] -> CommandAction
pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls ->
liftIO . void . runMaybeT $ do
cmd <- case args of
[] -> maybe notSet
(\s -> if null s then notSet else return s) =<<
liftIO (lookupEnv "PAGER")
where
notSet = printErr "Please set $PAGER or give a command to run" >> mzero
(CommandArg _ cmd : _) -> return cmd
lift . doRestricted . pipeToShellLazily cmd (historyEnv item) . T.encodeUtf8 $ T.unlines ls
setCurr :: HistoryItem -> ClientM ()
setCurr i =
let isJump = isNothing $ curr >>= pathItemByUri i . historyUri
in do
when isJump $ modify $ \s -> s { clientJumpBack = curr }
modify $ \s -> s { clientCurrent = Just i }
goHistory :: HistoryItem -> ClientM ()
goHistory i = setCurr i >> showUri (historyUri i)
goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
goUri forceRequest origin uri = dropUriFromQueue uri >> case curr >>= flip pathItemByUri uri of
Just i' | not forceRequest -> goHistory i'
_ -> doRequestUri uri $ \item -> do
maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
liftIO . slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item
let updateParent i =
-- Lazily recursively update the links in the doubly linked list
let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }
in i'
updateChild i' i = i { historyChild = setChild <$> historyChild i }
where setChild c = c { childItem = i' }
glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }
item' = item { historyParent = glueOrigin <$> origin }
setCurr item'
doRequestUri :: URI -> CommandAction -> ClientM ()
doRequestUri uri0 action = doRequestUri' 0 uri0
where
doRequestUri' redirs uri
| Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req
| otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (
let scheme = uriScheme uri
in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)
then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"
else "")
doRequest :: Int -> Request -> ClientM ()
doRequest redirs _ | redirs > 5 =
printErr "Too many redirections!"
doRequest redirs req@(NetworkRequest _ uri) = do
(mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities
modify $ \s -> s { clientActiveIdentities = ais }
printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri
let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream
liftIO (makeRequest requestContext mId respBuffSize req)
`bracket` either (\_ -> return ()) (liftIO . snd) $
either
(printErr . displayException)
(handleResponse . fst)
where
handleResponse :: Response -> ClientM ()
handleResponse (Input isPass prompt) = do
let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"
prompter = if isPass then promptPassword else promptInput
(liftIO . prompter $ (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case
Nothing -> return ()
Just query -> doRequestUri' redirs . setQuery ('?':escapeQuery query) $ uri
handleResponse (Success mimedData) = doAction req mimedData
handleResponse (Redirect isPerm to) = do
let uri' = to `relativeTo` uri
crossSite = uriRegName uri' /= uriRegName uri
crossScheme = uriScheme uri' /= uriScheme uri
warningStr = colour BoldRed
ais <- gets clientActiveIdentities
proceed <- (isJust <$>) . lift . runMaybeT $ do
when crossSite . guard <=< (liftIO . promptYN False) $
warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
when crossScheme . guard <=< (liftIO . promptYN False) $
warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
when proceed $ do
when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks
doRequestUri' (redirs + 1) uri'
where updateMark uri' (mark,uriId) = do
conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"
when conf . setMark mark $ uriId { uriIdUri = uri' }
handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do
identity <- do
liftIO . putStrLn $ (case code of
60 -> "Server requests identification"
_ -> "Server rejects provided identification certificate" ++
(if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))
++ if null info then "" else ": " ++ info
MaybeT . liftIO $ getIdentityRequesting ansi idsPath
lift $ do
addIdentity req identity
doRequest redirs req
handleResponse (Failure code info) =
printErr $ "Server returns failure: " ++ show code ++ " " ++ info
handleResponse (MalformedResponse malformation) =
printErr $ "Malformed response from server: " ++ show malformation
doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."
| otherwise = void . runMaybeT $ do
(path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do
let detectExtension = case takeExtension path of
-- |certain crucial filetypes we can't rely on magic to detect:
s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"
".md" -> Just "text/markdown"
".html" -> Just "text/html"
_ -> Nothing
#ifdef MAGIC
detectPlain "text/plain" = fromMaybe "text/plain" detectExtension
detectPlain s = s
magic <- Magic.magicOpen [Magic.MagicMimeType]
Magic.magicLoadDefault magic
s <- detectPlain <$> Magic.magicFile magic path
#else
let s = if "/" `isSuffixOf` path then "inode/directory"
else fromMaybe "application/octet-stream" detectExtension
#endif
case MIME.parseMIMEType $ TS.pack s of
Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing
_ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .
T.encodeUtf8 . T.unlines . ((("=> " <>) . T.pack . escapePathString) <$>) <$>
getDirectoryContents path
where slashedPath | "/" `isSuffixOf` path = path
| otherwise = path <> "/"
Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path
lift $ doAction (LocalFileRequest path') mimedData
doAction req mimedData = do
t0 <- liftIO timeCurrentP
geminated <- geminate mimedData
action $ HistoryItem req t0 mimedData geminated Nothing Nothing
where
-- |returns MimedData with lazy IO
geminate :: MimedData -> ClientM MimedData
geminate mimed =
let geminator = lookupGeminator $ showMimeType mimed
in liftIO . unsafeInterleaveIO $ applyGeminator geminator
where
lookupGeminator mimetype =
listToMaybe [ gem | (_, (regex, gem)) <- geminators
, isJust $ matchRegex regex mimetype ]
applyGeminator Nothing = return mimed
applyGeminator (Just cmd) =
printInfo ("| " <> cmd) >>
MimedData gemTextMimeType <$>
doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)
gemTextMimeType :: MIME.Type
gemTextMimeType = MIME.Type (MIME.Text "gemini") []
addIdentity :: Request -> Identity -> ClientM ()
addIdentity req identity = do
ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity
modify $ \s -> s {clientActiveIdentities = ais}
endIdentityPrompted :: Request -> Identity -> ClientM ()
endIdentityPrompted root ident = do
conf <- confirm $ liftIO . promptYN False $ "Stop using " ++
(if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) ++
" at " ++ displayUri (requestUri root) ++ "?"
when conf . modify $ \s ->
s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }
extractLinksMimed :: MimedData -> [Link]
extractLinksMimed (MimedData (MIME.Type (MIME.Text "gemini") _) body) =
extractLinks . parseGemini $ T.decodeUtf8With T.lenientDecode body
extractLinksMimed _ = []
renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])
renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of
MIME.Text textType -> do
let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v
extractCharsetParam _ = Nothing
charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime
isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]
#ifdef ICONV
reencoder = if isUtf8 then id else
convert charset "UTF-8"
#else
reencoder = id
unless isUtf8 . printErr $
"Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"
#endif
(_,width) <- getTermSize
let pageWidth = if interactive
then min maxWrapWidth (width - 4)
else maxWrapWidth
let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body
applyFilter :: [T.Text] -> IO [T.Text]
applyFilter = case renderFilter of
Nothing -> return
Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .
doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)
where appendNewline = (`BL.snoc` 10)
(Right <$>) . applyFilter . (sanitiseNonCSI <$>) $ case textType of
"gemini" ->
let opts = GemRenderOpts ansi' preOpt pageWidth
in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
_ -> T.stripEnd <$> T.lines bodyText
mimeType ->
return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"