diohsc-0.1.14: LineClient.hs
-- This file is part of Diohsc
-- Copyright (C) 2020-23 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 LineClient (lineClient) where
import qualified Codec.MIME.Parse as MIME
import qualified Codec.MIME.Type as MIME
import Control.Applicative (Alternative, empty)
import Control.Monad.Catch
import Control.Monad.State
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.Bifunctor (second)
import qualified Data.ByteString.Lazy as BL
import Data.Char (toLower)
import Data.Hash (hash)
import Data.IORef (modifyIORef, newIORef, readIORef)
import Data.List (intercalate, isPrefixOf,
isSuffixOf, sort, stripPrefix)
import qualified Data.Map as M
import Data.Maybe
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 Safe
import qualified System.Console.Haskeline as HL
import qualified System.Console.Terminal.Size as Size
import System.Directory
import System.Environment
import System.FilePath
import System.IO.Unsafe (unsafeInterleaveIO)
import Text.Regex (matchRegex, mkRegexWithOpts)
import Time.System (timeCurrentP)
import ActiveIdentities
import Alias
import ANSIColour
import qualified BStack
import ClientCert (KeyType (..))
import ClientOptions
import ClientState
import Command
import CommandLine
import GeminiProtocol
import History
import Identity
import Marks
import MetaString
import Mundanities
import Pager
import PrintFancy
import Prompt hiding (promptYN)
import qualified Prompt
import Queue
import Request
import ResolveTarget
import qualified RunExternal
import RunExternal hiding (runRestrictedIO)
import Slurp
import Target
import TextGemini
import URI
import Util
#ifdef ICONV
import Codec.Text.IConv (convert)
#endif
#ifdef MAGIC
import qualified Magic
#endif
getTermSize :: IO (Int,Int)
getTermSize = do
Size.Window height width <- fromMaybe (Size.Window (2^(30::Int)) 80) <$> Size.size
return (height,width)
lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM ()
lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir
, cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do
(liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)
lift addToQueuesFromFiles
mapM_ handleLine' initialCommands
when repl lineClient'
unless ghost $ lift appendQueuesToFiles
where
handleLine' :: String -> HL.InputT ClientM Bool
handleLine' line = lift get >>= \s -> handleLine cOpts s line
lineClient' :: HL.InputT ClientM ()
lineClient' = do
cmd <- lift getPrompt >>= promptLineInputT
quit <- case cmd of
Nothing -> if interactive
then printErrFancy ansi "Use \"quit\" to quit" >> return False
else return True
Just Nothing -> return True
Just (Just line) -> handleLine' line
lift addToQueuesFromFiles
unless quit lineClient'
addToQueuesFromFiles :: ClientM ()
addToQueuesFromFiles | ghost = return ()
| otherwise = do
qfs <- ignoreIOErr $ liftIO findQueueFiles
forM_ qfs $ \(qfile, qname) ->
modifyQueues . enqueue (QueueSpec qname Nothing) <=<
ignoreIOErr . liftIO $
mapMaybe queueLine <$> readFileLines qfile <* removeFile qfile
ignoreIOErr . liftIO $ removeDirectory queuesDir
where
findQueueFiles :: IO [(FilePath,String)]
findQueueFiles = do
qf <- (\e -> [(queueFile, "") | e]) <$> doesFileExist queueFile
qfs <- ((\qn -> (queuesDir </> qn, qn)) <$>) <$> listDirectory queuesDir
return $ qf <> qfs
queueLine :: T.Text -> Maybe QueueItem
queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s)
appendQueuesToFiles :: ClientM ()
appendQueuesToFiles = do
queues <- gets $ M.toList . clientQueues
liftIO $ createDirectoryIfMissing True queuesDir
liftIO $ forM_ queues appendQueue
where
appendQueue (_, []) = pure ()
appendQueue (qname, queue) =
let qfile = case qname of
"" -> queueFile
s -> queuesDir </> s
in warnIOErr $ BL.appendFile qfile .
T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue
queueFile, queuesDir :: FilePath
queueFile = userDataDir </> "queue"
queuesDir = userDataDir </> "queues"
getPrompt :: ClientM String
getPrompt = do
queue <- gets $ M.findWithDefault [] "" . clientQueues
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 =
((applyIf ansi withReverseStr $ colour BoldCyan "%%%") ++)
. (" " ++) . (++ bold "> ") . unwords $ catMaybes
[ queueStatus
, uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus)
. historyUri <$> curr
]
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 -> printErrFancy ansi err >> return False
Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True
Right cline -> handleCommandLine cOpts s False cline >> return False
where
catchInterrupts = HL.handleInterrupt (printErrFancy ansi "Interrupted." >> return False) . HL.withInterrupt . lift
backupHandler :: SomeException -> HL.InputT ClientM Bool
backupHandler = (>> return False) . printErrFancy ansi . ("Unhandled exception: " <>) . show
handleCommandLine :: ClientOptions -> ClientState -> Bool -> CommandLine -> ClientM ()
handleCommandLine
cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)
cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases
(ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection))
blockGo
= \(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
printErr, printInfo :: MonadIO m => String -> m ()
printErr = printErrFancy ansi
printInfo = printInfoFancy 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
inHistory = isJust $ curr >>= flip pathItemByUri uri
activeId = isJust $ idAtUri ais uri
col = if inHistory && not activeId then BoldBlue else 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
preprocessQuery :: String -> ClientM String
preprocessQuery = (escapeQuery <$>) . liftIO . maybeEdit
where
maybeEdit :: String -> IO String
maybeEdit s | lastMay s == Just '\\' =
handle (\e -> printIOErr e >> pure s)
. doRestrictedFilter (editInteractively ansi userDataDir)
$ init s
maybeEdit s = pure s
expand :: String -> String
expand = expandHelp ansi (fst <$> aliases) userDataDir
idsPath = userDataDir </> "identities"
savesDir = userDataDir </> "saves"
marksDir = userDataDir </> "marks"
historyEnv :: HistoryItem -> ClientM [(String,String)]
historyEnv item = gets clientActiveIdentities >>= \ais -> pure $
[ ("URI", show $ historyUri item)
, ("MIMETYPE", showMimeType $ historyMimedData item) ] <>
(maybe [] (identityEnvironment idsPath) . idAtUri ais $ historyUri item)
setMark :: String -> URIWithIdName -> ClientM ()
setMark mark uriId | markNameValid mark = do
modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
unless (mark `elem` tempMarks) . liftIO .
handle printIOErr $ saveMark marksDir mark uriId
setMark mark _ = printErr $ "Invalid mark name " ++ mark
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 cState 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 ()
doPage :: [T.Text] -> ClientM ()
doPage ls
| interactive = do
(height,width) <- liftIO getTermSize
let pageWidth = min maxWrapWidth (width - 4)
perPage = height - min 3 (height `div` 4)
doCmd str = get >>= \s -> doSubCommand s True str
printLinesPaged pageWidth width perPage doCmd ls
| 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 :: Bool -> T.Text -> (Int,URI) -> T.Text
showNumberedUri iter s (n,uri) = s <>
(if iter && n == 1 then " "
else if iter && n == 2 then T.takeEnd 1 s
else T.pack (show n)) <>
" " <> showUriFull ansi ais Nothing uri
showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)
showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)
showIteratedQueueItem s (n, QueueURI _ uri) =
showNumberedUri True s (n, uri)
showIteratedQueueItem s (n, QueueHistory item) =
showNumberedUri True s (n, historyUri item) <> " {fetched}"
showJumpBack :: [T.Text]
showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
doPage . intercalate [""] . filter (not . null) $
showJumpBack :
[ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue
| (qname, queue) <- M.toList queues ]
++ [ showNumberedItem "'" <$> M.toAscList sessionMarks
, (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))
++ (("@ " <>) . showUriFull ansi ais Nothing . historyUri <$>
maybeToList (curr >>= lastMay . historyAncestors))
, showIteratedItem ">" <$> 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 "{link_desc_first}: " <> show linkDescFirst
putStrLn $ expand "{log_length}: " <> show maxLogLen
putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
putStrLn $ expand "{no_confirm}: " <> show noConfirm
putStrLn $ expand "{verbose_connection}: " <> show verboseConnection
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` "link_desc_first" = case val of
[CommandArg s _] | map toLower s `isPrefixOf` "true" ->
modifyCConf $ \c -> c { clientConfLinkDescFirst = True }
[CommandArg s _] | map toLower s `isPrefixOf` "false" ->
modifyCConf $ \c -> c { clientConfLinkDescFirst = False }
_ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"
| 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"
| opt `isPrefixOf` "verbose_connection" = case val of
[CommandArg s _] | map toLower s `isPrefixOf` "true" ->
modifyCConf $ \c -> c { clientConfVerboseConnection = True }
[CommandArg s _] | map toLower s `isPrefixOf` "false" ->
modifyCConf $ \c -> c { clientConfVerboseConnection = False }
_ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"
| 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) = case parseQueueSpec $ commandArgArg <$> args of
Nothing -> printErr "Bad arguments to 'add'."
Just qs -> modifyQueues . enqueue qs $ targetQueueItem <$> ts
handleCommand ts ("fetch", args) = case parseQueueSpec $ commandArgArg <$> args of
Nothing -> printErr "Bad arguments to 'fetch."
Just qs -> do
-- XXX: we have to use an IORef to store the items, since
-- CommandAction doesn't allow a return value.
lRef <- liftIO $ newIORef []
let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)
forM_ ts $ \t -> case t of
TargetHistory item -> add item
_ -> modifyQueues (unqueue uri) >> doRequestUri uri add
where uri = targetUri t
l <- liftIO $ reverse <$> readIORef lRef
modifyQueues . enqueue qs $ QueueHistory <$> l
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 modifyQueues (unqueue 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 t | ("query", CommandArg _ str : _) <- cargs = do
let origin = case t of
TargetHistory item -> Just $ HistoryOrigin item Nothing
TargetFrom o _ -> Just o
_ -> Nothing
str' <- preprocessQuery str
goUri True origin . setQuery ('?':str') $ targetUri t
handleTargetCommand t =
handleUriCommand (targetUri t) cargs
recreateOrigin :: HistoryItem -> HistoryOrigin
recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent
handleUriCommand uri ("delete",[]) =
modifyQueues $ unqueueFrom "" uri
handleUriCommand uri ("delete",CommandArg qname _ : _) =
modifyQueues $ unqueueFrom qname 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,_)) | null args -> endIdentityPrompted root ident
_ -> void . runMaybeT $ do
ident <- MaybeT . liftIO $ case args of
CommandArg idName _ : args' ->
let tp = case args' of
CommandArg ('e':'d':_) _ : _ -> KeyEd25519
_ -> KeyRSA
in getIdentity interactive ansi idsPath tp idName
[] -> if interactive
then getIdentityRequesting ansi idsPath
else getIdentity interactive ansi idsPath KeyRSA ""
lift $ addIdentity req ident
handleUriCommand uri ("browse", args) = do
ais <- gets clientActiveIdentities
let envir = maybe [] (identityEnvironment idsPath) .
idAtUri ais . setSchemeDefault $ uri
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 envir)
handleUriCommand uri ("repl",_) = repl Nothing uri
handleUriCommand uri ("log",_) = addToLog uri >> modifyQueues (unqueue uri)
handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c
repl :: Maybe HistoryOrigin -> URI -> ClientM ()
repl origin uri = repl' where
repl' = liftIO (join <$> promptInput ">> ") >>= \case
Nothing -> return ()
Just query -> do
query' <- preprocessQuery query
goUri True origin . setQuery ('?':query') $ uri
repl'
slurpItem :: HistoryItem -> IO ()
slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item
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 uri desc) =
applyIf (cl == Just (n-1)) (bold "* " <>) $
T.pack ('[' : show n ++ "] ")
<> showUriRefFull ansi ais (historyUri item) uri
<> if T.null desc then "" else " " <>
applyIf ansi (withColourStr Cyan) desc
doPage . zipWith linkLine [1..] . historyLinks $ item
actionOfCommand ("mark", CommandArg mark _ : _) |
Just n <- readMay mark :: Maybe Int = Just $ \item -> do
liftIO $ slurpItem 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'
| take 2 path == "~/" = homePath </> drop 2 path
| take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path
| otherwise = savesDir </> path
body = mimedBody $ historyMimedData item
uri = historyUri item
name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .
filter (not . null) $ pathSegments uri
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 =<< 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 -> do
env <- historyEnv item
liftIO . handle printIOErr . doRestricted .
shellOnData noConfirm cmd userDataDir env . 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 -> do
env <- historyEnv item
liftIO . handle printIOErr . doRestricted $
pipeToShellLazily cmd env . 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 ->
doSubCommand (cState { clientCurrent = Just item }) blockGo str
actionOfCommand _ = Nothing
pipeRendered :: Bool -> [CommandArg] -> CommandAction
pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> do
env <- historyEnv item
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 env . T.encodeUtf8 $ T.unlines ls
doSubCommand :: ClientState -> Bool -> String -> ClientM ()
doSubCommand s block str = void . runMaybeT $ do
cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
lift $ handleCommandLine cOpts s block cl
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 }
doDefault :: HistoryItem -> ClientM ()
doDefault item =
maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
goHistory :: HistoryItem -> ClientM ()
goHistory _ | blockGo = printErr "Can't go anywhere now."
goHistory item = do
modifyQueues $ unqueue uri
showUri uri
setCurr item
doDefault item
where uri = historyUri item
goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
goUri _ _ _ | blockGo = printErr "Can't go anywhere now."
goUri forceRequest origin uri = do
modifyQueues $ unqueue uri
activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities
case curr >>= flip pathItemByUri uri of
Just i' | not (activeId || forceRequest) -> goHistory i'
_ -> doRequestUri uri $ \item -> do
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'
doDefault item
liftIO $ slurpItem 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 verboseConnection 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") ++ "]"
(liftIO . (join <$>) . promptInput $
(if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case
Nothing -> return ()
Just query -> do
query' <- preprocessQuery query
doRequestUri' redirs . setQuery ('?':query') $ uri
handleResponse (Success mimedData) = doAction req mimedData
handleResponse (Redirect isPerm to) = do
ais <- gets clientActiveIdentities
let uri' = to `relativeTo` uri
crossSite = uriRegName uri' /= uriRegName uri
crossScheme = uriScheme uri' /= uriScheme uri
crossScope = case idAtUri ais <$> [uri,uri'] of
[fromId,toId] -> isJust toId && fromId /= toId
_ -> False
warningStr = colour BoldRed
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 crossScope $ guard <=< (liftIO . promptYN False) $
warningStr "Follow redirect with identity " ++ 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
guard interactive
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) <$>) . sort <$>
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 }
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 $ case textType of
"gemini" ->
let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst
in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
_ -> T.stripEnd . stripControl <$> T.lines bodyText
mimeType ->
return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"