LineClient.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020-23 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE CPP               #-}
  12 {-# LANGUAGE FlexibleContexts  #-}
  13 {-# LANGUAGE LambdaCase        #-}
  14 {-# LANGUAGE OverloadedStrings #-}
  15 {-# LANGUAGE TupleSections     #-}
  16
  17 module LineClient (lineClient) where
  18
  19 import           Control.Applicative          (Alternative, empty)
  20 import           Control.Monad.Catch
  21 import           Control.Monad.State
  22 import           Control.Monad.Trans.Maybe    (MaybeT (..), runMaybeT)
  23 import           Data.Bifunctor               (second)
  24 import           Data.Char                    (isAlpha, toLower)
  25 import           Data.Hash                    (hash)
  26 import           Data.IORef                   (modifyIORef, newIORef, readIORef)
  27 import           Data.List                    (intercalate, isPrefixOf,
  28                                                isSuffixOf, sort, stripPrefix)
  29 import           Data.Maybe
  30 import           Safe
  31 import           System.Directory
  32 import           System.Environment
  33 import           System.Exit
  34 import           System.FilePath
  35 import           System.IO
  36 import           System.IO.Unsafe             (unsafeInterleaveIO)
  37 import           Text.Regex                   (matchRegex, mkRegexWithOpts)
  38 import           Time.System                  (timeCurrentP)
  39
  40 import qualified Data.ByteString.Lazy         as BL
  41
  42 import qualified Codec.MIME.Parse             as MIME
  43 import qualified Codec.MIME.Type              as MIME
  44 import qualified Data.Map                     as M
  45 import qualified Data.Set                     as S
  46 import qualified Data.Text                    as TS
  47 import qualified Data.Text.Encoding.Error     as T
  48 import qualified Data.Text.Lazy               as T
  49 import qualified Data.Text.Lazy.Encoding      as T
  50 import qualified Data.Text.Lazy.IO            as T
  51 import qualified System.Console.Haskeline     as HL
  52 import qualified System.Console.Terminal.Size as Size
  53
  54 import           ActiveIdentities
  55 import           Alias
  56 import           ANSIColour
  57 import qualified BStack
  58 import           ClientCert                   (KeyType (..))
  59 import           ClientOptions
  60 import           ClientState
  61 import           Command
  62 import           CommandLine
  63 import           GeminiProtocol
  64 import           History
  65 import           Identity
  66 import           Marks
  67 import           MetaString
  68 import           Mundanities
  69 import           Opts
  70 import           Pager
  71 import           PrintFancy
  72 import           Prompt                       hiding (promptYN)
  73 import qualified Prompt
  74 import           Queue
  75 import           Request
  76 import           ResolveTarget
  77 import qualified RunExternal
  78 import           RunExternal                  hiding (runRestrictedIO)
  79 import           Slurp
  80 import           Target
  81 import           TextGemini
  82 import           URI
  83 import           Util
  84 import           Version
  85
  86 #ifndef WINDOWS
  87 import           System.Posix.Files           (ownerModes, setFileMode)
  88 #endif
  89
  90 #ifdef ICONV
  91 import           Codec.Text.IConv             (convert)
  92 #endif
  93
  94 #ifdef MAGIC
  95 import qualified Magic
  96 #endif
  97
  98 getTermSize :: IO (Int,Int)
  99 getTermSize = do
 100     Size.Window height width <- fromMaybe (Size.Window (2^(30::Int)) 80) <$> Size.size
 101     return (height,width)
 102
 103 lineClient :: ClientOptions -> [String] -> Bool -> HL.InputT ClientM ()
 104 lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir
 105         , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands repl = do
 106     (liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)
 107     lift addToQueuesFromFiles
 108     mapM_ handleLine' initialCommands
 109     when repl lineClient'
 110     unless ghost $ lift appendQueuesToFiles
 111     where
 112     handleLine' :: String -> HL.InputT ClientM Bool
 113     handleLine' line = lift get >>= \s -> handleLine cOpts s line
 114
 115     lineClient' :: HL.InputT ClientM ()
 116     lineClient' = do
 117         cmd <- lift getPrompt >>= promptLineInputT
 118         quit <- case cmd of
 119             Nothing -> if interactive
 120                 then printErrFancy ansi "Use \"quit\" to quit" >> return False
 121                 else return True
 122             Just Nothing -> return True
 123             Just (Just line) -> handleLine' line
 124         lift addToQueuesFromFiles
 125         unless quit lineClient'
 126
 127     addToQueuesFromFiles :: ClientM ()
 128     addToQueuesFromFiles | ghost = return ()
 129         | otherwise = do
 130             qfs <- ignoreIOErr $ liftIO findQueueFiles
 131             forM_ qfs $ \(qfile, qname) ->
 132                 modifyQueues . enqueue (QueueSpec qname Nothing) <=<
 133                     ignoreIOErr . liftIO $
 134                     mapMaybe queueLine <$> readFileLines qfile <* removeFile qfile
 135             ignoreIOErr . liftIO $ removeDirectory queuesDir
 136         where
 137         findQueueFiles :: IO [(FilePath,String)]
 138         findQueueFiles = do
 139             qf <- (\e -> [(queueFile, "") | e]) <$> doesFileExist queueFile
 140             qfs <- ((\qn -> (queuesDir </> qn, qn)) <$>) <$> listDirectory queuesDir
 141             return $ qf <> qfs
 142         queueLine :: T.Text -> Maybe QueueItem
 143         queueLine s = QueueURI Nothing <$> (parseUriAsAbsolute . escapeIRI $ T.unpack s)
 144
 145     appendQueuesToFiles :: ClientM ()
 146     appendQueuesToFiles = do
 147         queues <- gets $ M.toList . clientQueues
 148         liftIO $ createDirectoryIfMissing True queuesDir
 149         liftIO $ forM_ queues appendQueue
 150         where
 151         appendQueue (_, []) = pure ()
 152         appendQueue (qname, queue) =
 153             let qfile = case qname of
 154                     "" -> queueFile
 155                     s  -> queuesDir </> s
 156             in warnIOErr $ BL.appendFile qfile .
 157                 T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue
 158
 159     queueFile, queuesDir :: FilePath
 160     queueFile = userDataDir </> "queue"
 161     queuesDir = userDataDir </> "queues"
 162
 163     getPrompt :: ClientM String
 164     getPrompt = do
 165         queue <- gets $ M.findWithDefault [] "" . clientQueues
 166         curr <- gets clientCurrent
 167         proxies <- gets $ clientConfProxies . clientConfig
 168         ais <- gets clientActiveIdentities
 169         let queueStatus :: Maybe String
 170             queueStatus = guard (not $ null queue) >> return (show (length queue) ++ "~")
 171             colour = applyIf ansi . withColourStr
 172             bold = applyIf ansi withBoldStr
 173             uriStatus :: Int -> URI -> String
 174             uriStatus w uri =
 175                 let fullUriStr = stripGem $ show uri
 176                     stripGem s = fromMaybe s $ stripPrefix "gemini://" s
 177                     mIdName = (identityName <$>) $ findIdentity ais =<< requestOfProxiesAndUri proxies uri
 178                     idStr = flip (maybe "") mIdName $ \idName ->
 179                         let abbrId = length idName > 8 && length fullUriStr + 2 + length idName > w - 2
 180                         in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]"
 181                     abbrUri = length fullUriStr + length idStr > w - 2
 182                     uriFormat = colour BoldMagenta
 183                     uriStr = if abbrUri
 184                         then
 185                             let abbrUriChars = w - 4 - length idStr
 186                                 preChars = abbrUriChars `div` 2
 187                                 postChars = abbrUriChars - preChars
 188                             in uriFormat (take preChars fullUriStr) <>
 189                             ".." <>
 190                             uriFormat (drop (length fullUriStr - postChars) fullUriStr)
 191                         else uriFormat fullUriStr
 192                 in uriStr ++
 193                     (if null idStr then "" else colour Green idStr)
 194             prompt :: Int -> String
 195             prompt maxPromptWidth =
 196                 ((applyIf ansi withReverseStr $ colour BoldCyan "%%%") ++)
 197                     . (" " ++) . (++ bold "> ") . unwords $ catMaybes
 198                     [ queueStatus
 199                     , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus)
 200                         . historyUri <$> curr
 201                     ]
 202         prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize
 203
 204 handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool
 205 handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of
 206     Left err -> printErrFancy ansi err >> return False
 207     Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True
 208     Right cline -> handleCommandLine cOpts s False cline >> return False
 209     where
 210     catchInterrupts = HL.handleInterrupt (printErrFancy ansi "Interrupted." >> return False) . HL.withInterrupt . lift
 211     backupHandler :: SomeException -> HL.InputT ClientM Bool
 212     backupHandler = (>> return False) . printErrFancy ansi . ("Unhandled exception: " <>) . show
 213
 214 handleCommandLine :: ClientOptions -> ClientState -> Bool -> CommandLine -> ClientM ()
 215 handleCommandLine
 216         cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)
 217         cState@(ClientState curr jumpBack cLog visited queues _ marks sessionMarks aliases
 218             (ClientConfig defaultAction proxies geminators renderFilter preOpt linkDescFirst maxLogLen maxWrapWidth confNoConfirm verboseConnection))
 219         blockGo
 220     = \(CommandLine mt mcas) -> case mcas of
 221         Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->
 222             let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args
 223                 appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)
 224                     where
 225                     appendTail arg@(CommandArg a' t') = case args of
 226                         []                   -> arg
 227                         (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t
 228             in handleCommandLine' (mt' `mplus` mt) $
 229                 (appendCArgs <$> mcas') `mplus` mcas''
 230         _ -> handleCommandLine' mt mcas
 231
 232     where
 233
 234     -- Remark: we handle haskell's "configurations problem" by having the below all within the scope
 235     -- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of
 236     -- simulating global variables or threading a Reader monad throughout. The downside is that this
 237     -- module can't be split as much as it ought to be.
 238     -- Similar remarks go for `GeminiProtocol.makeRequest`.
 239
 240     onRestriction :: IO ()
 241     onRestriction = printErr "This is not allowed in restricted mode."
 242
 243     doRestricted :: Monoid a => RestrictedIO a -> IO a
 244     doRestricted m | restrictedMode = onRestriction >> return mempty
 245         | otherwise = RunExternal.runRestrictedIO m
 246
 247     doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)
 248     doRestrictedAlt m | restrictedMode = onRestriction >> return empty
 249         | otherwise = RunExternal.runRestrictedIO m
 250
 251     doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)
 252     doRestrictedFilter f | restrictedMode = \a -> do
 253             onRestriction
 254             return a
 255         | otherwise = RunExternal.runRestrictedIO . f
 256
 257     printErr, printInfo :: MonadIO m => String -> m ()
 258     printErr = printErrFancy ansi
 259     printInfo = printInfoFancy ansi
 260
 261     printIOErr :: IOError -> IO ()
 262     printIOErr = printErr . show
 263
 264     noConfirm :: Bool
 265     noConfirm = confNoConfirm || not interactive
 266
 267     confirm :: Applicative m => m Bool -> m Bool
 268     confirm | noConfirm = const $ pure True
 269         | otherwise = id
 270
 271     promptYN = Prompt.promptYN interactive
 272
 273     colour :: MetaString a => Colour -> a -> a
 274     colour = applyIf ansi . withColourStr
 275     bold :: MetaString a => a -> a
 276     bold = applyIf ansi withBoldStr
 277
 278     isVisited :: URI -> Bool
 279     isVisited uri = S.member (hash $ show uri) visited
 280
 281     requestOfUri = requestOfProxiesAndUri proxies
 282
 283     idAtUri :: ActiveIdentities -> URI -> Maybe Identity
 284     idAtUri ais uri = findIdentity ais =<< requestOfUri uri
 285
 286     showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a
 287     showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base
 288
 289     showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a
 290     showUriFull ansi' ais base uri =
 291         let scheme = uriScheme uri
 292             handled = scheme `elem` ["gemini","file"] || M.member scheme proxies
 293             inHistory = isJust $ curr >>= flip pathItemByUri uri
 294             activeId = isJust $ idAtUri ais uri
 295             col = if inHistory && not activeId then BoldBlue else case (isVisited uri,handled) of
 296                 (True,True)   -> Yellow
 297                 (False,True)  -> BoldYellow
 298                 (True,False)  -> Red
 299                 (False,False) -> BoldRed
 300             s = case base of
 301                 Nothing -> show uri
 302                 Just b  -> show $ relativeFrom uri b
 303         in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of
 304             Nothing    -> ""
 305             Just ident -> showIdentity ansi' ident
 306
 307     displayUri :: MetaString a => URI -> a
 308     displayUri = colour Yellow . fromString . show
 309
 310     showUri :: URI -> ClientM ()
 311     showUri uri = do
 312         ais <- gets clientActiveIdentities
 313         liftIO . putStrLn $ showUriFull ansi ais Nothing uri
 314
 315     addToLog :: URI -> ClientM ()
 316     addToLog uri = do
 317         let t = T.pack $ show uri
 318         modify $ \s -> s
 319             { clientLog = BStack.push maxLogLen t $ clientLog s
 320             , clientVisited = S.insert (hash $ show uri) $ clientVisited s }
 321         unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH
 322
 323     preprocessQuery :: String -> ClientM String
 324     preprocessQuery = (escapeQuery <$>) . liftIO . maybeEdit
 325         where
 326             maybeEdit :: String -> IO String
 327             maybeEdit s | lastMay s == Just '\\' =
 328                 handle (\e -> printIOErr e >> pure s)
 329                     . doRestrictedFilter (editInteractively ansi userDataDir)
 330                     $ init s
 331             maybeEdit s = pure s
 332
 333     expand :: String -> String
 334     expand = expandHelp ansi (fst <$> aliases) userDataDir
 335
 336     idsPath = userDataDir </> "identities"
 337     savesDir = userDataDir </> "saves"
 338     marksDir = userDataDir </> "marks"
 339
 340     historyEnv :: HistoryItem -> ClientM [(String,String)]
 341     historyEnv item = gets clientActiveIdentities >>= \ais -> pure $
 342         [ ("URI", show $ historyUri item)
 343         , ("MIMETYPE", showMimeType $ historyMimedData item) ] <>
 344         (maybe [] (identityEnvironment idsPath) . idAtUri ais $ historyUri item)
 345
 346     setMark :: String -> URIWithIdName -> ClientM ()
 347     setMark mark uriId | markNameValid mark = do
 348         modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }
 349         unless (mark `elem` tempMarks) . liftIO .
 350             handle printIOErr $ saveMark marksDir mark uriId
 351     setMark mark _ = printErr $ "Invalid mark name " ++ mark
 352
 353     promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath
 354         where inputHistPath = userDataDir </> "inputHistory"
 355
 356     handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()
 357     handleCommandLine' mt mcas = void . runMaybeT $ do
 358         ts <- case mt of
 359             Nothing -> return []
 360             Just pt -> either ((>> mzero) . printErr)
 361                 (\ts -> mapM_ addTargetId ts >> return ts) $
 362                 resolveTarget cState pt
 363         case mcas of
 364             Nothing -> lift $ handleBareTargets ts
 365             Just (s,as) -> do
 366                 c' <- maybe (printErr (unknownCommand s) >> mzero)
 367                     return $ normaliseCommand s
 368                 lift $ handleCommand ts (c',as)
 369         where
 370         unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."
 371         addTargetId :: Target -> MaybeT ClientM ()
 372         addTargetId (TargetIdUri idName uri) =
 373             liftIO (loadIdentity idsPath idName) >>= (\case
 374                 (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero
 375                 (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero
 376                 (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,)
 377         addTargetId _ = return ()
 378
 379     doPage :: [T.Text] -> ClientM ()
 380     doPage ls
 381         | interactive = do
 382             (height,width) <- liftIO getTermSize
 383             let pageWidth = min maxWrapWidth (width - 4)
 384                 perPage = height - min 3 (height `div` 4)
 385                 doCmd str = get >>= \s -> doSubCommand s True str
 386             printLinesPaged pageWidth width perPage doCmd ls
 387         | otherwise = liftIO $ mapM_ T.putStrLn ls
 388
 389     handleBareTargets :: [Target] -> ClientM ()
 390     handleBareTargets [] = return ()
 391     handleBareTargets (_:_:_) =
 392         printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"
 393     handleBareTargets [TargetHistory item] = goHistory item
 394     handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri
 395     handleBareTargets [t] = goUri False Nothing $ targetUri t
 396
 397
 398     handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()
 399     handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =
 400         printErr "Command disabled in restricted mode"
 401     handleCommand [] ("help", args) = case args of
 402         []                 -> doPage . map (T.pack . expand) $ helpText
 403         CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s
 404     handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText
 405         where
 406         commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) ++
 407             ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)
 408         showAlias (a, Alias s _) = "{" <> a <> "}: " <> s
 409
 410     handleCommand [] ("mark", []) =
 411         let ms = M.toAscList marks
 412             markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m
 413                 in T.pack $ "'" <> m' <>
 414                     replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>
 415                     showUriWithId uriId
 416         in doPage $ markLine <$> ms
 417     handleCommand [] ("inventory",_) = do
 418         ais <- gets clientActiveIdentities
 419         let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text
 420             showNumberedUri iter s (n,uri) = s <>
 421                 (if iter && n == 1 then " "
 422                     else if iter && n == 2 then T.takeEnd 1 s
 423                     else T.pack (show n)) <>
 424                 " " <> showUriFull ansi ais Nothing uri
 425             showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item)
 426             showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item)
 427             showIteratedQueueItem s (n, QueueURI _ uri) =
 428                 showNumberedUri True s (n, uri)
 429             showIteratedQueueItem s (n, QueueHistory item) =
 430                 showNumberedUri True s (n, historyUri item) <> " {fetched}"
 431             showJumpBack :: [T.Text]
 432             showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack
 433         doPage . intercalate [""] . filter (not . null) $
 434             showJumpBack :
 435             [ showIteratedQueueItem (T.pack $ qname <> "~") <$> zip [1..] queue
 436                 | (qname, queue) <- M.toList queues ]
 437             ++ [ showNumberedItem "'" <$> M.toAscList sessionMarks
 438             , (showIteratedItem "<" <$> zip [1..] (maybe [] (initSafe . historyAncestors) curr))
 439             ++ (("@  " <>) . showUriFull ansi ais Nothing . historyUri <$>
 440                 maybeToList (curr >>= lastMay . historyAncestors))
 441             , showIteratedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)
 442             ]
 443     handleCommand [] ("log",_) =
 444         let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t
 445         in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)
 446     handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do
 447         c <- either ((>>mzero) . printErr) return $ parseCommand a
 448         when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero
 449         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 450         modify $ \s ->
 451                 s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }
 452     handleCommand [] ("alias", [CommandArg a _]) =
 453         modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }
 454     handleCommand [] ("set", []) = liftIO $ do
 455         let (c,args) = defaultAction
 456         putStrLn $ expand "{default_action}: " <> c <>
 457             maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)
 458         putStrLn $ expand "{proxies}:"
 459         printMap showHost $ M.toAscList proxies
 460         putStrLn $ expand "{geminators}:"
 461         printMap id $ second snd <$> geminators
 462         putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter
 463         putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt
 464         putStrLn $ expand "{link_desc_first}: " <> show linkDescFirst
 465         putStrLn $ expand "{log_length}: " <> show maxLogLen
 466         putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth
 467         putStrLn $ expand "{no_confirm}: " <> show noConfirm
 468         putStrLn $ expand "{verbose_connection}: " <> show verboseConnection
 469         where
 470             printMap :: (a -> String) -> [(String,a)] -> IO ()
 471             printMap f as = mapM_ putStrLn $
 472                 (\(k,e) -> "  " <> k <> " " <> f e) <$> as
 473     handleCommand [] ("set", CommandArg opt _ : val)
 474         | opt `isPrefixOf` "default_action" = case val of
 475             (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of
 476                 Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }
 477                 Nothing -> printErr "Invalid action"
 478             _ -> printErr "Require value for option."
 479         | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of
 480             (CommandArg scheme _ : val') ->
 481                 let f = maybe (M.delete scheme) (M.insert scheme) $
 482                         parseHost . commandArgLiteralTail =<< headMay val'
 483                 in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }
 484                     -- if only I'd allowed myself to use lenses, eh?
 485             [] -> printErr "Require mimetype to set geminator for."
 486         | opt `isPrefixOf` "geminators" = case val of
 487             (CommandArg patt _ : val') ->
 488                 let f = maybe (filter $ (/= patt) . fst)
 489                         (\v -> (++ [(patt, (mkRegexWithOpts patt True True,
 490                             commandArgLiteralTail v))])) $
 491                         headMay val'
 492                 in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }
 493             [] -> printErr "Require mimetype to set geminator for."
 494         | opt `isPrefixOf` "render_filter" =
 495             modifyCConf $ \c -> c { clientConfRenderFilter =
 496                 commandArgLiteralTail <$> headMay val }
 497         | opt `isPrefixOf` "pre_display" = case val of
 498             [CommandArg s _] | map toLower s `isPrefixOf` "both" ->
 499                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }
 500             [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->
 501                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }
 502             [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->
 503                 modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }
 504             _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"
 505         | opt `isPrefixOf` "link_desc_first" = case val of
 506             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 507                 modifyCConf $ \c -> c { clientConfLinkDescFirst = True }
 508             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 509                 modifyCConf $ \c -> c { clientConfLinkDescFirst = False }
 510             _ -> printErr "Require \"true\" or \"false\" as value for link_desc_first"
 511         | opt `isPrefixOf` "log_length" = case val of
 512             [CommandArg s _] | Just n <- readMay s, n >= 0 -> do
 513                 modifyCConf $ \c -> c { clientConfMaxLogLen = n }
 514                 modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }
 515             _ -> printErr "Require non-negative integer value for log_length"
 516         | opt `isPrefixOf` "max_wrap_width" = case val of
 517             [CommandArg s _] | Just n <- readMay s, n > 0 ->
 518                 modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }
 519             _ -> printErr "Require positive integer value for max_wrap_width"
 520         | opt `isPrefixOf` "no_confirm" = case val of
 521             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 522                 modifyCConf $ \c -> c { clientConfNoConfirm = True }
 523             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 524                 modifyCConf $ \c -> c { clientConfNoConfirm = False }
 525             _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"
 526         | opt `isPrefixOf` "verbose_connection" = case val of
 527             [CommandArg s _] | map toLower s `isPrefixOf` "true" ->
 528                 modifyCConf $ \c -> c { clientConfVerboseConnection = True }
 529             [CommandArg s _] | map toLower s `isPrefixOf` "false" ->
 530                 modifyCConf $ \c -> c { clientConfVerboseConnection = False }
 531             _ -> printErr "Require \"true\" or \"false\" as value for verbose_connection"
 532         | otherwise = printErr $ "No such option \"" <> opt <> "\"."
 533     handleCommand [] cargs =
 534         case curr of
 535             Just item -> handleCommand [TargetHistory item] cargs
 536             Nothing -> printErr "No current location. Enter an URI, or type \"help\"."
 537
 538     handleCommand ts ("add", args) = case parseQueueSpec $ commandArgArg <$> args of
 539         Nothing          -> printErr "Bad arguments to 'add'."
 540         Just qs -> modifyQueues . enqueue qs $ targetQueueItem <$> ts
 541
 542     handleCommand ts ("fetch", args) = case parseQueueSpec $ commandArgArg <$> args of
 543         Nothing -> printErr "Bad arguments to 'fetch."
 544         Just qs -> do
 545             -- XXX: we have to use an IORef to store the items, since
 546             -- CommandAction doesn't allow a return value.
 547             lRef <- liftIO $ newIORef []
 548             let add item = liftIO $ slurpItem item >> modifyIORef lRef (item:)
 549             forM_ ts $ \t -> case t of
 550                 TargetHistory item -> add item
 551                 _ -> modifyQueues (unqueue uri) >> doRequestUri uri add
 552                     where uri = targetUri t
 553             l <- liftIO $ reverse <$> readIORef lRef
 554             modifyQueues . enqueue qs $ QueueHistory <$> l
 555
 556     handleCommand ts cargs =
 557         mapM_ handleTargetCommand ts
 558         where
 559         handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =
 560             action item
 561         handleTargetCommand t | Just action <- actionOfCommand cargs =
 562             let uri = targetUri t
 563             in modifyQueues (unqueue uri) >> doRequestUri uri action
 564         handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =
 565             goUri True (recreateOrigin <$> historyParent item) $ historyUri item
 566         handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =
 567             repl (recreateOrigin <$> historyParent item) $ historyUri item
 568         handleTargetCommand t | ("query", CommandArg _ str : _) <- cargs = do
 569             let origin = case t of
 570                     TargetHistory item -> Just $ HistoryOrigin item Nothing
 571                     TargetFrom o _     -> Just o
 572                     _                  -> Nothing
 573             str' <- preprocessQuery str
 574             goUri True origin . setQuery ('?':str') $ targetUri t
 575         handleTargetCommand t =
 576             handleUriCommand (targetUri t) cargs
 577
 578         recreateOrigin :: HistoryItem -> HistoryOrigin
 579         recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent
 580
 581         handleUriCommand uri ("delete",[]) =
 582             modifyQueues $ unqueueFrom "" uri
 583         handleUriCommand uri ("delete",CommandArg qname _ : _) =
 584             modifyQueues $ unqueueFrom qname uri
 585         handleUriCommand uri ("repeat",_) = goUri True Nothing uri
 586         handleUriCommand uri ("uri",_) = showUri uri
 587         handleUriCommand uri ("mark", CommandArg mark _ : _)
 588             | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"
 589             | otherwise = do
 590             ais <- gets clientActiveIdentities
 591             let mIdName = case findIdentity ais =<< requestOfUri uri of
 592                     Just ident | not $ isTemporary ident -> Just $ identityName ident
 593                     _ -> Nothing
 594             setMark mark $ URIWithIdName uri mIdName
 595         handleUriCommand uri ("identify", args) = case requestOfUri uri of
 596             Nothing -> printErr "Bad URI"
 597             Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case
 598                 Just (root,(ident,_)) | null args -> endIdentityPrompted root ident
 599                 _ -> void . runMaybeT $ do
 600                     ident <- MaybeT . liftIO $ case args of
 601                         CommandArg idName _ : args' ->
 602                             let tp = case args' of
 603                                     CommandArg ('e':'d':_) _ : _ -> KeyEd25519
 604                                     _                            -> KeyRSA
 605                             in getIdentity interactive ansi idsPath tp idName
 606                         [] -> if interactive
 607                             then getIdentityRequesting ansi idsPath
 608                             else getIdentity interactive ansi idsPath KeyRSA ""
 609                     lift $ addIdentity req ident
 610         handleUriCommand uri ("browse", args) = do
 611             ais <- gets clientActiveIdentities
 612             let envir = maybe [] (identityEnvironment idsPath) .
 613                     idAtUri ais . setSchemeDefault $ uri
 614             void . liftIO . runMaybeT $ do
 615                 cmd <- case args of
 616                     [] -> maybe notSet
 617                         (\s -> if null s then notSet else return $ parseBrowser s) =<<
 618                             lift (lookupEnv "BROWSER")
 619                         where
 620                         notSet = printErr "Please set $BROWSER or give a command to run" >> mzero
 621                         -- |based on specification for $BROWSER in 'man 1 man'
 622                         parseBrowser :: String -> String
 623                         parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')
 624                     (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c
 625                 lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd envir)
 626         handleUriCommand uri ("repl",_) = repl Nothing uri
 627         handleUriCommand uri ("log",_) = addToLog uri >> modifyQueues (unqueue uri)
 628
 629         handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c
 630
 631         repl :: Maybe HistoryOrigin -> URI -> ClientM ()
 632         repl origin uri = repl' where
 633             repl' = liftIO (join <$> promptInput ">> ") >>= \case
 634                 Nothing -> return ()
 635                 Just query -> do
 636                     query' <- preprocessQuery query
 637                     goUri True origin . setQuery ('?':query') $ uri
 638                     repl'
 639
 640     slurpItem :: HistoryItem -> IO ()
 641     slurpItem item = slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item
 642
 643     actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction
 644     actionOnRendered ansi' m item = do
 645         ais <- gets clientActiveIdentities
 646         liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=
 647             either printErr m
 648
 649     actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction
 650     actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing
 651     actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn
 652     actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage
 653     actionOfCommand ("links",_) = Just $ \item -> do
 654         ais <- gets clientActiveIdentities
 655         let cl = childLink =<< historyChild item
 656             linkLine n (Link uri desc) =
 657                 applyIf (cl == Just (n-1)) (bold "* " <>) $
 658                 T.pack ('[' : show n ++ "] ")
 659                     <> showUriRefFull ansi ais (historyUri item) uri
 660                     <> if T.null desc then "" else " " <>
 661                         applyIf ansi (withColourStr Cyan) desc
 662         doPage . zipWith linkLine [1..] . historyLinks $ item
 663
 664     actionOfCommand ("mark", CommandArg mark _ : _) |
 665         Just n <- readMay mark :: Maybe Int = Just $ \item -> do
 666             liftIO $ slurpItem item
 667             modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }
 668     actionOfCommand ("mime",_) = Just $ liftIO . putStrLn . showMimeType . historyMimedData
 669     actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])
 670     actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do
 671         createDirectoryIfMissing True savesDir
 672         homePath <- getHomeDirectory
 673         let path'
 674                 | take 2 path == "~/" = homePath </> drop 2 path
 675                 | take 1 path == "/" || take 2 path == "./" || take 3 path == "../" = path
 676                 | otherwise = savesDir </> path
 677             body = mimedBody $ historyMimedData item
 678             uri = historyUri item
 679             name = fromMaybe (fromMaybe "" $ uriRegName uri) . lastMay .
 680                 filter (not . null) $ pathSegments uri
 681         handle printIOErr . void . runMaybeT $ do
 682             lift $ mkdirhierto path'
 683             isDir <- lift $ doesDirectoryExist path'
 684             let fullpath = if isDir then path' </> name else path'
 685             lift (doesDirectoryExist fullpath) >>? do
 686                 lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"
 687                 mzero
 688             lift (doesFileExist fullpath) >>?
 689                 guard =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")
 690             lift $ do
 691                 putStrLn $ "Saving to " ++ fullpath
 692                 t0 <- timeCurrentP
 693                 BL.writeFile fullpath =<< interleaveProgress t0 body
 694
 695     actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> do
 696         env <- historyEnv item
 697         liftIO . handle printIOErr . doRestricted .
 698             shellOnData noConfirm cmd userDataDir env . mimedBody $ historyMimedData item
 699
 700     actionOfCommand ("view",_) = Just $ \item ->
 701         let mimed = historyMimedData item
 702             mimetype = showMimeType mimed
 703             body = mimedBody mimed
 704         in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body
 705     actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> do
 706         env <- historyEnv item
 707         liftIO . handle printIOErr . doRestricted $
 708             pipeToShellLazily cmd env . mimedBody $ historyMimedData item
 709     actionOfCommand ("||", args) = Just $ pipeRendered ansi args
 710     actionOfCommand ("||-", args) = Just $ pipeRendered False args
 711     actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData
 712     actionOfCommand ("at", CommandArg _ str : _) = Just $ \item ->
 713         doSubCommand (cState { clientCurrent = Just item }) blockGo str
 714     actionOfCommand _ = Nothing
 715
 716     pipeRendered :: Bool -> [CommandArg] -> CommandAction
 717     pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls -> do
 718         env <- historyEnv item
 719         liftIO . void . runMaybeT $ do
 720             cmd <- case args of
 721                 [] -> maybe notSet
 722                     (\s -> if null s then notSet else return s) =<<
 723                     liftIO (lookupEnv "PAGER")
 724                     where
 725                     notSet = printErr "Please set $PAGER or give a command to run" >> mzero
 726                 (CommandArg _ cmd : _) -> return cmd
 727             lift . doRestricted . pipeToShellLazily cmd env . T.encodeUtf8 $ T.unlines ls
 728
 729     doSubCommand :: ClientState -> Bool -> String -> ClientM ()
 730     doSubCommand s block str = void . runMaybeT $ do
 731         cl <- either ((>>mzero) . printErr) return $ parseCommandLine str
 732         lift $ handleCommandLine cOpts s block cl
 733
 734     setCurr :: HistoryItem -> ClientM ()
 735     setCurr i =
 736         let isJump = isNothing $ curr >>= pathItemByUri i . historyUri
 737         in do
 738             when isJump $ modify $ \s -> s { clientJumpBack = curr }
 739             modify $ \s -> s { clientCurrent = Just i }
 740
 741     doDefault :: HistoryItem -> ClientM ()
 742     doDefault item =
 743         maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction
 744
 745     goHistory :: HistoryItem -> ClientM ()
 746     goHistory _ | blockGo = printErr "Can't go anywhere now."
 747     goHistory item = do
 748         modifyQueues $ unqueue uri
 749         showUri uri
 750         setCurr item
 751         doDefault item
 752         where uri = historyUri item
 753
 754     goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()
 755     goUri _ _ _ | blockGo = printErr "Can't go anywhere now."
 756     goUri forceRequest origin uri = do
 757         modifyQueues $ unqueue uri
 758         activeId <- gets $ isJust . (`idAtUri` uri) . clientActiveIdentities
 759         case curr >>= flip pathItemByUri uri of
 760             Just i' | not (activeId || forceRequest) -> goHistory i'
 761             _ -> doRequestUri uri $ \item -> do
 762                 let updateParent i =
 763                         -- Lazily recursively update the links in the doubly linked list
 764                         let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }
 765                         in i'
 766                     updateChild i' i = i { historyChild = setChild <$> historyChild i }
 767                         where setChild c = c { childItem = i' }
 768                     glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }
 769                     item' = item { historyParent = glueOrigin <$> origin }
 770                 setCurr item'
 771                 doDefault item
 772                 liftIO $ slurpItem item
 773
 774     doRequestUri :: URI -> CommandAction -> ClientM ()
 775     doRequestUri uri0 action = doRequestUri' 0 uri0
 776         where
 777         doRequestUri' redirs uri
 778             | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req
 779             | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (
 780                     let scheme = uriScheme uri
 781                     in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)
 782                     then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"
 783                     else "")
 784
 785         doRequest :: Int -> Request -> ClientM ()
 786         doRequest redirs _ | redirs > 5 =
 787             printErr "Too many redirections!"
 788         doRequest redirs req@(NetworkRequest _ uri) = do
 789             (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities
 790             modify $ \s -> s { clientActiveIdentities = ais }
 791             printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri
 792             let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream
 793             liftIO (makeRequest requestContext mId respBuffSize verboseConnection req)
 794                 `bracket` either (\_ -> return ()) (liftIO . snd) $
 795                 either
 796                     (printErr . displayException)
 797                     (handleResponse . fst)
 798             where
 799             handleResponse :: Response -> ClientM ()
 800             handleResponse (Input isPass prompt) = do
 801                 let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"
 802                 (liftIO . (join <$>) . promptInput $
 803                         (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case
 804                     Nothing -> return ()
 805                     Just query -> do
 806                         query' <- preprocessQuery query
 807                         doRequestUri' redirs . setQuery ('?':query') $ uri
 808
 809             handleResponse (Success mimedData) = doAction req mimedData
 810
 811             handleResponse (Redirect isPerm to) = do
 812                 ais <- gets clientActiveIdentities
 813                 let uri' = to `relativeTo` uri
 814                     crossSite = uriRegName uri' /= uriRegName uri
 815                     crossScheme = uriScheme uri' /= uriScheme uri
 816                     crossScope = case idAtUri ais <$> [uri,uri'] of
 817                             [fromId,toId] -> isJust toId && fromId /= toId
 818                             _             -> False
 819                     warningStr = colour BoldRed
 820                 proceed <- (isJust <$>) . lift . runMaybeT $ do
 821                     when crossSite $ guard <=< (liftIO . promptYN False) $
 822                         warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 823                     when crossScheme $ guard <=< (liftIO . promptYN False) $
 824                         warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 825                     when crossScope $ guard <=< (liftIO . promptYN False) $
 826                         warningStr "Follow redirect with identity " ++ showUriRefFull ansi ais uri to ++ warningStr "?"
 827                 when proceed $ do
 828                     when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks
 829                     doRequestUri' (redirs + 1) uri'
 830                 where updateMark uri' (mark,uriId) = do
 831                         conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"
 832                         when conf . setMark mark $ uriId { uriIdUri = uri' }
 833             handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do
 834                 identity <- do
 835                         liftIO . putStrLn $ (case code of
 836                             60 -> "Server requests identification"
 837                             _ -> "Server rejects provided identification certificate" ++
 838                                 (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))
 839                             ++ if null info then "" else ": " ++ info
 840                         guard interactive
 841                         MaybeT . liftIO $ getIdentityRequesting ansi idsPath
 842                 lift $ do
 843                     addIdentity req identity
 844                     doRequest redirs req
 845
 846             handleResponse (Failure code info) =
 847                 printErr $ "Server returns failure: " ++ show code ++ " " ++ info
 848             handleResponse (MalformedResponse malformation) =
 849                 printErr $ "Malformed response from server: " ++ show malformation
 850
 851         doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."
 852             | otherwise = void . runMaybeT $ do
 853                 (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do
 854                     let detectExtension = case takeExtension path of
 855                             -- |certain crucial filetypes we can't rely on magic to detect:
 856                             s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"
 857                             ".md" -> Just "text/markdown"
 858                             ".html" -> Just "text/html"
 859                             _ -> Nothing
 860 #ifdef MAGIC
 861                         detectPlain "text/plain" = fromMaybe "text/plain" detectExtension
 862                         detectPlain s = s
 863                     magic <- Magic.magicOpen [Magic.MagicMimeType]
 864                     Magic.magicLoadDefault magic
 865                     s <- detectPlain <$> Magic.magicFile magic path
 866 #else
 867                     let s = if "/" `isSuffixOf` path then "inode/directory"
 868                             else fromMaybe "application/octet-stream" detectExtension
 869 #endif
 870                     case MIME.parseMIMEType $ TS.pack s of
 871                         Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing
 872                         _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .
 873                             T.encodeUtf8 . T.unlines .
 874                             ((("=> " <>) . T.pack . escapePathString) <$>) . sort <$>
 875                                 getDirectoryContents path
 876                             where slashedPath | "/" `isSuffixOf` path = path
 877                                     | otherwise = path <> "/"
 878                         Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path
 879                 lift $ doAction (LocalFileRequest path') mimedData
 880
 881         doAction req mimedData = do
 882             t0 <- liftIO timeCurrentP
 883             geminated <- geminate mimedData
 884             action $ HistoryItem req t0 mimedData geminated Nothing Nothing
 885             where
 886             -- |returns MimedData with lazy IO
 887             geminate :: MimedData -> ClientM MimedData
 888             geminate mimed =
 889                 let geminator = lookupGeminator $ showMimeType mimed
 890                 in liftIO . unsafeInterleaveIO $ applyGeminator geminator
 891                 where
 892                 lookupGeminator mimetype =
 893                     listToMaybe [ gem | (_, (regex, gem)) <- geminators
 894                         , isJust $ matchRegex regex mimetype ]
 895                 applyGeminator Nothing = return mimed
 896                 applyGeminator (Just cmd) =
 897                     printInfo ("| " <> cmd) >>
 898                     MimedData gemTextMimeType <$>
 899                         doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)
 900
 901         gemTextMimeType :: MIME.Type
 902         gemTextMimeType = MIME.Type (MIME.Text "gemini") []
 903
 904
 905     addIdentity :: Request -> Identity -> ClientM ()
 906     addIdentity req identity = do
 907         ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity
 908         modify $ \s -> s {clientActiveIdentities = ais}
 909     endIdentityPrompted :: Request -> Identity -> ClientM ()
 910     endIdentityPrompted root ident = do
 911         conf <- confirm $ liftIO . promptYN False $ "Stop using " ++
 912             (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) ++
 913             " at " ++ displayUri (requestUri root) ++ "?"
 914         when conf . modify $ \s ->
 915                 s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }
 916
 917     renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])
 918     renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of
 919         MIME.Text textType -> do
 920             let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v
 921                 extractCharsetParam _                            = Nothing
 922                 charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime
 923                 isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]
 924 #ifdef ICONV
 925                 reencoder = if isUtf8 then id else
 926                     convert charset "UTF-8"
 927 #else
 928                 reencoder = id
 929             unless isUtf8 . printErr $
 930                 "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"
 931 #endif
 932             (_,width) <- getTermSize
 933             let pageWidth = if interactive
 934                 then min maxWrapWidth (width - 4)
 935                 else maxWrapWidth
 936             let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body
 937                 applyFilter :: [T.Text] -> IO [T.Text]
 938                 applyFilter = case renderFilter of
 939                     Nothing -> return
 940                     Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .
 941                         doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)
 942                         where appendNewline = (`BL.snoc` 10)
 943             (Right <$>) . applyFilter $ case textType of
 944                     "gemini" ->
 945                         let opts = GemRenderOpts ansi' preOpt pageWidth linkDescFirst
 946                         in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText
 947                     _ -> T.stripEnd . stripControl <$> T.lines bodyText
 948         mimeType ->
 949             return . Left $ "No geminator for " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " configured. Try \"save\", \"view\", \"!\", or \"|\"?"